DIRECTORY
Basics USING [Comparison, CompareCard],
IntCodeDefs USING [ApplyNode, AssignNode, BlockNode, CaseList, CommentNode, CompositeLocation, CondNode, ConstNode, DeclNode, DerefLocation, EnableNode, EscapeLocation, FieldLocation, GotoNode, IndexedLocation, Label, LabelNode, LambdaNode, Location, LocationRep, LogicalId, MesaOper, Node, NodeList, NodeRep, nullVariableFlags, nullVariableId, Offset, Oper, OperNode, OperRep, ReturnNode, SourceNode, Var, VariableFlags, VarList, VarRep],
IntCodeGen USING [CodeGenerator],
IntCodeStuff USING [],
IntCodeTarget USING [bitsPerLink, bitsPerLocal, logMinBitsPerArgument, maxBitsReturnRecord, minBitsPerArgument, ToBits, ToUnits],
IntCodeTwig USING [LambdaModel, OrFlag, OrVarFlags],
IntCodeUtils USING [IdTab, IntToWord, MapNode, NodeListCons, Visitor, zone],
Rope USING [ROPE],
Target: TYPE MachineParms USING [AlignmentIndex, Alignments];
Little Utilities
BitsForArgList:
PUBLIC PROC [args: NodeList]
RETURNS [bits:
INT ¬ 0] = {
FOR each: NodeList ¬ args, each.rest
WHILE each #
NIL
DO
arg: Node ¬ each.first;
IF arg #
NIL
THEN {
units: INT ¬ ToUnits[arg.bits, minBitsPerArgument, logMinBitsPerArgument];
bits ¬ bits + ToBits[units, logMinBitsPerArgument];
};
ENDLOOP;
};
BitsForFormalArgList:
PUBLIC PROC [vars: VarList]
RETURNS [bits:
INT ¬ 0] = {
FOR each: VarList ¬ vars, each.rest
WHILE each #
NIL
DO
arg: Var ¬ each.first;
IF arg #
NIL
THEN {
units: INT ¬ ToUnits[arg.bits, minBitsPerArgument, logMinBitsPerArgument];
bits ¬ bits + ToBits[units, logMinBitsPerArgument];
};
ENDLOOP;
};
CopyVar:
PUBLIC PROC [old: Var]
RETURNS [Var] = {
IF old #
NIL
THEN
RETURN [z.NEW[VarRep ¬ [bits: old.bits, details:
var[flags: old.flags, id: old.id, location: old.location]]]];
RETURN [NIL];
};
GenAddr:
PUBLIC PROC [var: Var]
RETURNS [Node] = {
node: ApplyNode ¬ GenApply[addrOperNode, NodeListCons[var]];
MarkAddressed[var];
RETURN [node];
};
GenAnonVar:
PUBLIC PROC [bits:
INT, loc: Location ¬
NIL]
RETURNS [Var] = {
RETURN [z.
NEW[VarRep ¬ [bits: bits, details:
var[flags: nullVariableFlags, id: nullVariableId, location: loc]]]];
};
GenApply:
PUBLIC PROC [proc: Node, args: NodeList, bits:
INT ¬ -1]
RETURNS [ApplyNode] = {
RETURN [z.NEW[NodeRep.apply ¬ [
IF bits = -1 THEN bitsPerLink ELSE bits,
apply[proc: proc, args: args]]]];
};
GenAssign:
PUBLIC PROC [lhs: Var, rhs: Node, bits:
INT ¬ 0]
RETURNS [AssignNode] = {
IF rhs =
NIL
OR rhs.bits = 0
OR lhs =
NIL
OR lhs.bits # rhs.bits
THEN
SIGNAL CantHappen;
IF bits # 0 AND bits # lhs.bits THEN SIGNAL CantHappen;
RETURN [z.NEW[NodeRep.assign ¬ [bits, assign[lhs: lhs, rhs: rhs]]]];
};
GenBlock:
PUBLIC PROC [nodes: NodeList, bits:
INT ¬ 0]
RETURNS [BlockNode] = {
RETURN [z.NEW[NodeRep.block ¬ [bits, block[nodes]]]];
};
GenComment:
PUBLIC PROC [msg:
ROPE]
RETURNS [CommentNode] = {
RETURN [z.NEW[NodeRep.comment ¬ [0, comment[msg]]]];
};
GenComposite:
PUBLIC PROC [nodes: NodeList, bits:
INT]
RETURNS [Var] = {
IF nodes = NIL THEN RETURN [NIL];
IF nodes.rest =
NIL
THEN
WITH nodes.first
SELECT
FROM
var: Var => RETURN [var];
ENDCASE;
RETURN [GenAnonVar[bits, z.NEW[LocationRep.composite ¬ [composite[nodes]]]]];
};
GenConst:
PUBLIC PROC [int:
INT, bits:
INT ¬ bitsPerLocal]
RETURNS [ConstNode] = {
IF constInit
AND bits = bitsPerLocal
THEN
SELECT int
FROM
0 => RETURN [constant0];
1 => RETURN [constant1];
2 => RETURN [constant2];
ENDCASE;
RETURN [z.NEW[NodeRep.const.word ¬ [bits, const[word[IntCodeUtils.IntToWord[int]]]]]];
};
GenDecl:
PUBLIC PROC [var: Var, init: Node]
RETURNS [DeclNode] = {
RETURN [z.NEW[NodeRep.decl ¬ [0, decl[var: var, init: init]]]];
};
GenDeref:
PUBLIC PROC [node: Node, bits:
INT, align:
NAT]
RETURNS [Var] = {
loc: Location ¬ z.NEW[LocationRep.deref ¬ [deref[node, align]]];
WITH node
SELECT
FROM
var: Var => var.flags[used] ¬ TRUE;
ENDCASE;
RETURN [GenAnonVar[bits, loc]];
};
GenDummy:
PUBLIC PROC [bits:
INT]
RETURNS [Var] = {
RETURN [GenAnonVar[bits, dummyLoc]];
};
GenField:
PUBLIC PROC [base: Node, offset:
INT, bits:
INT]
RETURNS [Var] = {
RETURN [GenAnonVar[bits, GenFieldLoc[base, offset]]];
};
GenXField:
PUBLIC
PROC [base: Node, offset:
INT, bits:
INT]
RETURNS [Var] = {
--Little endian only. ChJ, May 4, 1993
RETURN [GenAnonVar[bits, GenXFieldLoc[base, offset]]];
};
GenFieldLoc:
PUBLIC
PROC [base: Node, offset:
INT]
RETURNS [Location] = {
WITH base
SELECT
FROM
var: Var => RETURN [GenFieldLocOfVar[var, offset]];
ENDCASE;
IF base = NIL OR base.bits < offset THEN SIGNAL CantHappen;
RETURN [z.NEW[LocationRep.field ¬ [field[base, offset, FALSE]]]];
};
GenXFieldLoc:
PUBLIC
PROC [base: Node, offset:
INT]
RETURNS [Location] = {
--Little endian only. ChJ, May 4, 1993
LS? LAI
WITH base
SELECT
FROM
var: Var => RETURN [GenXFieldLocOfVar[var, offset]];
ENDCASE;
IF base = NIL OR base.bits < offset THEN SIGNAL CantHappen;
RETURN [z.NEW[LocationRep.field ← [field[base, offset, TRUE]]]];
};
GenFieldLocOfVar:
PUBLIC PROC [var: Var, offset:
INT]
RETURNS [Location] = {
base: Node ¬ var;
var.flags[used] ¬ TRUE;
WITH var.location
SELECT
FROM
field: FieldLocation => {
--ChJ, May 4, 1993
IF field.cross THEN ERROR; -- dont know how to handle LAI
base ¬ field.base;
offset ¬ offset + field.start;
};
ENDCASE;
RETURN [z.NEW[LocationRep.field ¬ [field[base, offset, FALSE]]]];
};
GenXFieldLocOfVar:
PUBLIC
PROC [var: Var, offset:
INT]
RETURNS [Location] = {
--ChJ, May 4, 1993
base: Node ← var;
var.flags[used] ← TRUE;
WITH var.location
SELECT
FROM
field: FieldLocation => {
IF ~field.cross THEN ERROR; -- dont know how to handle LAI
base ¬ field.base;
offset ¬ offset + field.start;
};
ENDCASE;
RETURN [z.NEW[LocationRep.field ← [field[base, offset, TRUE]]]];
};
GenFieldOfDeref:
PUBLIC PROC [ptr: Var, offset: Offset, bits:
INT]
RETURNS [Var] = {
Must only be used for fields based on worst-case (largest) alignment
var: Var ¬ GenDeref[ptr, offset+bits, worst];
IF offset # 0 THEN var ¬ GenAnonVar[bits, GenFieldLocOfVar[var, offset]];
RETURN [var];
};
GenFree:
PUBLIC PROC [var: Var]
RETURNS [Node] = {
RETURN [GenAssign[var, GenApply[freeOperNode, NodeListCons[var], bitsPerLink]]];
};
GenGoTo:
PUBLIC PROC [label: Label]
RETURNS [GotoNode] = {
label.jumpedTo ¬ label.used ¬ TRUE;
RETURN [z.NEW[NodeRep.goto ¬ [0, goto[label, FALSE]]]];
};
GenLabelAddress:
PUBLIC PROC [label: Label, direct:
BOOL]
RETURNS [Node] = {
oper: Oper ¬ z.NEW[OperRep.code ¬ [code[label: label, offset: 0, direct: direct]]];
operNode: Node ¬ z.NEW[NodeRep.oper ¬ [bits: bitsPerLink, details: oper[oper: oper]]];
RETURN [operNode];
};
GenLargeReturn:
PUBLIC
PROC [rets: NodeList, rtnVar: Var]
RETURNS [Node] = {
head: NodeList ¬ NIL;
tail: NodeList ¬ NIL;
offset: INT ¬ 0;
FOR each: NodeList ¬ rets, each.rest
WHILE each #
NIL
DO
this: Node ¬ each.first;
tBits: INT ¬ this.bits;
new: NodeList ¬ NodeListCons[GenAssign[GenField[rtnVar, offset, tBits], this]];
IF this.bits MOD bitsPerLocal # 0 THEN ERROR;
IF tail = NIL THEN head ¬ new ELSE tail.rest ¬ new;
tail ¬ new;
offset ¬ offset + tBits;
ENDLOOP;
IF head = NIL THEN RETURN [emptyReturn];
tail.rest ¬ NodeListCons[emptyReturn];
RETURN [GenBlock[head]];
};
GenOperNode:
PUBLIC PROC [operRep: OperRep, bits:
INT ¬ 0]
RETURNS [OperNode] = {
RETURN [z.NEW[NodeRep.oper ¬ [bits, oper[z.NEW[OperRep ¬ operRep]]]]];
};
GenReturn:
PUBLIC PROC [rets: NodeList ¬
NIL]
RETURNS [Node] = {
RETURN [z.NEW[NodeRep.return ¬ [bits: 0, details: return [rets]]]];
};
GenUpLevel:
PUBLIC PROC [link: Var, reg: Var, format: LogicalId ¬ 0]
RETURNS [Var] = {
loc: Location ¬ z.NEW[LocationRep.upLevel ¬ [upLevel[link, reg, format]]];
reg.flags[used] ¬ TRUE;
RETURN [GenAnonVar[reg.bits, loc]];
};
HasLongReturnVar:
PUBLIC PROC [model: LambdaModel, bits:
INT]
RETURNS [
BOOL] = {
IF model.forceLong
OR bits > maxBitsReturnRecord
THEN {
A large return record
rtnVar: Var ¬ model.returnVar;
IF bits = 0 THEN bits ¬ bitsPerLink;
IF rtnVar =
NIL
THEN {
Time to have a new large variable
rtnPtr: Var ¬ GenAnonVar[bitsPerLink];
rtnVar ¬ GenDeref[rtnPtr, bits, worst];
model.returnVar ¬ rtnVar;
};
IF rtnVar.bits # bits THEN SIGNAL CantHappen;
RETURN [TRUE];
};
RETURN [FALSE];
};
IsError:
PUBLIC PROC [node: Node]
RETURNS [
BOOL] = {
WITH node
SELECT
FROM
apply: ApplyNode =>
IF apply.handler =
NIL
THEN
WITH apply.proc
SELECT
FROM
oper: OperNode =>
WITH oper.oper
SELECT
FROM
mesa: MesaOper => IF mesa.mesa = error THEN RETURN [TRUE];
ENDCASE;
ENDCASE;
ENDCASE;
RETURN [FALSE];
};
IsLive:
PUBLIC
PROC [node: Node, initialLive:
BOOL ¬
TRUE]
RETURNS [
BOOL] = {
Determines whether control flow might exit the node, given that the node has an initial reachability given by initialLive. If NOT initialLive, then the exit liveness is determined by the existence of labels in the node that might be reached from outside of the node. This routine assumes that the used flag on labels has been properly initialized.
innerArgs:
PROC [list: NodeList] = {
Since the args can be evaluated in any order, the initial value of live is always oldLive. However, since all of the arguments must be evaluated, we take liveness to be the AND of all the livenesses. The handler does not affect the liveness.
oldLive: BOOL ¬ live;
newLive: BOOL ¬ live;
FOR each: NodeList ¬ list, each.rest
WHILE each #
NIL
DO
live ¬ oldLive;
[] ¬ inner[each.first];
newLive ¬ newLive AND live;
ENDLOOP;
live ¬ newLive;
};
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
n: Node ¬ node;
list: NodeList ¬ NIL;
DO
WITH n
SELECT
FROM
var: Var => {
Special handling for variables (both because they are common and because they are a lot like application).
WITH var.location
SELECT
FROM
field: FieldLocation => {n ¬ field.base; LOOP};
deref: DerefLocation => {n ¬ deref.addr; LOOP};
escape: EscapeLocation => {n ¬ escape.base; LOOP};
indexed: IndexedLocation => {
oldLive: BOOL ¬ live;
newLive: BOOL ¬ oldLive;
[] ¬ inner[indexed.base];
newLive ¬ live;
live ¬ oldLive;
[] ¬ inner[indexed.index];
live ¬ newLive AND live;
};
comp: CompositeLocation => innerArgs[comp.parts];
ENDCASE;
};
labelNode: LabelNode => {
label: Label = labelNode.label;
IF label.used THEN live ¬ TRUE;
n ¬ label.node;
LOOP;
};
lambda: LambdaNode => {list ¬ lambda.body; EXIT};
block: BlockNode => {list ¬ block.nodes; EXIT};
source: SourceNode => {list ¬ source.nodes; EXIT};
enable: EnableNode => {list ¬ enable.scope; EXIT};
rtn: ReturnNode => {innerArgs[rtn.rets]; live ¬ FALSE};
goto: GotoNode => live ¬ FALSE;
cond: CondNode => {
The liveness of a cond is the OR of all the livenesses of the arms.
oldLive: BOOL ¬ live;
newLive: BOOL ¬ FALSE;
nCases: INT ¬ 0;
lastTestList: NodeList ¬ NIL;
lastBody: Node ¬ NIL;
nextTestLive: BOOL ¬ oldLive;
FOR each: CaseList ¬ cond.cases, each.rest
WHILE each #
NIL
DO
live ¬ nextTestLive;
lastTestList ¬ each.tests;
FOR tests: NodeList ¬ lastTestList, tests.rest
WHILE tests #
NIL
DO
Evaluate the tests sequentially
[] ¬ inner[tests.first];
nextTestLive ¬ nextTestLive OR live;
ENDLOOP;
[] ¬ inner[lastBody ¬ each.body];
newLive ¬ live OR newLive;
nCases ¬ nCases + 1;
ENDLOOP;
SELECT
TRUE
FROM
lastTestList #
NIL => newLive ¬ newLive
OR nextTestLive;
There is an implicit ENDCASE or ELSE preserving liveness
ENDCASE;
live ¬ newLive;
};
apply: ApplyNode => {
oldLive: BOOL ¬ live;
newLive: BOOL ¬ oldLive;
[] ¬ inner[apply.proc];
newLive ¬ live;
live ¬ oldLive;
innerArgs[apply.args];
live ¬ live AND newLive;
IF IsError[apply] THEN live ¬ FALSE;
};
ENDCASE => IF n # NIL THEN IntCodeUtils.MapNode[n, inner];
EXIT;
ENDLOOP;
WHILE list # NIL DO [] ¬ inner[list.first]; list ¬ list.rest; ENDLOOP;
RETURN [node];
};
live: BOOL ¬ initialLive;
[] ¬ inner[node];
RETURN [live];
};
MarkAddressed:
PUBLIC
PROC [node: Node] = {
DO
WITH node
SELECT
FROM
var: Var =>
IF
NOT var.flags[addressed]
THEN {
OrVarFlags[var, addressedFlags];
WITH var.location
SELECT
FROM
indexed: REF LocationRep.indexed => {node ¬ indexed.base; LOOP};
field: REF LocationRep.field => {node ¬ field.base; LOOP};
ENDCASE;
};
ENDCASE;
RETURN;
ENDLOOP;
};
MarkAssigned:
PUBLIC
PROC [node: Node] = {
DO
WITH node
SELECT
FROM
var: Var =>
IF
NOT var.flags[assigned]
THEN {
var.flags[assigned] ¬ TRUE;
WITH var.location
SELECT
FROM
indexed: REF LocationRep.indexed => {node ¬ indexed.base; LOOP};
field: REF LocationRep.field => {node ¬ field.base; LOOP};
composite:
REF LocationRep.composite =>
FOR each: NodeList ¬ composite.parts, each.rest
WHILE each #
NIL
DO
MarkAssigned[each.first];
ENDLOOP;
ENDCASE;
};
ENDCASE;
RETURN;
ENDLOOP;
};
MarkUsed:
PUBLIC
PROC [node: Node] = {
DO
WITH node
SELECT
FROM
var: Var =>
IF
NOT var.flags[used]
THEN {
var.flags[used] ¬ TRUE;
WITH var.location
SELECT
FROM
indexed:
REF LocationRep.indexed => {
MarkUsed[indexed.base];
node ¬ indexed.index;
LOOP;
};
deref: REF LocationRep.deref => {node ¬ deref.addr; LOOP};
field: REF LocationRep.field => {node ¬ field.base; LOOP};
composite:
REF LocationRep.composite =>
FOR each: NodeList ¬ composite.parts, each.rest
WHILE each #
NIL
DO
MarkUsed[each.first];
ENDLOOP;
ENDCASE;
};
ENDCASE;
RETURN;
ENDLOOP;
};
NodeContains:
PUBLIC PROC [node: Node, object: Node]
RETURNS [
BOOL] = {
Returns TRUE iff the given object is found as a component (at any depth) of the given node.
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
SELECT
TRUE
FROM
node = object => found ¬ TRUE;
NOT found => IntCodeUtils.MapNode[node, inner];
ENDCASE;
RETURN [node];
};
found: BOOL ¬ object = node;
IF NOT found THEN [] ¬ inner[node];
RETURN [found];
};
NodeListCons2:
PUBLIC PROC [node1, node2: Node]
RETURNS [NodeList] = {
RETURN [NodeListCons[node1, NodeListCons[node2]]];
};
NodeListCons3:
PUBLIC PROC [node1, node2, node3: Node]
RETURNS [NodeList] = {
RETURN [NodeListCons[node1, NodeListCons[node2, NodeListCons[node3]]]];
};
NodeListCons4:
PUBLIC PROC [node1, node2, node3, node4: Node]
RETURNS [NodeList] = {
RETURN [NodeListCons[node1, NodeListCons[node2,
NodeListCons[node3, NodeListCons[node4]]]]];
};
NodeListCons5:
PUBLIC PROC [node1, node2, node3, node4, node5: Node]
RETURNS [NodeList] = {
RETURN [NodeListCons[node1, NodeListCons[node2,
NodeListCons[node3, NodeListCons[node4, NodeListCons[node5]]]]]];
};
PadComposite:
PUBLIC PROC [argsRets: NodeList, logMinBits:
NAT]
RETURNS [Node] = {
newList: NodeList ¬ NIL;
tail: NodeList ¬ NIL;
totalBits: INT ¬ 0;
minBits: INT ¬ ToBits[1, logMinBits];
FOR each: NodeList ¬ argsRets, each.rest
WHILE each #
NIL
DO
argsRet: Node ¬ each.first;
IF argsRet #
NIL
THEN {
bits: INT ¬ argsRet.bits;
units: INT ¬ ToUnits[bits, minBits, logMinBits];
round: INT ¬ ToBits[units, logMinBits];
new: NodeList ¬ NodeListCons[argsRet];
IF bits # round
THEN {
We need some padding inserted
pad: NodeList ¬ NodeListCons[GenDummy[round-bits]];
IF tail = NIL THEN newList ¬ pad ELSE tail.rest ¬ pad;
tail ¬ pad;
};
IF tail = NIL THEN newList ¬ new ELSE tail.rest ¬ new;
tail ¬ new;
totalBits ¬ totalBits + round;
};
ENDLOOP;
SELECT
TRUE
FROM
newList = NIL => RETURN [NIL];
newList.rest = NIL => RETURN [newList.first];
ENDCASE => {
comp: Var ¬ GenComposite[newList, totalBits];
comp.flags[used] ¬ TRUE;
RETURN [comp];
};
};
StripNilCheck:
PUBLIC PROC [node: Node]
RETURNS [Node] = {
WITH node
SELECT
FROM
apply: ApplyNode =>
IF apply.handler =
NIL
THEN
WITH apply.proc
SELECT
FROM
oper: OperNode =>
WITH oper.oper
SELECT
FROM
mesa: MesaOper => IF mesa.mesa = nilck THEN RETURN [apply.args.first];
ENDCASE;
ENDCASE;
ENDCASE;
RETURN [node];
};