IntCodeOptImpl.mesa
Copyright Ó 1989, 1990, 1991, 1993 by Xerox Corporation. All rights reserved.
Russ Atkinson (RRA) February 4, 1991 7:33 pm PST
Willie-s, September 23, 1991 6:01 pm PDT
Christian Jacobi, May 4, 1993 8:20 pm PDT
DIRECTORY
Basics32,
IO,
IntCodeDefs,
IntCodeOpt USING [],
IntCodeStuff,
IntCodeTwig,
IntCodeUtils,
ProcessProps, ParseIntCode,
Rope,
Target: TYPE MachineParms;
IntCodeOptImpl:
CEDAR
PROGRAM
IMPORTS Basics32, IO, IntCodeStuff, IntCodeTwig, IntCodeUtils, ProcessProps, ParseIntCode
EXPORTS IntCodeOpt
= BEGIN OPEN IntCodeDefs, IntCodeStuff, IntCodeUtils, Rope;
useReturnSubstitution: BOOL ¬ TRUE;
useTailGotoSubstitution: BOOL ¬ TRUE;
testBogusAssignment: BOOL ¬ TRUE;
retainNamedReturns: BOOL ¬ TRUE;
useRemTemp: BOOL ¬ TRUE;
BaseModel: TYPE = IntCodeTwig.BaseModel;
LambdaModel: TYPE = IntCodeTwig.LambdaModel;
DebugNodeList:
PROC [why:
REF
TEXT, list: NodeList] = {
WITH ProcessProps.GetProp[$StdOut]
SELECT
FROM
st:
IO.
STREAM => {
IO.PutText[st, why];
ParseIntCode.ToStream[st, list];
IO.PutText[st, "\n"];
};
ENDCASE;
};
GenAnonLocal:
PUBLIC PROC [base: BaseModel, parent: Label, bits:
INT]
RETURNS [Var] = {
next: INT ¬ -IntCodeTwig.DeclsSize[base]-1;
z: ZONE ¬ IntCodeUtils.zone;
loc: Location ¬ z.NEW[LocationRep.localVar ¬ [localVar[id: next, parent: parent]]];
var: Var ¬ IntCodeStuff.GenAnonVar[bits, loc];
var.id ¬ next;
var.flags[used] ¬ TRUE;
IntCodeTwig.DeclsStore[base, next, var];
RETURN [var];
};
CleanupLambda:
PUBLIC
PROC
[base: BaseModel, model: LambdaModel, lambda: LambdaNode, rtnPtr: Var] = {
This routine cleans up the tree, removing all sorts of unclean cases.
innerList:
PROC [list: NodeList]
RETURNS [NodeList] = {
innerList treats the list as a sequence of nodes where we should splice out the unreachable stuff.
head: NodeList ¬ NIL;
tail: NodeList ¬ NIL;
splicingOut: BOOL ¬ FALSE;
WHILE list #
NIL
DO
oldLive: BOOL ¬ live;
oldCount: INT ¬ labelCount;
next: NodeList ¬ list.rest;
this: Node ¬ list.first;
IF
NOT live
AND this #
NIL
AND this.bits = 0
THEN {
Special cases where we can eliminate jumping into things without processing the parts, since we can't jump into the middle of processing.
WITH this
SELECT
FROM
decl: DeclNode =>
Just kill the initialization, since it can't be executed
decl.init ¬ NIL;
block: BlockNode =>
Get rid of the whole thing
list.first ¬ deadBlockComment;
ENDCASE => GO TO notSimple;
list ¬ next;
LOOP;
EXITS notSimple => {};
};
IF useTailGotoSubstitution
AND next #
NIL
THEN {
label: Label ¬ FindLeadingLabel[next.first];
IF label # NIL THEN this ¬ RemTailGoTo[this, label, tailGoToComment];
};
this ¬ inner[this];
IF this #
NIL
THEN {
SELECT
TRUE
FROM
oldLive, live, oldCount # labelCount => {
This node either was live or has become live, or must be preserved because there may be a live piece in it.
splicingOut ¬ FALSE;
GO TO spliceIn;
};
this = deadLabelComment, this = deadCodeComment =>
Preserve notices of dead labels and code
GO TO spliceIn;
ENDCASE;
At this point we are going to lose this node unless it is a declaration
WITH this
SELECT
FROM
decl: DeclNode => {
Just kill the initialization, since it can't be executed
decl.init ¬ NIL;
GO TO spliceIn;
};
ENDCASE;
At this point we are going to lose this node forever
IF
NOT splicingOut
THEN {
We need to put in a splice out notice
list.first ¬ deadCodeComment;
splicingOut ¬ TRUE;
GO TO spliceIn;
};
EXITS spliceIn => {
IF tail # NIL THEN tail.rest ¬ list ELSE head ¬ list;
tail ¬ list;
};
};
list ¬ next;
ENDLOOP;
IF tail # NIL THEN tail.rest ¬ NIL;
RETURN [head];
};
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;
each.first ¬ inner[each.first];
newLive ¬ newLive AND live;
ENDLOOP;
live ¬ newLive;
};
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
list: NodeList ¬ NIL;
WITH node
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 => field.base ¬ inner[field.base];
deref: DerefLocation => deref.addr ¬ inner[deref.addr];
escape: EscapeLocation => escape.base ¬ inner[escape.base];
indexed: IndexedLocation => {
oldLive: BOOL ¬ live;
newLive: BOOL ¬ oldLive;
indexed.base ¬ inner[indexed.base];
newLive ¬ live;
live ¬ oldLive;
indexed.index ¬ inner[indexed.index];
live ¬ newLive AND live;
};
comp: CompositeLocation => {
needsFlattening: BOOL ¬ FALSE;
innerArgs[comp.parts];
FOR each: NodeList ¬ comp.parts, each.rest
WHILE each #
NIL
DO
elem: Node = each.first;
WITH elem
SELECT
FROM
v: Var =>
WITH v.location
SELECT
FROM
comp: REF LocationRep.composite => needsFlattening ¬ TRUE;
ENDCASE;
ENDCASE;
ENDLOOP;
IF needsFlattening
THEN {
head: NodeList ¬ NIL;
tail: NodeList ¬ NIL;
copyParts:
PROC [parts: NodeList] = {
FOR each: NodeList ¬ parts, each.rest
WHILE each #
NIL
DO
elem: Node = each.first;
WITH elem
SELECT
FROM
v: Var =>
WITH v.location
SELECT
FROM
comp: REF LocationRep.composite => {copyParts[comp.parts]; LOOP};
ENDCASE;
ENDCASE;
IF elem #
NIL
THEN {
new: NodeList ¬ NodeListCons[elem];
IF tail = NIL THEN head ¬ new ELSE tail.rest ¬ new;
tail ¬ new;
};
ENDLOOP;
};
copyParts[comp.parts];
comp.parts ¬ head;
};
};
ENDCASE;
GO TO done;
};
assign: AssignNode => {
lhs: Var ¬ NARROW[inner[assign.lhs]];
lhsLive: BOOL ¬ live;
rhs: Node ¬ inner[assign.rhs];
live ¬ live AND lhsLive;
WITH rhs
SELECT
FROM
rv: Var =>
WITH rv.location
SELECT
FROM
cLoc: CompositeLocation => {
We are assigning a composite. If this assignment is to a local var then we should do it as a series of simpler assignments to make C2C more happy.
lv: Var ¬ lhs;
start: INT ¬ 0;
DO
IF lv = NIL THEN GO TO done;
WITH lv.location
SELECT
FROM
local: LocalVarLocation => IF NOT lv.flags[addressed] THEN EXIT;
field: FieldLocation => {
IF field.cross
THEN {
--Little endian code lifted without understanding. ChJ, May 4, 1993
GOTO done;
--Currently we dont support a composite assignment to a lhs which is xfield. But we need to, we will have to add a case for collapsing xfield, however we need to separate the cases of xfield or field is the toplevel and collapse accordingly. Then use the state to determine if we use genfield of genxfield in the multiple assignment stuff below. LAI
};
WITH field.base
SELECT
FROM
fv: Var => {start ¬ start + field.start; lv ¬ fv; LOOP};
ENDCASE;
};
ENDCASE;
GO TO done;
ENDLOOP;
IF cLoc.parts #
NIL
THEN {
We try to build up a series of assignments to the variable. If we fail, we discard the list we are building up, and nothing else has changed.
head: NodeList ¬ NIL;
tail: NodeList ¬ NIL;
FOR each: NodeList ¬ cLoc.parts, each.rest
WHILE each #
NIL
DO
val: Node ¬ each.first;
IF val #
NIL
THEN {
vBits: INT = val.bits;
IF ModBits[vBits] # 0 THEN GO TO done;
IF vBits > 0
THEN {
field: Var ¬ GenField[lv, start, val.bits];
new: NodeList ¬ NodeListCons[GenAssign[field, val]];
start ¬ start + val.bits;
IF tail # NIL THEN tail.rest ¬ new ELSE head ¬ new;
tail ¬ new;
};
};
ENDLOOP;
IF head #
NIL
THEN {
We were able to break up the composite, so make a block
IF head.rest =
NIL
THEN {
Actually, a single assignment will do
node ¬ head.first;
node.bits ¬ assign.bits;
GO TO done;
};
IF assign.bits # 0 THEN tail ¬ tail.rest ¬ NodeListCons[lhs];
node ¬ GenBlock[head, assign.bits];
GO TO done;
};
};
};
ENDCASE;
ENDCASE;
GO TO done;
};
labelNode: LabelNode => {
label: Label = labelNode.label;
IF label.used
THEN {
This node must be assumed to be live. Further, we bump the label counter to ensure that the container for the label does not disappear.
live ¬ TRUE;
labelCount ¬ labelCount + 1;
}
ELSE {
This label is not used by anyone. If there is no node, then we mark it as a dead label. In any case, sequential liveness is not affected.
node ¬ label.node;
IF node = NIL THEN RETURN [deadLabelComment];
};
label.node ¬ inner[label.node];
GO TO done;
};
lambda: LambdaNode => {
lambda.body ¬ innerList[lambda.body];
GO TO done;
};
block: BlockNode => {
nodes: NodeList ¬ innerList[block.nodes];
IF useRemTemp THEN nodes ¬ RemTemp[nodes];
block.nodes ¬ nodes;
SELECT
TRUE
FROM
nodes = NIL => node ¬ NIL;
block.bits # 0 =>
IF live
THEN {
tail: NodeList ¬ NodeListTail[block.nodes];
IF tail.first = NIL OR tail.first.bits # block.bits THEN SIGNAL CantHappen;
};
ENDCASE;
GO TO done;
};
source: SourceNode => {
source.nodes ¬ innerList[source.nodes];
GO TO done;
};
enable: EnableNode => {
enable.scope ¬ innerList[enable.scope];
GO TO done;
};
rtn: ReturnNode => {
innerArgs[rtn.rets];
live ¬ FALSE;
GO TO done;
};
goto: GotoNode => {
live ¬ FALSE;
GO TO done;
};
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;
represents the test liveness if all of them could evaluate to FALSE
FOR each: CaseList ¬ cond.cases, each.rest
WHILE each #
NIL
DO
live ¬ oldLive;
lastTestList ¬ each.tests;
FOR tests: NodeList ¬ lastTestList, tests.rest
WHILE tests #
NIL
DO
The liveness of a test is the OR of all the livenesses of the tests, evaluated sequentially, since the first test being true will prevent evaluation of the succeeding tests.
tests.first ¬ inner[tests.first];
nextTestLive ¬ nextTestLive OR live;
ENDLOOP;
lastBody ¬ each.body ¬ inner[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
nCases < 2 => node ¬ lastBody;
The cond is trivially unconditional
ENDCASE;
live ¬ newLive;
GO TO done;
};
decl: DeclNode => {
var: Var ¬ decl.var;
IF
NOT var.flags[used]
AND
NOT var.flags[named]
THEN
IF decl.init =
NIL
OR IntCodeUtils.SideEffectFree[decl.init,
TRUE]
THEN
RETURN [GenComment[
IO.PutFR1["removed dead decl of %g", [integer[var.id]]]]];
};
apply: ApplyNode => {
Since the proc and 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 ¬ oldLive;
apply.proc ¬ inner[apply.proc];
newLive ¬ live;
live ¬ oldLive;
innerArgs[apply.args];
live ¬ live AND newLive;
IF IsError[apply] THEN live ¬ FALSE;
GO TO done;
};
ENDCASE;
IntCodeUtils.MapNode[node, inner];
RETURN [node];
EXITS done => RETURN [node];
};
live: BOOL ¬ TRUE;
labelCount: INT ¬ 0;
deadBlockComment: Node ¬ GenComment["removed dead block"];
deadCodeComment: Node ¬ GenComment["removed dead code"];
deadLabelComment: Node ¬ GenComment["removed dead label"];
tailGoToComment: Node ¬ GenComment["removed tail goto"];
[] ¬ inner[lambda];
IF rtnPtr #
NIL
AND useReturnSubstitution
THEN
ReturnSubstitution[base, model, lambda.body, rtnPtr];
};
RectifyBlock:
PUBLIC
PROC [node: Node]
RETURNS [Node] = {
DO
WITH node
SELECT
FROM
block: BlockNode => {
nodes: NodeList ¬ block.nodes;
IF nodes #
NIL
THEN
WITH nodes.first
SELECT
FROM
decl: DeclNode => {
rest: NodeList ¬ nodes.rest;
var: Var ¬ decl.var;
second: Node ¬ IF rest = NIL THEN NIL ELSE rest.first;
IF second = NIL THEN RETURN [node];
WITH second
SELECT
FROM
bn: BlockNode => {
IF rest.rest = NIL THEN rest.first ¬ RectifyBlock[second];
RETURN [node];
};
assign: AssignNode =>
IF decl.init =
NIL
AND decl.var = assign.lhs
AND assign.bits = 0
THEN {
Collapse out an assignment if it can be done by the decl init
decl.init ¬ assign.rhs;
nodes.rest ¬ rest.rest;
LOOP;
};
ENDCASE;
IF
NOT var.flags[named]
AND rest #
NIL
THEN {
This code declares a nameless variable, and may not need to.
rest ¬ rest.rest;
IF rest #
NIL
AND rest.rest =
NIL
THEN
This looks suspiciously like a gratuitous temporary
WITH rest.first
SELECT
FROM
assign: AssignNode =>
IF assign.rhs = var
THEN {
ultimateVar: Var ¬ assign.lhs;
WITH second
SELECT
FROM
dn: DeclNode =>
IF var = dn.var
THEN
node ¬ GenAssign[ultimateVar, dn.init];
apply: ApplyNode =>
IF ultimateVar #
NIL
THEN {
args: NodeList ¬ apply.args;
IF args #
NIL
THEN
WITH args.first
SELECT
FROM
ap2: ApplyNode =>
IF ap2.proc = addrOperNode
THEN
IF ap2.args #
NIL
AND ap2.args.first = var
THEN {
ap2.args.first ¬ ultimateVar;
MarkAddressed[ultimateVar];
Now there are two cases: if the block returns 0 bits, then the apply node is the resulting node; otherwise, the resulting node is a block with the apply node followed by the ultimateVar.
IF block.bits = 0
THEN
The apply node is sufficient
node ¬ apply
ELSE
We need to return the ultimate var as the value
node ¬ GenBlock[
NodeListCons2[apply, ultimateVar], ultimateVar.bits];
};
ENDCASE;
};
ENDCASE;
};
ENDCASE;
};
};
ENDCASE;
};
ENDCASE;
RETURN [node];
ENDLOOP;
};
depthLimit: INT ¬ 100;
SimplifyValueBlocks:
PUBLIC PROC
[base: BaseModel, model: LambdaModel, lambda: LambdaNode] = {
declHead: NodeList ¬ NIL;
declTail: NodeList ¬ NIL;
depth: INT ¬ 0;
generalVisit:
PROC [example: Node, n: Node]
RETURNS [Node] = {
visit: IntCodeUtils.Visitor = {
new: Node ¬ node;
WITH example
SELECT
FROM
var: Var =>
WITH var.location
SELECT
FROM
field: FieldLocation =>
IF field.cross
--ChJ, May 4, 1993
THEN new ¬ GenXField[node, field.start, example.bits]
ELSE new ¬ GenField[node, field.start, example.bits];
deref: DerefLocation => new ¬ GenDeref[node, example.bits, deref.align];
ENDCASE;
apply: ApplyNode =>
new ¬ innerExpr[GenApply[apply.proc, NodeListCons[node], example.bits]];
assign: AssignNode =>
new ¬ innerExpr[GenAssign[assign.lhs, node, example.bits]];
return: ReturnNode =>
new ¬ innerExpr[GenReturn[NodeListCons[node]]];
ENDCASE;
RETURN [new];
};
IF WillMapValuePoints[n]
THEN {
n ¬ MapValuePoints[n, visit];
n.bits ¬ example.bits;
n ¬ RectifyBlock[n];
RETURN [n];
};
RETURN [example];
};
innerExpr: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
oldDeclHead: NodeList ¬ declHead;
oldDeclTail: NodeList ¬ declTail;
IF node #
NIL
THEN {
IF (depth ¬ depth + 1) > depthLimit THEN SIGNAL CantHappen;
declHead ¬ declTail ¬ NIL;
WITH node
SELECT
FROM
const: ConstNode => GO TO return;
var: Var => {
bits: INT = var.bits;
WITH var.location
SELECT
FROM
field: FieldLocation => {
A field location can be moved into the block!
base: Node ¬ field.base;
IF base #
NIL
THEN {
base ¬ field.base ¬ innerExpr[base];
IF IsReallySimple[node] THEN node ¬ generalVisit[node, base];
GO TO return;
};
};
deref: DerefLocation => {
A deref location can be moved into the block!
base: Node ¬ deref.addr;
IF base #
NIL
THEN {
base ¬ deref.addr ¬ innerExpr[deref.addr];
IF IsReallySimple[node] THEN node ¬ generalVisit[node, base];
GO TO return;
};
};
ENDCASE;
};
assign: AssignNode => {
rhs: Node ¬ assign.rhs ¬ innerExpr[assign.rhs];
lhs: Var ¬ assign.lhs;
IF IsReallySimple[lhs] THEN node ¬ generalVisit[node, rhs];
GO TO return;
};
apply: ApplyNode => {
args: NodeList ¬ apply.args;
proc: Node ¬ apply.proc;
listHead: NodeList ¬ NIL;
listTail: NodeList ¬ NIL;
makeTemp:
PROC [n: Node, relaxed:
BOOL]
RETURNS [Node] = {
WITH n
SELECT
FROM
bn: BlockNode => {
bnHead: NodeList ¬ bn.nodes;
tail: NodeList ¬ bnHead;
temp: Var ¬ NIL;
WITH bnHead.first
SELECT
FROM
decl: DeclNode => {
var: Var = decl.var;
IF NOT var.flags[named] THEN temp ¬ var;
};
ENDCASE;
DO
rest: NodeList ¬ tail.rest;
IF rest = NIL THEN EXIT;
tail.rest ¬ NIL;
IF listTail = NIL THEN listHead ¬ tail ELSE listTail.rest ¬ tail;
listTail ¬ tail;
tail ¬ rest;
ENDLOOP;
bnHead ¬ tail;
n ¬ bnHead.first;
IF relaxed OR IsConst[n, TRUE] OR temp = n THEN RETURN [n];
};
ENDCASE;
{
eBits: INT = n.bits;
mod: [0..Target.bitsPerWord) = ModBits[eBits];
newVar: Var ¬ GenRoundedLocal[base, model.label, eBits];
newDecl: Node = GenDecl[newVar, IF mod = 0 THEN n ELSE NIL];
newList: NodeList ¬ NodeListCons[newDecl];
IF listTail # NIL THEN listTail.rest ¬ newList ELSE listHead ¬ newList;
listTail ¬ newList;
newVar.flags[constant] ¬ TRUE;
IF mod # 0
THEN {
The variable is not properly aligned, so just use a field of it.
newVar ¬ AdjustedField[newVar, eBits, TRUE];
listTail ¬ listTail.rest ¬ NodeListCons[GenAssign[newVar, n]];
};
RETURN [newVar];
};
};
WITH proc
SELECT
FROM
oper: OperNode =>
WITH oper.oper
SELECT
FROM
mesa:
REF OperRep.mesa =>
SELECT mesa.mesa
FROM
addr => GO TO dontHassle;
equal, notEqual =>
IF args.first.bits > Target.bitsPerWord THEN GO TO dontHassle;
ENDCASE;
ENDCASE;
ENDCASE;
SELECT
TRUE
FROM
NOT IsReallySimple[proc],
NOT IntCodeUtils.SideEffectFree[proc,
FALSE] =>
Put the procedure into a temp
proc ¬ apply.proc ¬ makeTemp[innerExpr[proc], IsConstList[args, TRUE]];
args #
NIL
AND args.rest =
NIL
AND apply.handler =
NIL => {
In the single-argument case we move the application inside of the block
singleArg: Node = args.first;
IF WillMapValuePoints[singleArg]
THEN {
node ¬ generalVisit[node, singleArg];
GO TO return;
};
};
ENDCASE;
FOR each: NodeList ¬ args, each.rest
WHILE each #
NIL
DO
first: Node = each.first;
IF
NOT IsReallySimple[first]
THEN {
each.first ¬ NIL; -- don't count current argument
each.first ¬ makeTemp[innerExpr[first], IsConstList[args, TRUE]];
};
ENDLOOP;
IF listTail #
NIL
THEN {
We need to make a new block
listTail.rest ¬ NodeListCons[apply];
node ¬ GenBlock[listHead, apply.bits];
};
GO TO return;
EXITS dontHassle => {};
};
decl: DeclNode => {
decl.init ¬ innerExpr[decl.init];
GO TO return;
};
return: ReturnNode => {
rets: NodeList = return.rets;
IF rets #
NIL
THEN
IF rets.rest =
NIL AND WillMapValuePoints[rets.first]
THEN node ¬ generalVisit[return, rets.first]
ELSE exprList[return.rets];
GO TO return;
};
lambda: LambdaNode => GO TO return;
comment: CommentNode => GO TO return;
block: BlockNode => {
nodes: NodeList ¬ block.nodes ¬ innerList[block.nodes];
GO TO return;
};
source: SourceNode => {
source.nodes ¬ innerList[source.nodes];
GO TO return;
};
enable: EnableNode => {
enable.scope ¬ innerList[enable.scope];
GO TO return;
};
ENDCASE;
IntCodeUtils.MapNode[node, innerExpr];
GO TO return;
EXITS return => {
depth ¬ depth - 1;
IF depth < 0 THEN ERROR;
IF declTail #
NIL
THEN {
declTail.rest ¬ NodeListCons[node];
node ¬ GenBlock[declHead, node.bits];
};
declHead ¬ oldDeclHead;
declTail ¬ oldDeclTail;
};
};
RETURN [node];
};
exprList:
PROC [args: NodeList] = {
FOR each: NodeList ¬ args, each.rest
WHILE each #
NIL
DO
expr: Node ¬ each.first ¬ innerExpr[each.first];
IF expr #
NIL
THEN {
eBits: INT ¬ expr.bits;
IF eBits # 0
AND
NOT IsReallySimple[expr]
THEN {
mod: [0..Target.bitsPerWord) = ModBits[eBits];
newVar: Var ¬ GenRoundedLocal[base, model.label, eBits];
newDecl: Node = GenDecl[newVar, NIL];
field: Var = AdjustedField[newVar, eBits, TRUE];
new: NodeList ¬ NodeListCons2[newDecl, innerExpr[GenAssign[field, expr]]];
IF declTail = NIL THEN declHead ¬ new ELSE declTail.rest ¬ new;
declTail ¬ new.rest;
each.first ¬ field;
};
};
ENDLOOP;
};
innerList:
PROC [list: NodeList]
RETURNS [NodeList] = {
This routine is used to process nodes at a "statement" level. All declaration processing actually happens here to avoid inserting an extra level of scope, potentially hiding the declaration fron its users.
this: NodeList ¬ list;
lag: NodeList ¬ NIL;
WHILE this #
NIL
DO
next: NodeList ¬ this.rest;
comment: ROPE ¬ NIL;
first: Node ¬ this.first;
bits: INT ¬ 0;
IF first =
NIL
THEN {
A NIL node at this level can always be spliced out
IF lag = NIL THEN list ¬ next ELSE lag.rest ¬ next;
this ¬ next;
LOOP;
};
WITH first
SELECT
FROM
decl: DeclNode => {
init: Node ¬ decl.init;
IF
NOT IsReallySimple[init]
THEN {
decl.init ¬ NIL;
next ¬ this.rest ¬ NodeListCons[GenAssign[decl.var, init], next];
};
};
ENDCASE => first ¬ innerExpr[first];
this.first ¬ first;
lag ¬ this;
this ¬ next;
ENDLOOP;
IF declHead #
NIL
THEN {
declTail.rest ¬ list;
list ¬ declHead;
declHead ¬ declTail ¬ NIL;
};
RETURN [list];
};
count: INT ¬ 0;
lambda.body ¬ innerList[lambda.body];
};
IsReallySimple:
PUBLIC
PROC [n: Node]
RETURNS [
BOOL] = {
This is an estimate of what can be generated as an expression without nasty control flow and funny effects. It tends to be conservative, but is not necessarily totally correct.
DO
WITH n
SELECT
FROM
const: ConstNode => RETURN [TRUE];
var: Var =>
WITH var.location
SELECT
FROM
local: LocalVarLocation => RETURN [TRUE];
global: GlobalVarLocation => RETURN [TRUE];
deref: DerefLocation => {n ¬ deref.addr; LOOP};
field: FieldLocation => {n ¬ field.base; LOOP};
indexed: IndexedLocation =>
RETURN [IsReallySimple[indexed.base] AND IsReallySimple[indexed.index]];
dummy: DummyLocation => RETURN [TRUE];
ENDCASE;
assign: AssignNode => {
RETURN [IsReallySimple[assign.lhs] AND IsReallySimple[assign.rhs]];
};
apply: ApplyNode => {
args: NodeList ¬ apply.args;
IF apply.handler # NIL THEN RETURN [FALSE];
IF NOT IsReallySimple[apply.proc] THEN RETURN [FALSE];
FOR each: NodeList ¬ apply.args, each.rest
WHILE each #
NIL
DO
IF NOT IsReallySimple[each.first] THEN RETURN [FALSE];
ENDLOOP;
RETURN [TRUE];
};
oper: OperNode => RETURN [TRUE];
mc: MachineCodeNode => RETURN [TRUE];
cond: CondNode => {
FOR each: CaseList ¬ cond.cases, each.rest
WHILE each #
NIL
DO
FOR tests: NodeList ¬ each.tests, tests.rest
WHILE tests #
NIL
DO
IF NOT IsReallySimple[tests.first] THEN RETURN [FALSE];
ENDLOOP;
IF NOT IsReallySimple[each.body] THEN RETURN [FALSE];
ENDLOOP;
RETURN [TRUE];
};
ENDCASE => IF n = NIL THEN RETURN [TRUE];
RETURN [FALSE];
ENDLOOP;
};
WillMapValuePoints:
PROC [node: Node]
RETURNS [
BOOL] = {
tail: NodeList ¬ NIL;
WITH node
SELECT
FROM
block: BlockNode => tail ¬ NodeListTail[block.nodes];
source: SourceNode => tail ¬ NodeListTail[source.nodes];
label: LabelNode => RETURN [TRUE];
cond: CondNode => RETURN [TRUE];
ENDCASE => RETURN [FALSE];
IF tail #
NIL
THEN {
tailNode: Node ¬ tail.first;
IF tailNode # NIL AND tailNode.bits = node.bits THEN RETURN [TRUE];
};
RETURN [FALSE];
};
MapValuePoints:
PROC [node: Node, visitor: IntCodeUtils.Visitor]
RETURNS [Node] = {
tail: NodeList ¬ NIL;
WITH node
SELECT
FROM
source: SourceNode => tail ¬ NodeListTail[source.nodes];
block: BlockNode => tail ¬ NodeListTail[block.nodes];
labelNode: LabelNode => {
label: Label ¬ labelNode.label;
new: Node ¬ label.node;
IF new #
NIL
THEN {
new ¬ MapValuePoints[label.node, visitor];
IF new # NIL THEN {label.node ¬ new; labelNode.bits ¬ new.bits};
};
GO TO done;
};
cond: CondNode => {
bits: INT ¬ cond.bits;
FOR each: CaseList ¬ cond.cases, each.rest
WHILE each #
NIL
DO
body: Node ¬ each.body;
IF body #
NIL
THEN {
new: Node ¬ MapValuePoints[body, visitor];
IF new # NIL THEN {bits ¬ new.bits; each.body ¬ new};
};
ENDLOOP;
cond.bits ¬ bits;
GO TO done;
};
goto: GotoNode => GO TO done;
rtn: ReturnNode => GO TO done;
ENDCASE => RETURN [visitor[node]];
IF tail #
NIL
THEN {
tailNode: Node ¬ tail.first;
IF tailNode #
NIL
AND node.bits = tailNode.bits
THEN {
new: Node ¬ MapValuePoints[tailNode, visitor];
IF new # NIL THEN {node.bits ¬ new.bits; tail.first ¬ new};
};
};
GO TO done;
EXITS done => RETURN [node];
};
MergeDecl:
PROC [decl: DeclNode, list: NodeList]
RETURNS [NodeList] = {
IF decl.init =
NIL
AND list #
NIL
THEN {
WITH list.first
SELECT
FROM
assn: AssignNode =>
IF assn.lhs = decl.var
AND assn.bits = 0
THEN {
decl.init ¬ assn.rhs;
list ¬ list.rest;
};
ENDCASE;
};
RETURN [list];
};
RemTemp:
PROC [list: NodeList]
RETURNS [NodeList] = {
declLag: NodeList ¬ NIL;
IF list #
NIL
THEN {
WITH list.first
SELECT
FROM
decl: DeclNode => {
scanChange: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
Sets changed to TRUE if the object could be affected, or if the temp is used in any way except simple assignments.
IF
NOT changed
THEN {
WITH node
SELECT
FROM
bn: BlockNode => {};
cn: CondNode => {};
sn: SourceNode => {};
dn: DeclNode =>
IF NodeContains[object, dn.var] THEN GO TO change;
assn: AssignNode => {
lhs: Var = assn.lhs;
IF CouldIntersect[node, object] THEN GO TO change;
IF CouldIntersect[assn.rhs, temp] THEN GO TO change;
WITH lhs.location
SELECT
FROM
loc:
REF LocationRep.localVar =>
IF lhs = temp THEN GO TO noChange;
field:
REF LocationRep.field =>
IF field.base = temp THEN GO TO noChange;
ENDCASE;
IF CouldIntersect[lhs, temp] THEN GO TO change;
GO TO noChange;
};
ENDCASE => {
IF CouldIntersect[node, object] THEN GO TO change;
IF CouldIntersect[node, temp] THEN GO TO change;
GO TO noChange;
};
IntCodeUtils.MapNode[node, scanChange];
};
GO TO noChange;
EXITS
change => {changed ¬ TRUE; RETURN [node]};
noChange => RETURN [node];
};
changed: BOOL ¬ FALSE;
object: Var ¬ NIL;
temp: Var ¬ decl.var;
rest: NodeList ¬ list.rest;
lag: NodeList ¬ list;
tail: NodeList ¬ lag.rest;
IF tail = NIL THEN GO TO tryNext;
IF temp.flags[named] OR temp.flags[addressed] THEN GO TO tryNext;
WITH temp.location
SELECT
FROM
loc: REF LocationRep.localVar => {};
ENDCASE => GO TO tryNext;
DO
WITH tail.first
SELECT
FROM
assn: AssignNode => {
lhs: Var = assn.lhs;
IF CouldIntersect[decl.init, lhs]
THEN
GO
TO tryNext;
If the assignment could affect the initialization, then we cannot remove the use of this temporary without changing the semantics.
IF assn.rhs = temp
THEN {
This could be the last use of temp, and we might be able to substitute the destination of the assignment for all uses of temp.
IF NodeContains[lhs, temp] THEN GO TO tryNext;
IF NOT IsSimple[lhs, [derefs: 1, noSignals: TRUE]] THEN GO TO tryNext;
FOR each: NodeList ¬ tail.rest, each.rest
WHILE each #
NIL
DO
Ensure that there is no subsequent use of temp
IF NodeContains[each.first, temp] THEN GO TO tryNext;
ENDLOOP;
object ¬ lhs;
FOR each: NodeList ¬ list.rest, each.rest
WHILE each # tail
DO
[] ¬ scanChange[each.first];
IF changed THEN GO TO tryNext;
ENDLOOP;
IF decl.init #
NIL
THEN list.first ¬ GenAssign[lhs: lhs, rhs: decl.init]
ELSE list ¬ list.rest;
SubstituteInList[list: list, old: temp, new: lhs];
IF assn.bits # 0
THEN tail.first ¬ lhs
ELSE lag.rest ¬ tail.rest;
GO TO tryNext;
};
WITH assn.lhs.location
SELECT
FROM
loc: REF LocationRep.localVar => IF assn.lhs = temp THEN GO TO okThisTime;
field: REF LocationRep.field => IF field.base = temp THEN GO TO okThisTime;
ENDCASE => GO TO tryNext;
IF CouldIntersect[assn.lhs, temp] THEN GO TO tryNext;
IF CouldIntersect[assn.rhs, temp] THEN GO TO tryNext;
EXITS okThisTime => {};
};
cn: CommentNode => {};
dn: DeclNode =>
IF declLag = NIL AND NOT dn.var.flags[named] THEN declLag ¬ lag;
labNode: LabelNode =>
GO
TO tryNext;
Can't trust the control flow
gotoNode: GotoNode =>
GO
TO tryNext;
Can't trust the control flow
ENDCASE;
lag ¬ tail;
tail ¬ lag.rest;
IF tail = NIL THEN GO TO done;
ENDLOOP;
};
ENDCASE;
EXITS
done => { };
tryNext =>
The one we looked at was no good, but there is a next candidate
IF declLag # NIL THEN declLag.rest ¬ RemTemp[declLag.rest];
};
RETURN [list];
};
ReturnSubstitution:
PROC
[base: BaseModel, model: LambdaModel, nodes: NodeList, rtnPtr: Var] = {
rtnAssn: AssignNode ¬ NIL;
rtnVar: Var ¬ NIL;
rtnVarDecl: DeclNode ¬ NIL;
assnHead: NodeList ¬ NIL;
abort: BOOL ¬ FALSE;
remField: IntCodeUtils.Visitor = {
WITH node
SELECT
FROM
var: Var =>
WITH var.location
SELECT
FROM
fv: FieldLocation => {
base: Node = fv.base;
IF fv.start = 0
AND var.bits = base.bits
THEN
WITH base
SELECT
FROM
bv: Var => RETURN [base];
ENDCASE;
};
ENDCASE;
ENDCASE;
RETURN [node];
};
firstPass: IntCodeUtils.Visitor = {
The first pass removes bogus self-assignments, and finds a single assignment to deref of the rtnPtr. If there is such a single assignment, it must be from a simple local return variable.
WITH node
SELECT
FROM
var: Var => {
IF var = rtnPtr THEN abort ¬ TRUE;
RETURN [remField[var]];
};
assn: AssignNode => {
lhs: Var ¬ assn.lhs ¬ NARROW[remField[assn.lhs]];
rhs: Node ¬ assn.rhs ¬ remField[assn.rhs];
base: Var ¬ lhs;
start: INT ¬ 0;
bits: INT ¬ lhs.bits;
IF testBogusAssignment
AND IntCodeUtils.SimplyEqual[lhs, rhs]
AND IntCodeUtils.SideEffectFree[lhs,
TRUE]
AND IntCodeUtils.SideEffectFree[rhs,
TRUE]
THEN {
A completely bogus assignment
IF node.bits # 0 THEN RETURN [lhs];
RETURN [IntCodeStuff.GenComment["removed bogus assignment"]];
};
WITH lhs.location
SELECT
FROM
deref:
REF LocationRep.deref =>
IF deref.addr = rtnPtr
THEN {
IF rtnAssn =
NIL
THEN
WITH rhs
SELECT
FROM
rv: Var =>
WITH rv.location
SELECT
FROM
rLoc:
REF LocationRep.localVar =>
IF
NOT rv.flags[addressed]
AND
NOT rv.flags[upLevel]
THEN {
This variable is not addressed or upLevel, so it is simple enough
assn.rhs ¬ firstPass[rhs];
rtnVar ¬ rv;
rtnAssn ¬ assn;
RETURN [assn];
};
ENDCASE;
ENDCASE;
abort ¬ TRUE;
};
ENDCASE;
};
ENDCASE;
IntCodeUtils.MapNode[node, firstPass];
RETURN [node];
};
secondPass: IntCodeUtils.Visitor = {
The second pass collects all simple assignments to the rtnVar, sorting the assignments by the start position.
IF abort THEN RETURN [node];
WITH node
SELECT
FROM
var: Var => IF var = rtnVar THEN abort ¬ TRUE;
decl: DeclNode =>
IF decl.var = rtnVar
THEN {
decl.init ¬ secondPass[decl.init];
IF decl.init # NIL THEN abort ¬ TRUE;
IF retainNamedReturns AND rtnVar.flags[named] THEN abort ¬ TRUE;
rtnVarDecl ¬ decl;
RETURN [node];
};
assn: AssignNode => {
lhs: Var = assn.lhs;
rhs: Node = assn.rhs;
base: Var ¬ lhs;
start: CARD ¬ 0;
bits: INT ¬ lhs.bits;
IF retainNamedReturns AND lhs.flags[named] THEN {abort ¬ TRUE; RETURN [node]};
IF assn = rtnAssn THEN RETURN [node];
WITH lhs.location
SELECT
FROM
field:
REF LocationRep.field => {
IF field.cross THEN ERROR; -- cant expect cross records in a return can we? LAI. Lifted: ChJ, May 4, 1993
WITH field.base
SELECT
FROM
fv: Var => {base ¬ fv; start ¬ field.start};
ENDCASE;
};
ENDCASE;
IF base = rtnVar
AND bits < rtnVar.bits
THEN {
We have a new assignment to collect
new: NodeList ¬ NodeListCons[assn];
lag: NodeList ¬ NIL;
lagLim: CARD ¬ 0;
assn.rhs ¬ secondPass[assn.rhs];
FOR each: NodeList ¬ assnHead, each.rest
WHILE each #
NIL
DO
WITH each.first
SELECT
FROM
listAssn: AssignNode => {
listStart: CARD ¬ 0;
WITH listAssn.lhs.location
SELECT
FROM
listField:
REF LocationRep.field => {
IF listField.cross THEN ERROR; -- cant expect cross records in a return can we? LAI. Lifted, ChJ, May 4, 1993
listStart ¬ listField.start;
};
ENDCASE;
IF start <= listStart THEN EXIT;
lagLim ¬ listStart + listAssn.lhs.bits;
};
ENDCASE => ERROR;
lag ¬ each;
ENDLOOP;
IF lag =
NIL
THEN {new.rest ¬ assnHead; assnHead ¬ new}
ELSE {new.rest ¬ lag.rest; lag.rest ¬ new};
RETURN [node];
};
};
ENDCASE;
IntCodeUtils.MapNode[node, secondPass];
RETURN [node];
};
thirdPass: IntCodeUtils.Visitor = {
The third pass turns fields of the rtnVar into simple variables or constants.
list: NodeList ¬ NIL;
WITH node
SELECT
FROM
sn: SourceNode => thirdPassList[sn.nodes];
bn: BlockNode => thirdPassList[bn.nodes];
assn: AssignNode => {
An assignment to a constant return field is discarded. An assignment to a variable return field is turned into an assignment to a simple variable. And the rtnAssn is turned into a sequence of assignments to field thru the rtnPtr.
base: Var ¬ assn.lhs;
start: CARD ¬ 0;
lim: CARD ¬ 0;
IF assn = rtnAssn
THEN {
This assignment needs to be replaced by a block of assignments
newList: NodeList ¬ NIL;
FOR each: NodeList ¬ assnHead, each.rest
WHILE each #
NIL
DO
new: Node ¬ NIL;
start: CARD ¬ 0;
val: Node ¬ NIL;
var: Var ¬ NIL;
WITH each.first
SELECT
FROM
eAssn: AssignNode => {var ¬ eAssn.lhs; val ¬ eAssn.rhs};
ENDCASE => ERROR;
WITH var.location
SELECT
FROM
field:
REF LocationRep.field => {
IF field.cross THEN ERROR; -- cant expect cross records in a return can we? LAI. Lifted, ChJ, May 4, 1993
start ¬ field.start;
};
ENDCASE;
newList ¬ NodeListCons[
GenAssign[GenFieldOfDeref[rtnPtr, start, var.bits], val],
newList];
ENDLOOP;
RETURN [GenBlock[newList]];
};
WITH assn.lhs.location
SELECT
FROM
field:
REF LocationRep.field => {
IF field.cross THEN ERROR; -- cant expect cross records in a return can we? LAI. Lifted, ChJ, May 4, 1993
WITH field.base
SELECT
FROM
fv: Var => {base ¬ fv; start ¬ field.start};
ENDCASE;
};
ENDCASE;
IF base = rtnVar
THEN {
lim ¬ start + assn.lhs.bits;
FOR each: NodeList ¬ assnHead, each.rest
WHILE each #
NIL
DO
eStart: CARD ¬ 0;
val: Node ¬ NIL;
var: Var ¬ NIL;
const: BOOL ¬ FALSE;
WITH each.first
SELECT
FROM
eAssn: AssignNode => {var ¬ eAssn.lhs; val ¬ eAssn.rhs};
ENDCASE => ERROR;
WITH var.location
SELECT
FROM
field:
REF LocationRep.field => {
IF field.cross THEN ERROR; -- cant expect cross records in a return can we? LAI. Lifted, ChJ, May 4, 1993
eStart ¬ field.start;
};
ENDCASE;
IF start = eStart
THEN {
The right field is now found. Discard an assignment of a constant
IF IsConst[val,
FALSE]
THEN {
IF assn.bits # 0 THEN RETURN [val];
RETURN [GenComment["eliminated constant return field"]];
};
At this point we retain the assignment, but substitute the new variable
RETURN [GenAssign[NARROW[val], assn.rhs, assn.bits]];
};
ENDLOOP;
ERROR;
We should not be able to find such an assignment!
};
};
ENDCASE => IntCodeUtils.MapNode[node, thirdPass];
RETURN [node];
};
thirdPassList:
PROC [list: NodeList] = {
WHILE list #
NIL
DO
first: Node = thirdPass[list.first];
list.first ¬ first;
WITH first
SELECT
FROM
dn: DeclNode =>
IF dn = rtnVarDecl
THEN {
This must become a sequence of declarations
list.first ¬ IntCodeStuff.GenComment["Return var split"];
FOR aList: NodeList ¬ assnHead, aList.rest
WHILE aList #
NIL
DO
WITH aList.first
SELECT
FROM
var: Var => {
vBits: INT = var.bits;
newVar: Var = GenRoundedLocal[base, model.label, vBits];
aList.first ¬ GenAssign[var, AdjustedField[newVar, vBits, FALSE]];
list.rest ¬ NodeListCons[GenDecl[newVar, NIL], list.rest];
list ¬ list.rest;
};
ENDCASE;
ENDLOOP;
};
ENDCASE;
list ¬ list.rest;
ENDLOOP;
};
IntCodeUtils.MapNodeList[nodes, firstPass];
IF rtnVar #
NIL
AND
NOT abort
THEN {
lagStart: CARD ¬ 0;
lagLim: CARD ¬ 0;
IntCodeUtils.MapNodeList[nodes, secondPass];
IF abort THEN GO TO noDice;
Now rewrite the sorted assignment list to ensure that the fields are distinct. Assignments of single constants are retained. Otherwise, the fields of the rtnVar are retained. The assignments themselves are not modified.
FOR each: NodeList ¬ assnHead, each.rest
WHILE each #
NIL
DO
start: CARD ¬ 0;
lim: CARD ¬ 0;
WITH each.first
SELECT
FROM
assn: AssignNode => {
multiple: BOOL ¬ FALSE;
constVal: Node ¬ NIL;
WITH assn.lhs.location
SELECT
FROM
field:
REF LocationRep.field => {
IF field.cross THEN ERROR; -- cant expect cross records in a return can we? LAI. Lifted, ChJ, May 4, 1993
start ¬ field.start;
};
ENDCASE;
lim ¬ start + assn.lhs.bits;
IF lagLim > start THEN GO TO noDice;
IF assn.rhs.bits = Target.bitsPerWord
AND IsConst[assn.rhs,
FALSE]
THEN
constVal ¬ assn.rhs;
FOR next: NodeList ¬ each.rest, next.rest
WHILE next #
NIL
DO
WITH next.first
SELECT
FROM
nassn: AssignNode => {
nstart: CARD ¬ 0;
nlim: CARD ¬ 0;
WITH nassn.lhs.location
SELECT
FROM
field:
REF LocationRep.field => {
IF field.cross THEN ERROR; -- cant expect cross records in a return can we? LAI. Lifted, ChJ, May 4, 1993
nstart ¬ field.start;
};
ENDCASE;
nlim ¬ nstart + nassn.lhs.bits;
SELECT
TRUE
FROM
start = nstart
AND lim = nlim =>
IF constVal =
NIL
OR
NOT IntCodeUtils.SimplyEqual[constVal, nassn.rhs]
THEN
multiple assignments to the same field
multiple ¬ TRUE;
lim > nstart =>
GO
TO noDice;
overlapping fields, so don't even try
ENDCASE =>
EXIT;
Done with this scan
each.rest ¬ next.rest;
};
ENDCASE => ERROR;
ENDLOOP;
SELECT
TRUE
FROM
NOT multiple AND constVal # NIL => {};
ENDCASE => each.first ¬ assn.lhs;
};
ENDCASE => ERROR;
lagStart ¬ start;
lagLim ¬ lim;
ENDLOOP;
IntCodeUtils.MapNodeList[nodes, thirdPass];
EXITS noDice => {abort ¬ TRUE};
};
};
CouldIntersect:
PROC [node: Node, lhs: Var]
RETURNS [
BOOL] = {
list: NodeList ¬ NIL;
IF node = NIL THEN RETURN [FALSE];
IF node = lhs THEN RETURN [TRUE];
WITH node
SELECT
FROM
const: ConstNode => RETURN [FALSE];
var: Var => {
IF var.flags[constant] THEN RETURN [FALSE];
WITH var.location
SELECT
FROM
local:
REF LocationRep.localVar => {
IF NodeContains[var, lhs] THEN RETURN [TRUE];
RETURN [var.flags[addressed]];
};
field:
REF LocationRep.field => {
WITH lhs.location
SELECT
FROM
lf:
REF LocationRep.field =>
IF EqualVars[field.base, lf.base,
FALSE]
AND field.cross=lf.cross <<ChJ lifted>>
THEN {
Special case looking for disjoint fields
IF NOT SideEffectFree[field.base, FALSE] THEN RETURN [TRUE];
SELECT field.start
FROM
< lf.start => RETURN [field.start+var.bits > lf.start];
> lf.start => RETURN [lf.start+lhs.bits > field.start];
ENDCASE => RETURN [TRUE];
};
ENDCASE;
RETURN [CouldIntersect[field.base, lhs]];
};
deref:
REF LocationRep.deref => {
IF var.flags[addressed] THEN RETURN [TRUE];
RETURN [CouldIntersect[deref.addr, lhs]];
};
ENDCASE;
RETURN [TRUE];
};
apply: ApplyNode => {
IF NOT SideEffectFree[apply, FALSE] THEN RETURN [TRUE];
IF apply.handler # NIL THEN RETURN [TRUE];
FOR each: NodeList ¬ apply.args, each.rest
WHILE each #
NIL
DO
IF CouldIntersect[each.first, lhs] THEN RETURN [TRUE];
ENDLOOP;
RETURN [FALSE];
};
bn: BlockNode => list ¬ bn.nodes;
sn: SourceNode => list ¬ sn.nodes;
cn: CommentNode => RETURN [FALSE];
cond: CondNode => {
FOR each: CaseList ¬ cond.cases, each.rest
WHILE each #
NIL
DO
FOR each: CaseList ¬ cond.cases, each.rest
WHILE each #
NIL
DO
FOR tests: NodeList ¬ each.tests, tests.rest
WHILE tests #
NIL
DO
IF NOT CouldIntersect[tests.first, lhs] THEN RETURN [TRUE];
ENDLOOP;
IF CouldIntersect[each.body, lhs] THEN RETURN [TRUE];
ENDLOOP;
ENDLOOP;
RETURN [FALSE];
};
an: AssignNode =>
RETURN [CouldIntersect[an.lhs, lhs] OR CouldIntersect[an.rhs, lhs]];
dn: DeclNode =>
RETURN [CouldIntersect[dn.var, lhs] OR CouldIntersect[dn.init, lhs]];
ENDCASE;
FOR each: NodeList ¬ list, each.rest
WHILE each #
NIL
DO
IF CouldIntersect[each.first, lhs] THEN RETURN [TRUE];
ENDLOOP;
RETURN [TRUE];
};
EqualVars:
PROC [n1, n2: Node, compareBits:
BOOL]
RETURNS [
BOOL] = {
IF n1 = n2 THEN RETURN [TRUE];
WITH n1
SELECT
FROM
v1: Var => {
WITH n2
SELECT
FROM
v2: Var => {
IF v1.id # 0 AND v2.id # 0 AND v1.id # v2.id THEN RETURN [FALSE];
WITH v1.location
SELECT
FROM
v1f: FieldLocation =>
WITH v2.location
SELECT
FROM
v2f: FieldLocation => {
IF v1f.start # v2f.start THEN RETURN [FALSE];
IF v1f.cross # v2f.cross THEN RETURN [FALSE]; --Lifted, ChJ
IF compareBits AND v1.bits # v2.bits THEN RETURN [FALSE];
RETURN [EqualVars[v1f.base, v2f.base, FALSE]];
};
ENDCASE;
v1d: DerefLocation =>
WITH v2.location
SELECT
FROM
v2d: DerefLocation => RETURN [EqualVars[v1d.addr, v2d.addr, FALSE]];
ENDCASE;
ENDCASE;
};
ENDCASE;
};
ENDCASE;
RETURN [FALSE];
};
SubstituteInList:
PROC [list: NodeList, old: Node, new: Node] = {
inner: IntCodeUtils.Visitor = {
IF node = old THEN RETURN [new];
IntCodeUtils.MapNode[node, inner];
IF newIsField
THEN
WITH node
SELECT
FROM
var: Var =>
WITH var.location
SELECT
FROM
field: FieldLocation =>
WITH field.base
SELECT
FROM
baseVar: Var =>
WITH baseVar.location
SELECT
FROM
baseField: FieldLocation =>
IF field.cross=baseField.cross
THEN {
-- simply add if same sex
field.start ¬ field.start + baseField.start;
field.base ¬ baseField.base;
}
ELSE {
--lifted but not understood ChJ
-- upper node is a field of a record in an cross record, translate to native access by pretending the cross base is a native base and adjusting the offsets
-- upper node is a field of an cross record in an native record, translate to cross access by pretending the native base is an cross base, and adjusting the offsets
IF field.base.bits >= bitsPerWord
THEN {
-- we should test if the basefield.start is a multiple of words LAI
field.start ← field.start + baseField.start
}
ELSE {
-- we have to switch an offset within a word
field.start ← field.start + Basics32.BITXOR[ baseField.start + field.base.bits-1, bitsPerWord-1]
};
field.base ← baseField.base;
};
ENDCASE;
ENDCASE;
ENDCASE;
ENDCASE;
RETURN [node];
};
newIsField: BOOL ¬ FALSE;
WITH new
SELECT
FROM
var: Var =>
WITH var.location
SELECT
FROM
field: FieldLocation => newIsField ¬ TRUE;
ENDCASE;
ENDCASE;
IntCodeUtils.MapNodeList[list, inner];
};
FindLeadingLabel:
PROC [node: Node]
RETURNS [Label] = {
WITH node
SELECT
FROM
labNode: REF NodeRep.label => RETURN [labNode.label];
source: SourceNode =>
IF source.nodes # NIL THEN RETURN [FindLeadingLabel[source.nodes.first]];
ENDCASE;
RETURN [NIL];
};
RemTailGoTo:
PROC [base: Node, label: Label, comment: Node]
RETURNS [Node] = {
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
list: NodeList ¬ NIL;
WITH node
SELECT
FROM
goto:
REF NodeRep.goto =>
IF goto.dest = label THEN RETURN [comment] ELSE RETURN [node];
cond:
REF NodeRep.cond => {
trivial: BOOL ¬ TRUE;
FOR each: CaseList ¬ cond.cases, each.rest
WHILE each #
NIL
DO
new: Node ¬ inner[each.body];
each.body ¬ new;
IF NOT IsTrivial[new] THEN trivial ¬ FALSE;
ENDLOOP;
IF trivial
THEN {
FOR each: CaseList ¬ cond.cases, each.rest
WHILE each #
NIL
DO
FOR tests: NodeList ¬ each.tests, tests.rest
WHILE tests #
NIL
DO
IF NOT IntCodeUtils.SideEffectFree[tests.first, TRUE] THEN GO TO nonTrivial;
ENDLOOP;
ENDLOOP;
RETURN [GenComment["removed trivial cond node"]];
EXITS nonTrivial => {};
};
RETURN [node];
};
block: BlockNode => list ¬ block.nodes;
source: SourceNode => list ¬ source.nodes;
enable: EnableNode => list ¬ enable.scope;
ENDCASE => RETURN [node];
IF list #
NIL
THEN
DO
next: NodeList ¬ list.rest;
IF next # NIL THEN {list ¬ next; LOOP};
list.first ¬ inner[list.first];
EXIT;
ENDLOOP;
RETURN [node];
};
RETURN [inner[base]];
};
IsTrivial:
PROC [node: Node]
RETURNS [
BOOL] = {
list: NodeList ¬ NIL;
IF node = NIL THEN RETURN [TRUE];
WITH node
SELECT
FROM
block: BlockNode => list ¬ block.nodes;
source: SourceNode => list ¬ source.nodes;
enable: EnableNode => list ¬ enable.scope;
comNode: REF NodeRep.comment => RETURN [TRUE];
ENDCASE => RETURN [FALSE];
WHILE list #
NIL
DO
IF NOT IsTrivial[list.first] THEN RETURN [FALSE];
list ¬ list.rest;
ENDLOOP;
RETURN [TRUE];
};
IsConstList:
PROC [list: NodeList, varOK:
BOOL]
RETURNS [
BOOL] = {
FOR each: NodeList ¬ list, each.rest
WHILE each #
NIL
DO
IF NOT IsConst[each.first, varOK] THEN RETURN [FALSE];
ENDLOOP;
RETURN [TRUE];
};
IsConst:
PROC [n: Node, varOK:
BOOL]
RETURNS [
BOOL] = {
WITH n
SELECT
FROM
var: Var => {
IF varOK AND var.flags[constant] THEN RETURN [TRUE];
WITH var.location
SELECT
FROM
field: FieldLocation => RETURN [IsConst[field.base, varOK]];
dummy: DummyLocation => RETURN [TRUE];
ENDCASE;
};
const: REF NodeRep.const => RETURN [TRUE];
cond: CondNode => {
FOR each: CaseList ¬ cond.cases, each.rest
WHILE each #
NIL
DO
FOR each: CaseList ¬ cond.cases, each.rest
WHILE each #
NIL
DO
FOR tests: NodeList ¬ each.tests, tests.rest
WHILE tests #
NIL
DO
IF NOT IsConst[tests.first, varOK] THEN RETURN [FALSE];
ENDLOOP;
IF NOT IsConst[each.body, varOK] THEN RETURN [FALSE];
ENDLOOP;
ENDLOOP;
RETURN [TRUE];
};
ENDCASE;
RETURN [n = NIL];
};
ModBits:
PROC [bits:
INT]
RETURNS [[0..Target.bitsPerWord)] =
INLINE {
RETURN [
(
IF
BITS[
WORD] =
BITS[
INT]
THEN LOOPHOLE[bits, WORD]
ELSE Basics32.LowHalf[LOOPHOLE[bits, CARD]]) MOD Target.bitsPerWord];
};
GenRoundedLocal:
PROC [base: BaseModel, parent: Label, bits:
INT]
RETURNS [Var] = {
IF bits # Target.bitsPerWord
THEN {
mod: [0..Target.bitsPerWord) = ModBits[bits];
IF mod # 0 THEN bits ¬ bits + (Target.bitsPerWord-mod);
};
RETURN [GenAnonLocal[base, parent, bits]];
};
AdjustedField:
PROC [var: Var, bits:
INT, isConst:
BOOL]
RETURNS [Var] = {
Lifted comment from the little endian compiler: ChJ
do we need this in a little-endian machine? a AdjustedXField? LAI
mod: [0..Target.bitsPerWord) = ModBits[bits];
IF isConst THEN var.flags[constant] ¬ TRUE;
IF mod # 0
THEN {
offset: INT ¬ IF bits < Target.bitsPerWord AND Target.bitOrder = msBit <<???Lifted, ChJ. This is wierd>> THEN (Target.bitsPerWord-bits) ELSE 0;
var ¬ GenField[var, offset, bits];
IF isConst THEN var.flags[constant] ¬ TRUE;
};
RETURN [var];
};
END.