
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] = {
innerList: PROC [list: NodeList] RETURNS [NodeList] = {
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 {
WITH this SELECT FROM
decl: DeclNode =>
decl.init Ź NIL;
block: BlockNode =>
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 => {
splicingOut Ź FALSE;
GO TO spliceIn;
};
this = deadLabelComment, this = deadCodeComment =>
GO TO spliceIn;
ENDCASE;
WITH this SELECT FROM
decl: DeclNode => {
decl.init Ź NIL;
GO TO spliceIn;
};
ENDCASE;
IF NOT splicingOut THEN {
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] = {
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 = {
list: NodeList Ź NIL;
WITH node SELECT FROM
var: Var => {
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 => {
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;
};
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 {
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 {
IF head.rest = NIL THEN {
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 {
live Ź TRUE;
labelCount Ź labelCount + 1;
}
ELSE {
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 => {
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 Ź oldLive;
lastTestList Ź each.tests;
FOR tests: NodeList Ź lastTestList, tests.rest WHILE tests # NIL DO
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;
nCases < 2 => node Ź lastBody;
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 => {
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 {
decl.init Ź assign.rhs;
nodes.rest Ź rest.rest;
LOOP;
};
ENDCASE;
IF NOT var.flags[named] AND rest # NIL THEN {
rest Ź rest.rest;
IF rest # NIL AND rest.rest = NIL THEN
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];
IF block.bits = 0
THEN
node Ź apply
ELSE
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 = {
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 => {
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 => {
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 {
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] =>
proc Ź apply.proc Ź makeTemp[innerExpr[proc], IsConstList[args, TRUE]];
args # NIL AND args.rest = NIL AND apply.handler = NIL => {
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 {
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: 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 {
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] = {
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 = {
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 assn.rhs = temp THEN {
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
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;
gotoNode: GotoNode => GO TO tryNext;
ENDCASE;
lag Ź tail;
tail Ź lag.rest;
IF tail = NIL THEN GO TO done;
ENDLOOP;
};
ENDCASE;
EXITS
done => { };
tryNext =>
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 = {
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 {
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 {
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 = {
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 {
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 = {
list: NodeList Ź NIL;
WITH node SELECT FROM
sn: SourceNode => thirdPassList[sn.nodes];
bn: BlockNode => thirdPassList[bn.nodes];
assn: AssignNode => {
base: Var Ź assn.lhs;
start: CARD Ź 0;
lim: CARD Ź 0;
IF assn = rtnAssn THEN {
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 {
IF IsConst[val, FALSE] THEN {
IF assn.bits # 0 THEN RETURN [val];
RETURN [GenComment["eliminated constant return field"]];
};
RETURN [GenAssign[NARROW[val], assn.rhs, assn.bits]];
};
ENDLOOP;
ERROR;
};
};
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 {
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;
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 Ź TRUE;
lim > nstart => GO TO noDice;
ENDCASE => EXIT;
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 {
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 = {
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] = {
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.


  6  
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
This routine cleans up the tree, removing all sorts of unclean cases.
innerList treats the list as a sequence of nodes where we should splice out the unreachable stuff.
Special cases where we can eliminate jumping into things without processing the parts, since we can't jump into the middle of processing.
Just kill the initialization, since it can't be executed
Get rid of the whole thing
This node either was live or has become live, or must be preserved because there may be a live piece in it.
Preserve notices of dead labels and code
At this point we are going to lose this node unless it is a declaration
Just kill the initialization, since it can't be executed
At this point we are going to lose this node forever
We need to put in a splice out notice
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.
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
Special handling for variables (both because they are common and because they are a lot like application).
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.
--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
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.
We were able to break up the composite, so make a block
Actually, a single assignment will do
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.
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.
The liveness of a cond is the OR of all the livenesses of the arms.
represents the test liveness if all of them could evaluate to FALSE
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.
There is an implicit ENDCASE or ELSE preserving liveness
The cond is trivially unconditional
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.
Collapse out an assignment if it can be done by the decl init
This code declares a nameless variable, and may not need to.
This looks suspiciously like a gratuitous temporary
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.
The apply node is sufficient
We need to return the ultimate var as the value
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
A field location can be moved into the block!
A deref location can be moved into the block!
The variable is not properly aligned, so just use a field of it.
Put the procedure into a temp
In the single-argument case we move the application inside of the block
We need to make a new block
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.
A NIL node at this level can always be spliced out
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.
[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 the assignment could affect the initialization, then we cannot remove the use of this temporary without changing the semantics.
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.
Ensure that there is no subsequent use of temp
Can't trust the control flow
Can't trust the control flow
The one we looked at was no good, but there is a next candidate
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.
A completely bogus assignment
This variable is not addressed or upLevel, so it is simple enough
The second pass collects all simple assignments to the rtnVar, sorting the assignments by the start position.
We have a new assignment to collect
The third pass turns fields of the rtnVar into simple variables or constants.
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.
This assignment needs to be replaced by a block of assignments
The right field is now found.  Discard an assignment of a constant
At this point we retain the assignment, but substitute the new variable
We should not be able to find such an assignment!
This must become a sequence of declarations
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.
multiple assignments to the same field
overlapping fields, so don't even try
Done with this scan
Special case looking for disjoint fields
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
Lifted comment from the little endian compiler: ChJ
do we need this in a little-endian machine?  a AdjustedXField? LAI 
Ę;  (cedarcode) styleNewlineDelimiter
 headIcode
ĎeCNL0L(L) Ďk		L	LLLLLLLLLĎnLEYLL/;L L#L%L!L LL L(L,L 7.LL  LLLLL (
WL"+LL>SL..LLL((LLL KeLEEStartOfExpansion7 -- [node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]7LbbLLLL	L
LL3LL8LLLLLLLL0L,,L	2ELL))LkLL
L22L(L
LLGL8LL
LLL4L%LLL
LL5LLLLLL#LL$LŽBóL	L	"8LLLLLLL3LLjL77L77L;;L	L	L##LLL%%LLLL(>L
%L,:LLLLL%#9L
%L2ALLL##L3LLLLLLLLLLLL%L	LL	'LLLL
L	@Ďc /ZL
LáLL28LLLLLLLL(>LLL&L++L44LL3LLLLL7L%LLLLL&=L##LLLLLLLLLLLLLLLL-LLLLL%%LLL))L*LL L++L
KLLLLL''LLL''LLLLLLLLLL#CL	L	LLLL>C(>LL,	CL­L!!L$LL((L	LL8L8L#LLLLL	4	(GL8NLLťBL	L	LLLLL	L$LLLL""LL	LLLL::L88L::L88L
.L55LL 9L	0LLL6L
#L#:LL
GL=LLLLL
-L<L	&L30LL''/L.11LLLşşLLL/LFFLLLLLLLLLLLLLLL L=^LLL>L	) 9L15L15LHHLLHHL;;L//LLLLLLLLLL#L3L!!L!!L";LL!LL-LL$$L!=LLLL-LL**L!=LLLLLL//LL ;LLLLLL
:LLLLL(LLLLLLALLLLLL	
;LLL
L..L88L	 	<L**LGLL	L@L&,L>>LL
LL,LL&>LLL#ILL@G;LGL'L%%LLLL"8L#L 2L:ALLLL$L&LLLLL!!LLL5L(,LLLL#L%L77LLL''LLL''LLLL&&LLLL##L%%LLLLLLL
#"8L00L0L..L88L %L*0LJJL?LLLLLL7LÎLLLL7 -- [node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]	LL	L-2L3LLLL"LLAALLL$LLLLLLLLLLLL%%LL 
8L-ĎbtąL")L)L+L)/L)/L HL&LLCLLL
+L
6(>L
6LLLL L%(>*	AL
7LL
5LLLL)LLLL 8LL55L88L"L LLLCLLLL -SLL88L55LLL**L/@LLLL(>LL**L$5LLLLLLLL"L6L..L*;LLLL	LL 	"G
(CLLLLLLLL 5L7 -- [node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]$L3L^r	LLLL2LL2L 4 L
"L
)LL/L
LL2L0L
LL'LL
L	*LLL	LLLLLL
	!L
	AL$L	L 	5LL~L	.L&	F'=L.L 	5LL'>LL		LL15LL2LLL	L"LJLKL	L 	5L 	5LLLL
@	$L	$LLLLL
LLLL

L?L&;LLLL H`LLLLL")L-LLLLLLL#LťL	"LLL1L*LLL$""LL#L7=L'!
;LALLLLLLLLLLLLL&&LL$LmLL	.-L""L	%L	@LLLLLLLLL

	NL%!L 4     jL,,LLL.L#L#LLL &<L&%L OnLLLL L''LLLLL&*L'+LLLLL''LL#LMLL**L))LçLLLL>L&<LLLLL88L!L OjLLLL[[LLL"!L OjL,,LLLL&<LLLLL88L!L OjLLLLBL#L28LLGL5LLL1LLL*1LL(L$$L)L+L99(	?LL88L:BL):LLLLLLLLLL++

$L
LL,,LLŢ&<LLL
L"!L OjLLLLL$$GL'=LL#!L OjLLLL 	/KL&LL%LLLLLL
&L!LLLLLL++LLLL >LL
"L!L#L+$L-LL! %WL(L<L#7L#7LLLL#)L!L+L#)LLLLL7L
*(>L!6LLLL!!L""L"(>(>*	AL
";LL 5LLLLLDLEL"8L!6LLLL 
	DL	LA2L-L	 <L
9L .LL2L DLLLLLLLLL +AL L"")1L L,,LL &L L ¤¤ "L CCL+LL ,,L%5`LLLLLLLLLL)L%*LLL&&LL 7L	5L(ILLLL +NL3LL
>L	(>LLL+L	(>*	AL*LLLL+1LLLLL''L**L**LLL'LLLLLLLL 	/LL
!L''L**L**L	.LL
1LLLLL 
B"8L
6LLLL 
7L
4L<L&LLL*(>(>*	AL
7LL
5LLLLLLLL 
FLLELL (
S#L--L	(7LL$*LL 

J3L BCL-L	+	LĎiL""L	+LLLL LL L      Ň  ćŚ  