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.