DIRECTORY
Alloc USING [Notifier],
Basics USING [bitsPerWord],
Code USING [caseCVState, catchcount, CodeNotImplemented, curctxlvl],
CodeDefs USING [Base, Byte, codeType, JumpType, LabelCCIndex, LabelInfoRecord, LabelInfoIndex, LabelInfoNull, Lexeme, NamedLabelInfoIndex, NullLex, VarComponent, VarIndex],
FOpCodes USING [qDCOMP, qDUCOMP, qFCOMP, qLI, qLL, qLP, qOR, qPUSH, qSFC],
Literals USING [Base, LTIndex, ltType],
P5 USING [Exp, FreeHeapLex, GenAnonLex, LogHeapFree, PushLex, PushRhs, StatementTree, SysCall, TypeRel],
P5L USING [EasilyLoadable, FieldOfVar, InCode, LoadAddress, LoadBoth, LoadComponent, LoadVar, LongVarAddress, MakeComponent, ReusableCopies, VarAlignment, VarForLex, Words],
P5S USING [],
P5U USING [FreeChunk, GetChunk, InsertLabel, LabelAlloc, Out0, Out1, OutJump, PushLitVal, TreeLiteral, TreeLiteralValue],
PrincOps USING [localbase, returnOffset, sBLTE, sBLTEC, sBLTECL, sBLTEL],
Stack USING [Decr, Dump, Incr, Mark, Require],
Symbols USING [HTIndex],
Tree USING [Base, Index, Link, NodeName, Null, treeType],
TreeOps USING [GetHash, GetNode, ScanList];
Flow:
PROGRAM
IMPORTS CPtr: Code, P5U, P5L, P5, TreeOps, Stack
EXPORTS CodeDefs, P5, P5S = BEGIN OPEN CodeDefs;
imported definitions
wordlength: CARDINAL = Basics.bitsPerWord;
HTIndex: TYPE = Symbols.HTIndex;
labelStack: LabelInfoIndex ← LabelInfoNull;
UndeclaredLabel: SIGNAL [HTIndex] = CODE;
tb: Tree.Base; -- tree base (local copy)
cb: CodeDefs.Base; -- code base (local copy)
ltb: Literals.Base; -- literal table
FlowNotify:
PUBLIC Alloc.Notifier =
BEGIN -- called by allocator whenever table area is repacked
tb ← base[Tree.treeType];
cb ← base[codeType];
ltb ← base[Literals.ltType];
END;
JumpNN:
PACKED
ARRAY Tree.NodeName[relE..relLE]
OF JumpType ← [
relE:JumpE, relN:JumpN, relL:JumpL, relGE:JumpGE, relG:JumpG, relLE:JumpLE];
UJumpNN:
PACKED
ARRAY Tree.NodeName[relE..relLE]
OF JumpType ← [
relE:JumpE, relN:JumpN, relL:UJumpL, relGE:UJumpGE, relG:UJumpG, relLE:UJumpLE];
RNN:
ARRAY Tree.NodeName[relE..relLE]
OF Tree.NodeName = [
relE:relE, relN:relN, relL:relG, relGE:relLE, relG:relL, relLE:relGE];
CNN:
ARRAY Tree.NodeName[relE..relLE]
OF Tree.NodeName = [
relE:relN, relN:relE, relL:relGE, relGE:relL, relG:relLE, relLE:relG];
FlowTree:
PUBLIC
PROC [t: Tree.Link, tf:
BOOL, label: LabelCCIndex] =
BEGIN -- produces code to jump to label on condition tf
node: Tree.Index;
WITH t
SELECT
FROM
symbol =>
BEGIN
l: Lexeme.se = [se[index]];
P5.PushLex[l];
P5U.PushLitVal[0];
P5U.OutJump[IF tf THEN JumpN ELSE JumpE, label];
END;
subtree =>
BEGIN
node ← index;
SELECT tb[node].name
FROM
and, or =>
BEGIN ENABLE P5.LogHeapFree => RESUME [FALSE, NullLex];
label1: LabelCCIndex;
sw: BOOL = (IF tb[node].name = and THEN tf ELSE ~tf);
IF sw
THEN
BEGIN
label1←P5U.LabelAlloc[];
FlowTree[tb[node].son[1], ~tf, label1];
FlowTree[tb[node].son[2], tf, label];
P5U.InsertLabel[label1];
END
ELSE
BEGIN
FlowTree[tb[node].son[1], tf, label];
FlowTree[tb[node].son[2], tf, label];
END;
END;
not => FlowTree[tb[node].son[1], ~tf, label];
cast => FlowTree[tb[node].son[1], tf, label]; -- ignore casts
in => FlowIn[t, tf, label];
notin => FlowIn[t, ~tf, label];
relE, relN, relL, relGE, relG, relLE => SFRel[node, tf, label];
istype => P5.TypeRel[node, tf, label];
ENDCASE =>
-- must be a BOOL expression
BEGIN
P5.PushRhs[t];
P5U.PushLitVal[0];
P5U.OutJump[IF tf THEN JumpN ELSE JumpE, label];
END;
END;
literal =>
BEGIN
val: CARDINAL = P5U.TreeLiteralValue[t];
IF tf = (val # 0) THEN P5U.OutJump[Jump, label];
END;
ENDCASE;
END;
SFRel:
PROC [node: Tree.Index, tf:
BOOL, label: LabelCCIndex] =
BEGIN -- main subroutine of Cflow for handling relationals
t1: Tree.Link ← tb[node].son[1];
t2: Tree.Link;
n: Tree.NodeName ← tb[node].name;
hLex1, hLex2: Lexeme.se ← NullLex;
r1, r2: VarIndex;
IF P5U.TreeLiteral[t1] THEN {n ← RNN[n]; t2 ← t1; t1 ← tb[node].son[2]}
ELSE t2 ← tb[node].son[2];
IF ~tf THEN n ← CNN[n];
r1 ← P5L.VarForLex[P5.Exp[t1 ! P5.LogHeapFree =>
IF calltree = t1 THEN RESUME [TRUE, hLex1 ← P5.GenAnonLex[1]]
ELSE RESUME [FALSE, NullLex]]];
r2 ← P5L.VarForLex[P5.Exp[t2 ! P5.LogHeapFree =>
IF calltree = t2 THEN RESUME [TRUE, hLex2 ← P5.GenAnonLex[1]]
ELSE RESUME [FALSE, NullLex]]];
VarVarComp[
r1: r1, r2: r2, n: n,
real: tb[node].attr1, signed: tb[node].attr3,
hLex1: hLex1, hLex2: hLex2, label: label,
commutable: t1 # Tree.Null OR CPtr.caseCVState = multi];
END;
VarVarComp:
PROC [
r1, r2: VarIndex, n: Tree.NodeName, real, signed: BOOL,
hLex1, hLex2: Lexeme.se, label: LabelCCIndex,
commutable: BOOL ← FALSE] =
BEGIN
wSize: CARDINAL;
bSize, bd1, bd2: [0..wordlength);
nw: CARDINAL;
FreeHeapNodes:
PROC =
BEGIN
IF hLex1 # NullLex THEN P5.FreeHeapLex[hLex1];
IF hLex2 # NullLex THEN P5.FreeHeapLex[hLex2];
hLex1 ← hLex2 ← NullLex;
END;
[wSize: wSize, bSize: bSize, bd: bd1] ← P5L.VarAlignment[r1, load];
[bd: bd2] ← P5L.VarAlignment[r2, load];
nw ← P5L.Words[wSize, bSize]; -- r1 and r2 are same size if > 1
IF nw > 1 AND bd1 # bd2 THEN SIGNAL CPtr.CodeNotImplemented;
IF nw <= 2
THEN
BEGIN
c1: VarComponent ← P5L.MakeComponent[r1];
c2: VarComponent ← P5L.MakeComponent[r2];
BEGIN
IF n = relE
OR n = relN
THEN
WITH c2
SELECT
FROM
const =>
IF wSize = 2
AND bSize = 0
AND ~real
AND d1 = 0
AND d2 = 0
THEN
BEGIN
P5L.LoadComponent[c1];
P5U.Out0[FOpCodes.qOR];
GO TO double;
END;
ENDCASE;
P5L.LoadBoth[@c1, @c2, (n = relE OR n = relN) AND commutable];
IF nw = 2
THEN
BEGIN
P5U.Out0[
IF real
THEN FOpCodes.qFCOMP
ELSE IF signed THEN FOpCodes.qDCOMP ELSE FOpCodes.qDUCOMP];
GO TO double;
END;
FreeHeapNodes[];
EXITS
double => {FreeHeapNodes[]; P5U.Out1[FOpCodes.qLI, 0]};
END;
P5U.OutJump[IF signed OR nw = 2 THEN JumpNN[n] ELSE UJumpNN[n], label];
END
ELSE
BEGIN -- multiword quantities, n = relE or relN
IF bSize = 0
THEN
BEGIN
code: BOOL ← FALSE;
long1, long2: BOOL;
CompFn:
ARRAY
BOOL
OF
ARRAY
BOOL
OF Byte = [
[PrincOps.sBLTE, PrincOps.sBLTEL], [PrincOps.sBLTEC, PrincOps.sBLTECL]];
Stack.Dump[]; Stack.Mark[]; -- so procedure call will work
IF P5L.InCode[r1] THEN {tr: VarIndex = r1; r1 ← r2; r2 ← tr};
IF P5L.InCode[r2] THEN code ← TRUE;
long2 ← P5L.LongVarAddress[r2];
long1 ← P5L.LoadAddress[r: r1, codeOk: FALSE];
IF ~long1 AND long2 THEN {P5U.Out0[FOpCodes.qLP]; long1 ← TRUE};
P5U.Out1[FOpCodes.qLI, nw];
[] ← P5L.LoadAddress[r: r2, codeOk: TRUE];
IF ~code AND long1 AND ~long2 THEN P5U.Out0[FOpCodes.qLP];
P5.SysCall[CompFn[code][long1]];
Stack.Incr[1];
FreeHeapNodes[];
P5U.Out1[FOpCodes.qLI, 0];
P5U.OutJump[IF n # relE THEN JumpE ELSE JumpN, label]
END
ELSE
BEGIN -- do in two pieces
r1a, r1b: VarIndex;
r2a, r2b: VarIndex;
firstEq, secondComp: LabelCCIndex;
[first: r1b, next: r1a] ← P5L.ReusableCopies[r1, load, FALSE];
[first: r2b, next: r2a] ← P5L.ReusableCopies[r2, load, FALSE];
IF bd1 # 0
THEN
BEGIN
P5L.FieldOfVar[r: r1b, bSize: bSize];
P5L.FieldOfVar[r: r1a, bd: bSize, wSize: wSize];
P5L.FieldOfVar[r: r2b, bSize: bSize];
P5L.FieldOfVar[r: r2a, bd: bSize, wSize: wSize];
END
ELSE
BEGIN
P5L.FieldOfVar[r: r1b, wSize: wSize];
P5L.FieldOfVar[r: r1a, wd: wSize, bSize: bSize];
P5L.FieldOfVar[r: r2b, wSize: wSize];
P5L.FieldOfVar[r: r2a, wd: wSize, bSize: bSize];
END;
secondComp ← P5U.LabelAlloc[];
IF n = relN THEN firstEq ← label
ELSE firstEq ← P5U.LabelAlloc[];
VarVarComp[r1b, r2b, relE, real, signed, NullLex, NullLex, secondComp];
FreeHeapNodes[]; -- this looks awful here, but Final sorts it all out
P5U.OutJump[Jump, firstEq];
P5U.InsertLabel[secondComp];
VarVarComp[r1a, r2a, n, real, signed, hLex1, hLex2, label];
IF n # relN THEN P5U.InsertLabel[firstEq];
END;
END;
END;
FlowIn:
PROC [t: Tree.Link, tf:
BOOL, label: LabelCCIndex] =
BEGIN -- generates code for IN expression in flow context
node: Tree.Index = TreeOps.GetNode[t];
t1: Tree.Link = tb[node].son[1];
subNode: Tree.Index = TreeOps.GetNode[tb[node].son[2]]; -- interval node
n: Tree.NodeName = tb[subNode].name;
real: BOOL = tb[subNode].attr1;
double: BOOL = real OR tb[subNode].attr2;
signed: BOOL = tb[subNode].attr3;
tLow: Tree.Link = tb[subNode].son[1];
tUp: Tree.Link = tb[subNode].son[2];
jumpNN:
POINTER
TO
PACKED
ARRAY Tree.NodeName[relE..relLE]
OF JumpType ←
IF double OR signed THEN @JumpNN ELSE @UJumpNN;
r1: VarIndex;
hLex: Lexeme.se ← NullLex;
IF real
THEN
IF t = Tree.Null
AND CPtr.caseCVState = singleLoaded
THEN
Stack.Require[1]
ELSE Stack.Dump[];
r1 ← P5L.VarForLex[P5.Exp[t1 ! P5.LogHeapFree =>
IF calltree = t1 THEN RESUME [TRUE, hLex ← P5.GenAnonLex[1]]
ELSE RESUME [FALSE, NullLex]]];
IF ~real
AND Zero[tLow]
AND (~signed
OR Constant[tUp])
AND (n = intCO
OR n = intCC)
THEN
BEGIN
P5L.LoadVar[r1];
IF hLex # NullLex THEN {P5.FreeHeapLex[hLex]; hLex ← NullLex};
P5.PushRhs[tUp ! P5.LogHeapFree =>
IF calltree = tUp THEN RESUME [TRUE, hLex ← P5.GenAnonLex[1]]
ELSE RESUME [FALSE, NullLex]];
IF double
THEN
{P5U.Out0[FOpCodes.qDUCOMP]; P5U.PushLitVal[0]; jumpNN ← @JumpNN}
ELSE jumpNN ← @UJumpNN;
IF hLex # NullLex THEN {P5.FreeHeapLex[hLex]; hLex ← NullLex};
SELECT n
FROM
intCO => P5U.OutJump[IF tf THEN jumpNN[relL] ELSE jumpNN[relGE], label];
intCC => P5U.OutJump[IF tf THEN jumpNN[relLE] ELSE jumpNN[relG], label];
ENDCASE;
END
ELSE
BEGIN
fail: LabelCCIndex = P5U.LabelAlloc[];
OutDComp:
PROC =
BEGIN
P5U.Out0[
IF real
THEN FOpCodes.qFCOMP
ELSE IF signed THEN FOpCodes.qDCOMP ELSE FOpCodes.qDUCOMP];
P5U.PushLitVal[0];
END;
var1: VarComponent ← P5L.MakeComponent[r1];
IF double THEN var1 ← P5L.EasilyLoadable[var1, load];
P5L.LoadComponent[var1];
IF hLex # NullLex THEN {P5.FreeHeapLex[hLex]; hLex ← NullLex};
P5.PushRhs[tLow ! P5.LogHeapFree =>
IF calltree = tLow THEN RESUME [TRUE, hLex ← P5.GenAnonLex[1]]
ELSE RESUME [FALSE, NullLex]];
IF double THEN OutDComp[];
IF hLex # NullLex THEN {P5.FreeHeapLex[hLex]; hLex ← NullLex};
SELECT n
FROM
intOO,intOC => P5U.OutJump[jumpNN[relLE], IF tf THEN fail ELSE label];
intCO,intCC => P5U.OutJump[jumpNN[relL], IF tf THEN fail ELSE label];
ENDCASE;
IF double THEN P5L.LoadComponent[var1]
ELSE P5U.Out0[FOpCodes.qPUSH];
P5.PushRhs[tUp ! P5.LogHeapFree =>
IF calltree = tUp THEN RESUME [TRUE, hLex ← P5.GenAnonLex[1]]
ELSE RESUME [FALSE, NullLex]];
IF double THEN OutDComp[];
IF hLex # NullLex THEN P5.FreeHeapLex[hLex];
SELECT n
FROM
intOO,intCO => P5U.OutJump[IF tf THEN jumpNN[relL] ELSE jumpNN[relGE], label];
intOC,intCC => P5U.OutJump[IF tf THEN jumpNN[relLE] ELSE jumpNN[relG], label];
ENDCASE;
P5U.InsertLabel[fail];
END;
END;
Constant:
PROC [t: Tree.Link]
RETURNS [
BOOL] =
BEGIN
RETURN [
WITH t
SELECT
FROM
literal => TRUE,
subtree => tb[index].name = mwconst,
ENDCASE => FALSE]
END;
Zero:
PROC [t: Tree.Link]
RETURNS [
BOOL] =
BEGIN
lti: Literals.LTIndex;
WITH lt: t
SELECT
FROM
literal =>
WITH l: lt.index
SELECT
FROM
word => lti ← l.lti;
ENDCASE => RETURN [FALSE];
subtree =>
BEGIN
node: Tree.Index = lt.index;
IF tb[node].name = mwconst THEN RETURN [Zero[tb[node].son[1]]]
ELSE RETURN [FALSE];
END;
ENDCASE => RETURN [FALSE];
WITH ll: ltb[lti]
SELECT
FROM
short => RETURN [ll.value = 0];
long =>
SELECT ll.length
FROM
1 => RETURN [ll.value[0] = 0];
2 => RETURN [ll.value[1] = 0 AND ll.value[0] = 0];
ENDCASE => RETURN [FALSE];
ENDCASE => RETURN [FALSE];
END;
CatchMark:
PUBLIC
PROC [node: Tree.Index] =
BEGIN -- process a CONTINUEd or RETRYed statement
l: LabelInfoIndex ← P5U.GetChunk[LabelInfoRecord.SIZE];
retry: LabelCCIndex = P5U.LabelAlloc[];
continue: LabelCCIndex = P5U.LabelAlloc[];
cb[l] ← [thread: labelStack, catchLevel: CPtr.catchcount, body:
stmt[retry: retry, continue: continue]];
labelStack ← l;
P5U.InsertLabel[retry];
tb[node].son[1] ← P5.StatementTree[tb[node].son[1]];
P5U.InsertLabel[continue];
IF labelStack # l THEN ERROR;
labelStack ← cb[l].thread;
P5U.FreeChunk[l, LabelInfoRecord.SIZE];
END;
Label:
PUBLIC
PROC [node: Tree.Index] =
BEGIN -- process an exitable block
elabel: LabelCCIndex = P5U.LabelAlloc[];
labelmark: LabelInfoIndex = labelStack;
TreeOps.ScanList[tb[node].son[2], LabelCreate];
tb[node].son[1] ← P5.StatementTree[tb[node].son[1]];
P5U.OutJump[Jump, elabel];
LabelList[tb[node].son[2], elabel, labelmark];
P5U.InsertLabel[elabel];
END;
GetLabelMark:
PUBLIC
PROC
RETURNS [LabelInfoIndex] =
{RETURN [labelStack]};
PopLabels:
PROC [first: LabelInfoIndex] =
BEGIN
oldl: LabelInfoIndex;
UNTIL first = LabelInfoNull
DO
oldl ← first;
first ← cb[first].thread;
P5U.FreeChunk[oldl, LabelInfoRecord.SIZE];
ENDLOOP;
END;
ObscureLabels:
PROC [mark: LabelInfoIndex]
RETURNS [first: LabelInfoIndex] =
BEGIN
first ← labelStack;
UNTIL labelStack = LabelInfoNull
OR cb[labelStack].thread = mark
DO
labelStack ← cb[labelStack].thread;
ENDLOOP;
cb[labelStack].thread ← LabelInfoNull;
labelStack ← mark;
RETURN
END;
FindLabel:
PROC [start: LabelInfoIndex, hti: HTIndex]
RETURNS [NamedLabelInfoIndex] =
BEGIN
FOR l: LabelInfoIndex ← start, cb[l].thread
UNTIL l = LabelInfoNull
DO
WITH li: cb[l]
SELECT
FROM
named => IF li.hti = hti THEN RETURN [LOOPHOLE[l]];
ENDCASE;
ENDLOOP;
ERROR UndeclaredLabel[hti]
END;
LabelList:
PUBLIC
PROC [t: Tree.Link, elabel: LabelCCIndex, mark: LabelInfoIndex] =
BEGIN -- generates code for labels
toBind: LabelInfoIndex = ObscureLabels[mark];
PutLabel:
PROC [t: Tree.Link] =
BEGIN
P5U.InsertLabel[cb[FindLabel[toBind, TreeOps.GetHash[t]]].cci];
END;
CLabelItem:
PROC [t: Tree.Link] =
BEGIN -- generates code for a labelitem
node: Tree.Index = TreeOps.GetNode[t];
TreeOps.ScanList[tb[node].son[1], PutLabel];
tb[node].son[2] ← P5.StatementTree[tb[node].son[2]];
P5U.OutJump[Jump, elabel];
END;
TreeOps.ScanList[t, CLabelItem];
PopLabels[toBind];
END;
LabelCreate:
PUBLIC
PROC [t: Tree.Link] =
BEGIN -- sets up label cells for labels
node: Tree.Index = TreeOps.GetNode[t];
TreeOps.ScanList[tb[node].son[1], PushLabel];
END;
PushLabel:
PROC [t: Tree.Link] =
BEGIN -- stacks a label for an EXIT clause
l: LabelInfoIndex = P5U.GetChunk[LabelInfoRecord.SIZE];
cb[l] ← [thread: labelStack, catchLevel: CPtr.catchcount, body:
named[hti: TreeOps.GetHash[t], cci: P5U.LabelAlloc[]]];
labelStack ← l;
END;
MakeExitLabel:
PUBLIC
PROC
RETURNS [exit, loop: LabelCCIndex] =
BEGIN -- sets up anonymous label for EXITs
l: LabelInfoIndex = P5U.GetChunk[LabelInfoRecord.SIZE];
exit ← P5U.LabelAlloc[];
loop ← P5U.LabelAlloc[];
cb[l] ← [thread: labelStack, catchLevel: CPtr.catchcount, body:
loop[exit: exit, loop: loop]];
labelStack ← l;
RETURN
END;
Retry:
PUBLIC
PROC =
BEGIN -- process RETRY statement
FOR l: LabelInfoIndex ← labelStack, cb[l].thread
UNTIL l = LabelInfoNull
DO
WITH li: cb[l]
SELECT
FROM
stmt => {ExplicitJump[li.catchLevel, li.retry]; RETURN};
ENDCASE;
ENDLOOP;
ERROR
END;
Continue:
PUBLIC
PROC =
BEGIN -- process CONTINUE statement
FOR l: LabelInfoIndex ← labelStack, cb[l].thread
UNTIL l = LabelInfoNull
DO
WITH li: cb[l]
SELECT
FROM
stmt => {ExplicitJump[li.catchLevel, li.continue]; RETURN};
ENDCASE;
ENDLOOP;
ERROR
END;
Exit:
PUBLIC
PROC =
BEGIN -- generate code for EXIT
FOR l: LabelInfoIndex ← labelStack, cb[l].thread
UNTIL l = LabelInfoNull
DO
WITH li: cb[l]
SELECT
FROM
loop => {ExplicitJump[li.catchLevel, li.exit]; RETURN};
ENDCASE;
ENDLOOP;
ERROR
END;
Loop:
PUBLIC
PROC =
BEGIN -- generate code for LOOP
FOR l: LabelInfoIndex ← labelStack, cb[l].thread
UNTIL l = LabelInfoNull
DO
WITH li: cb[l]
SELECT
FROM
loop => {ExplicitJump[li.catchLevel, li.loop]; RETURN};
ENDCASE;
ENDLOOP;
ERROR
END;
GoTo:
PUBLIC
PROC [node: Tree.Index] =
BEGIN -- generate code for GOTO
l: NamedLabelInfoIndex = FindLabel[labelStack, TreeOps.GetHash[tb[node].son[1]]];
ExplicitJump[cb[l].catchLevel, cb[l].cci];
END;
ExplicitJump:
PROC [cc:
CARDINAL, lc: LabelCCIndex] =
BEGIN -- process EXIT/REPEAT/GOTO/etc. statement
IF CPtr.catchcount = cc THEN P5U.OutJump[Jump, lc]
ELSE
BEGIN
var: VarComponent = [wSize: 1, space: frame[
wd: PrincOps.localbase,
level: CPtr.curctxlvl-(CPtr.catchcount-cc-1)]];
P5L.LoadComponent[var];
P5U.PushLitVal[-1];
P5U.Out1[FOpCodes.qLL, PrincOps.returnOffset];
P5U.Out0[FOpCodes.qSFC];
Stack.Decr[2];
P5U.OutJump[Jump, lc];
END;
END;
END.