MimP5StuffImpl.mesa
Copyright Ó 1988, 1989, 1990, 1991 by Xerox Corporation. All rights reserved.
Russ Atkinson (RRA) February 4, 1991 5:34 pm PST
Eduardo Pelegri-Llopart December 22, 1988 10:09:09 am PST
Willie-s, September 24, 1991 4:51 pm PDT
DIRECTORY
Alloc,
Basics,
IntCodeDefs,
IntCodeStuff,
IntCodeUtils,
LiteralOps,
MimCode,
MimP5S,
MimP5Stuff,
MimP5U,
MimZones,
SymbolOps,
Symbols,
Target: TYPE MachineParms USING [bitsPerWord],
Tree,
TreeOps;
MimP5StuffImpl:
CEDAR
PROGRAM
IMPORTS Basics, IntCodeStuff, IntCodeUtils, LiteralOps, MimCode, MimP5S, MimP5U, MimZones, SymbolOps, TreeOps
EXPORTS MimP5Stuff
= BEGIN OPEN IntCodeDefs, MimCode;
Options
collapseConsBlocks: BOOL ¬ TRUE;
splitCrossWords: BOOL ¬ TRUE;
zeroSpanTrigger: NAT ¬ 4;
zeroSpanInline: NAT ¬ 4;
aggressiveCanonBlock: BOOL ¬ TRUE;
simplifyParts: BOOL ¬ TRUE;
elimUselessGoTos:
BOOL ¬
TRUE;
TRUE => call ElimUselessGoTos to remove useless go to nodes
FALSE => don't call ElimUselessGoTos
flattenLists:
BOOL ¬
TRUE;
TRUE => call FlattenList
FALSE => don't call FlattenList
Public procedures
BlockValSimplify:
PUBLIC PROC [cl: CodeList, node: Node, bn: BlockNode]
RETURNS [
BOOL] = {
Given a code list to generate into, we simplify an assignment or declaration with a block value that declares an unnecessary temporary. We return TRUE if the simplification was possible, and FALSE if it was not possible.
nodes: NodeList ¬ bn.nodes;
declVar: Var ¬ NIL;
declInit: Node ¬ NIL;
declRest: NodeList ¬ NIL;
lag: NodeList ¬ NIL;
var: Var ¬ NIL;
isAssign: BOOL ¬ FALSE;
WITH node
SELECT
FROM
assign: AssignNode => {var ¬ assign.lhs; isAssign ¬ TRUE};
decl: DeclNode => var ¬ decl.var;
ENDCASE => ERROR;
WHILE nodes #
NIL
DO
rest: NodeList ¬ nodes.rest;
first: Node ¬ nodes.first;
IF isAssign AND Intersects[first, var] THEN EXIT;
WITH first
SELECT
FROM
last: Var =>
IF rest #
NIL
OR last # declVar
THEN
EXIT
ELSE {
inner: IntCodeUtils.Visitor =
TRUSTED {
IF node = declVar THEN RETURN [var];
IntCodeUtils.MapNode[node, inner];
RETURN [node];
};
lag.rest ¬ NIL;
bn.bits ¬ 0;
WITH node
SELECT
FROM
assign: AssignNode =>
IF declInit = NIL THEN node ¬ NIL ELSE assign.rhs ¬ declInit;
decl: DeclNode => decl.init ¬ declInit;
ENDCASE => ERROR;
IntCodeUtils.MapNodeList[declRest, inner];
MimP5U.MoreCode[cl, node];
bn.nodes ¬ declRest;
MimP5U.MoreCode[cl, bn];
RETURN [TRUE];
};
decl:
REF NodeRep.decl =>
IF declVar =
NIL
THEN {
declInit ¬ decl.init;
declVar ¬ decl.var;
declRest ¬ rest;
IF declVar = NIL OR declVar.flags[named] THEN EXIT;
IF declVar.bits # var.bits THEN EXIT;
};
ENDCASE => {
IF declVar = NIL THEN EXIT;
};
lag ¬ nodes;
nodes ¬ rest;
ENDLOOP;
RETURN [FALSE];
};
MakeConsBlock:
PUBLIC
PROC [cl: CodeList, dest: Node, bits:
INT, assumeTemp:
BOOL]
RETURNS [Node] = {
Makes a block from the given code list, then prunes out excess assignments of zeros by clearing out the block first.
If assumeTemp = TRUE, then we can be more aggressive about combining assignments to dest, because we can assume that the value of dest is not used on the rhs of any assignments in the block.
new: Node ¬ MimP5U.MakeBlock[cl, bits];
WITH new
SELECT
FROM
block:
REF NodeRep.block => {
oldList: NodeList ¬ block.nodes;
inhibitZeroPrune: BOOL ¬ FALSE;
zerosAssigned: INT ¬ 0;
zeroBitsAssigned: INT ¬ 0;
totalAssigned: INT ¬ 0;
minOffset: INT ¬ INT.LAST;
maxOffset: INT ¬ 0;
changed: BOOL ¬ FALSE;
IF oldList #
NIL
THEN
WITH oldList.first
SELECT
FROM
decl: DeclNode =>
IF decl.var = dest
AND decl.init #
NIL
THEN {
This declaration should become an assignment in order to correctly collapse, so it is better to rewrite it here.
rest: NodeList ¬ oldList.rest;
IF rest #
NIL
THEN
WITH rest.first
SELECT
FROM
assign:
REF NodeRep.assign =>
WITH assign.lhs.location
SELECT
FROM
field:
REF LocationRep.field =>
IF field.base = dest
THEN {
ffLoc: IntCodeDefs.Location ¬ z.NEW[IntCodeDefs.LocationRep.field
¬ [field[start: 0, base: field.base]]];
ffVar: Var ¬ z.NEW[IntCodeDefs.VarRep
¬ [bits: bits, details: var[location: ffLoc]]];
newAssn: Node ¬ MimP5U.Assign[lhs: ffVar, rhs: decl.init];
decl.init ¬ NIL;
oldList.rest ¬ MimP5U.MakeNodeList[newAssn, rest];
};
ENDCASE;
ENDCASE;
};
ENDCASE;
FOR pass:
NAT
IN [1..2]
DO
lag: NodeList ¬ NIL;
each: NodeList ¬ oldList;
WHILE each #
NIL
DO
rest: NodeList ¬ each.rest;
WITH each.first
SELECT
FROM
assign:
REF NodeRep.assign => {
lhs: Var ¬ assign.lhs;
rhs: Node ¬ assign.rhs;
SELECT
TRUE
FROM
assumeTemp => {};
NOT IntCodeUtils.SideEffectFree[lhs,
FALSE] =>
inhibitZeroPrune ¬ TRUE;
NOT IntCodeUtils.SideEffectFree[rhs,
FALSE] =>
inhibitZeroPrune ¬ TRUE;
ENDCASE;
WITH lhs.location
SELECT
FROM
field:
REF LocationRep.field => {
lBits: INT = lhs.bits;
fStart: INT = field.start;
IF pass = 1
THEN {
IF dest # field.base THEN inhibitZeroPrune ¬ totalAssigned # 0;
IF lBits <= bpw
THEN {
IF splitCrossWords THEN [] ¬ SplitAssignment[each];
IF collapseConsBlocks
AND each.rest = rest
AND rest #
NIL
THEN {
WITH rest.first
SELECT
FROM
nextAssn: AssignNode =>
IF nextAssn.lhs.bits <= bpw
THEN {
IF splitCrossWords THEN [] ¬ SplitAssignment[rest];
IF CombineAssignments[each, assumeTemp]
THEN
GO TO redo;
};
ENDCASE;
};
};
IF rest #
NIL
THEN
WITH rest.first
SELECT
FROM
assn2:
REF NodeRep.assign =>
WITH assn2.lhs.location
SELECT
FROM
field2:
REF LocationRep.field =>
IF field2.start > (fStart+lBits)
THEN
Any gaps inhibit zero pruning
inhibitZeroPrune ¬ totalAssigned # 0;
ENDCASE => inhibitZeroPrune ¬ totalAssigned # 0;
ENDCASE;
totalAssigned ¬ totalAssigned + 1;
};
IF MimP5U.IsZero[rhs]
AND lhs.bits >= bpw
THEN
IF pass = 1
THEN {
Just count during the first pass
zerosAssigned ¬ zerosAssigned + 1;
zeroBitsAssigned ¬ zeroBitsAssigned + lBits;
minOffset ¬ MIN[minOffset, field.start];
maxOffset ¬ MAX[maxOffset, field.start+lBits];
}
ELSE {
This assignment can be removed!
IF lag = NIL THEN block.nodes ¬ rest ELSE lag.rest ¬ rest;
each ¬ rest;
GO TO redo;
};
};
ENDCASE => inhibitZeroPrune ¬ totalAssigned # 0;
EXITS redo => {changed ¬ TRUE; LOOP};
};
ENDCASE =>
IF
NOT assumeTemp
AND
NOT IntCodeUtils.SideEffectFree[each.first,
FALSE]
THEN
If something strange has happened to the record we are assigning, then we can't do the zero pruning, so be conservative!
inhibitZeroPrune ¬ TRUE;
lag ¬ each;
each ¬ rest;
ENDLOOP;
SELECT pass
FROM
1 => IF zerosAssigned+zerosAssigned < totalAssigned
OR zerosAssigned <= zeroSpanTrigger
OR inhibitZeroPrune THEN EXIT;
2 => {
start: INT = minOffset - OffsetInWord[minOffset];
maxMod: NAT = OffsetInWord[maxOffset];
lim: INT = maxOffset - maxMod;
zeroBits: INT = lim-start;
zeroConst: Node = MimP5U.MakeConstCard[0];
zeroWords: INT = zeroBits/bpw;
field: Var ¬ MimP5U.TakeFieldVar[dest, start, zeroBits];
nodes: NodeList ¬ NIL;
IF maxMod # 0
THEN {
Urp, a partially zero word at the tail
field: Var ¬ MimP5U.TakeFieldVar[dest, lim, maxMod];
field0: Node ¬ MimP5U.TakeField[zeroConst, bpw-maxMod, maxMod];
assign: Node ¬ MimP5U.Assign[field, field0];
nodes ¬ MimP5U.MakeNodeList[assign, nodes];
};
IF zeroWords <= zeroSpanInline
THEN {
Don't generate an all node, since C2C can't do very much with it
FOR i:
NAT
IN [0..
NAT[zeroWords])
DO
field: Var ¬ MimP5U.TakeFieldVar[dest, start+i*bpw, bpw];
assign: Node ¬ MimP5U.Assign[field, zeroConst];
nodes ¬ MimP5U.MakeNodeList[assign, nodes];
ENDLOOP;
}
ELSE {
allNode: Node ¬ MimP5U.ApplyOp[
oper: MimP5U.MesaOpNode[all],
args: MimP5U.MakeArgList2[MimP5U.MakeConstCard[0], MimP5U.MakeConstCard[zeroWords]],
bits: zeroBits];
assign: Node ¬ MimP5U.Assign[field, allNode];
nodes ¬ MimP5U.MakeNodeList[assign, nodes];
};
{
Find the right place to insert the zeros
lag: NodeList ¬ NIL;
nodesTail: NodeList ¬ IntCodeUtils.NodeListTail[nodes];
FOR each: NodeList ¬ block.nodes, each.rest
WHILE each #
NIL
DO
WITH each.first
SELECT
FROM
var: Var => EXIT;
assign: AssignNode => {
lhs: Var = assign.lhs;
IF lhs = dest THEN EXIT;
WITH lhs.location
SELECT
FROM
field: REF LocationRep.field => IF field.base = dest THEN EXIT;
ENDCASE;
};
apply: ApplyNode => EXIT;
ENDCASE;
lag ¬ each;
ENDLOOP;
IF lag =
NIL
THEN {
nodesTail.rest ¬ block.nodes;
block.nodes ¬ nodes;
}
ELSE {
nodesTail.rest ¬ lag.rest;
lag.rest ¬ nodes;
};
};
changed ¬ TRUE;
};
ENDCASE => ERROR;
ENDLOOP;
IF changed OR aggressiveCanonBlock THEN new ¬ CanonBlock[new];
};
ENDCASE;
RETURN [new];
};
Intersects:
PUBLIC PROC [node: Node, var: Var]
RETURNS [
BOOL] = {
Returns TRUE if the execution of node might depend on or affect the value of var. This routine is quite conservative.
DO
list: NodeList ¬ NIL;
WITH node
SELECT
FROM
bn: BlockNode => list ¬ bn.nodes;
sn: REF NodeRep.source => list ¬ sn.nodes;
dn:
REF NodeRep.decl => {
IF Intersects[dn.var, var] THEN RETURN [TRUE];
node ¬ dn.init;
LOOP;
};
label: REF NodeRep.label => {node ¬ label.label.node; LOOP};
comment: REF NodeRep.comment => RETURN [FALSE];
const: ConstNode => RETURN [FALSE];
an:
REF NodeRep.assign => {
IF Intersects[an.lhs, var] THEN RETURN [TRUE];
node ¬ an.rhs;
LOOP;
};
cn:
REF NodeRep.cond => {
FOR each: CaseList ¬ cn.cases, each.rest
WHILE each #
NIL
DO
FOR test: NodeList ¬ each.tests, test.rest
WHILE test #
NIL
DO
IF Intersects[test.first, var] THEN RETURN [TRUE];
ENDLOOP;
IF Intersects[each.body, var] THEN RETURN [TRUE];
ENDLOOP;
RETURN [FALSE];
};
apply:
REF NodeRep.apply => {
WITH apply.proc
SELECT
FROM
oper:
REF NodeRep.oper =>
WITH oper.oper
SELECT
FROM
code: REF OperRep.code => RETURN [TRUE];
escape: REF OperRep.escape => RETURN [TRUE];
ENDCASE => {};
ENDCASE => RETURN [TRUE];
list ¬ apply.args;
};
vn: Var => {
IF vn = var THEN RETURN [TRUE];
WITH vn.location
SELECT
FROM
g: GlobalVarLocation => RETURN [FALSE];
l: LocalVarLocation => RETURN [FALSE];
f: FieldLocation => {node ¬ f.base; LOOP};
c: CompositeLocation => list ¬ c.parts;
d: DummyLocation => RETURN [FALSE];
x: IndexedLocation =>
IF Intersects[x.index, var] THEN RETURN [TRUE] ELSE {node ¬ x.base; LOOP};
ENDCASE => RETURN [TRUE];
};
ENDCASE => IF node = NIL THEN RETURN [FALSE] ELSE RETURN [TRUE];
WHILE list #
NIL
DO
IF Intersects[list.first, var] THEN RETURN [TRUE];
list ¬ list.rest;
ENDLOOP;
RETURN [FALSE];
ENDLOOP;
};
IsSimpleVar:
PUBLIC
PROC [n: Node]
RETURNS [
BOOL] = {
Returns TRUE if the node is a simple variable (local variable, global variable, or field of a simple variable).
DO
WITH n
SELECT
FROM
v: Var =>
WITH v.location
SELECT
FROM
field: FieldLocation => n ¬ field.base;
local: LocalVarLocation => RETURN [TRUE];
global: GlobalVarLocation => RETURN [TRUE];
ENDCASE => RETURN [FALSE];
ENDCASE => RETURN [FALSE];
ENDLOOP;
};
CanonBlock:
PUBLIC
PROC [n: Node]
RETURNS [Node] = {
WITH n
SELECT
FROM
block: BlockNode => {
head: NodeList ¬ block.nodes;
IF flattenLists THEN head ¬ FlattenList[head];
block.nodes ¬ head;
IF head = NIL THEN RETURN [NIL];
IF aggressiveCanonBlock
THEN {
list: NodeList ¬ head;
WHILE list #
NIL
DO
rest: NodeList ¬ list.rest;
IF rest = NIL THEN EXIT;
WITH list.first
SELECT
FROM
assn1: AssignNode =>
WITH rest.first
SELECT
FROM
var2: Var =>
IF var2 = assn1.lhs
THEN
IF MimP5S.GetCategory[assn1.rhs] <= local
THEN
rest.first ¬ assn1.rhs;
assn2: AssignNode =>
SELECT
TRUE
FROM
assn1.lhs = assn2.rhs => {
rhs1: Node = assn1.rhs;
IF
NOT IsCard[rhs1]
THEN
WITH rhs1
SELECT
FROM
rv: Var =>
WITH rv.location
SELECT
FROM
loc: REF LocationRep.localVar => {};
ENDCASE => GO TO noTricks;
ENDCASE => GO TO noTricks;
assn2.rhs ¬ rhs1;
EXITS noTricks => {};
};
NOT IntCodeUtils.SideEffectFree[assn1.rhs, FALSE] => {};
NOT IntCodeUtils.SideEffectFree[assn2.rhs, FALSE] => {};
CombineAssignments[list, FALSE] => {list ¬ list.rest; LOOP};
ENDCASE;
ENDCASE;
ENDCASE;
list ¬ rest;
ENDLOOP;
};
SELECT
TRUE
FROM
head.rest =
NIL =>
WITH head.first
SELECT
FROM
dn: REF NodeRep.decl => {};
sn: REF NodeRep.source => {};
ENDCASE => RETURN [head.first];
ENDCASE => {
Now there are at least two nodes in the list, which may well lead to returning a block.
WITH head.first
SELECT
FROM
assign: AssignNode => {
rest: NodeList = head.rest;
IF IntCodeUtils.SimplyEqual[assign.lhs, rest.first]
AND rest.rest =
NIL
THEN {
rhs: Node = assign.rhs;
IF
NOT IsCard[rhs]
THEN
WITH rhs
SELECT
FROM
var: Var =>
WITH var.location
SELECT
FROM
loc: REF LocationRep.localVar => {};
ENDCASE => GO TO noTricks;
ENDCASE => GO TO noTricks;
A special case that sometimes comes up for assign expressions
rest.first ¬ rhs;
EXITS noTricks => {};
};
};
decl: DeclNode => {
temp: Var ¬ decl.var;
rest: NodeList ¬ head.rest;
tail: NodeList ¬ IntCodeUtils.NodeListTail[head];
IF
NOT temp.flags[named]
THEN {
WITH tail.first
SELECT
FROM
var: Var =>
IF var = temp
THEN {
This block declares a temporary that is then the result
FOR each: NodeList ¬ rest, each.rest
DO
first: Node ¬ each.first;
WITH first
SELECT
FROM
var: Var => {
IF decl.init = NIL THEN EXIT;
each.first ¬ decl.init;
each.rest ¬ NIL;
head ¬ rest;
EXIT;
};
assn: AssignNode =>
IF assn.lhs = var
THEN {
next: NodeList ¬ each.rest;
IF next = tail
THEN {
IF decl.init # NIL THEN EXIT;
IF IntCodeStuff.NodeContains[assn.rhs, var] THEN EXIT;
each.first ¬ assn.rhs;
each.rest ¬ NIL;
head ¬ rest;
EXIT;
};
};
ENDCASE;
IF IntCodeStuff.NodeContains[first, var] THEN EXIT;
ENDLOOP;
tail ¬ IntCodeUtils.NodeListTail[head];
IF head = tail THEN RETURN [tail.first];
};
ENDCASE;
IF head.first = decl
AND
IntCodeUtils.SideEffectFree[decl.init,
TRUE]
THEN {
lag: NodeList ¬ head;
Scan for non-trivial uses of this temporary variable
FOR each: NodeList ¬ head.rest, each.rest
WHILE each #
NIL
DO
first: Node ¬ each.first;
WITH first
SELECT
FROM
assn: AssignNode =>
IF assn.lhs = temp
THEN {
IF assn.bits # 0 THEN GO TO stop;
first ¬ assn.rhs;
};
ENDCASE;
IF IntCodeStuff.NodeContains[first, temp] THEN GO TO stop;
ENDLOOP;
At this point the declaration is not used, and has no effect, so we splice out all assignments to it.
DO
next: NodeList = lag.rest;
IF next = NIL THEN EXIT;
WITH next.first
SELECT
FROM
assn: AssignNode =>
IF assn.lhs = temp
THEN {
lag.rest ¬ next.rest;
LOOP;
};
ENDCASE;
lag ¬ next;
ENDLOOP;
head ¬ head.rest;
IF head = tail
THEN
RETURN [tail.first];
We have removed the block entirely!
EXITS stop => {};
};
};
};
ENDCASE;
IF head = NIL THEN RETURN [NIL];
n ¬ MimCode.z.NEW [NodeRep.block ¬ [bits: block.bits, details: block[head]]];
};
};
ENDCASE;
RETURN [n];
};
IsCard:
PUBLIC
PROC [node: Node]
RETURNS [
BOOL] = {
start: INT ¬ 0;
bits: INT ¬ IF node = NIL THEN 0 ELSE node.bits;
IF bits = 0 OR bits > bpw THEN RETURN [FALSE];
DO
IF MimP5U.IsZero[node] THEN RETURN [TRUE];
WITH node
SELECT
FROM
wc: REF NodeRep.const.word => RETURN [TRUE];
var: Var =>
WITH var.location
SELECT
FROM
field:
REF LocationRep.field => {
node ¬ field.base;
start ¬ start + field.start;
LOOP;
};
ENDCASE;
ENDCASE;
RETURN [FALSE];
ENDLOOP;
};
GetCard:
PUBLIC
PROC
[node: Node, start:
INT ¬ 0, bits:
NAT ¬ bpw]
RETURNS [
CARD] = {
IF bits = 0 OR bits > bpw THEN ERROR;
DO
c: CARD ¬ 0;
IF
NOT MimP5U.IsZero[node]
THEN {
lim: NAT ¬ OffsetInWord[start+bits];
WITH node
SELECT
FROM
wc:
REF NodeRep.const.word =>
c ¬ IntCodeUtils.WordToCard[wc.word];
var: Var =>
WITH var.location
SELECT
FROM
field:
REF LocationRep.field => {
vBits: NAT ¬ var.bits;
vLim: BitIndex ¬ OffsetInWord[field.start+vBits];
c ¬ GetCard[field.base, 0, bpw];
IF vLim # 0
THEN c ¬ Basics.
BITRSHIFT[c, bpw-vLim];
Get the value right-justified in a word
IF bits > vBits THEN bits ¬ vBits;
};
ENDCASE => ERROR;
ENDCASE => ERROR;
IF bits # bpw
THEN c ¬ Basics.
BITAND[c, Basics.
BITRSHIFT[
CARD.
LAST, bpw-bits]];
Mask off the bits of the value
IF lim # 0
THEN c ¬ Basics.
BITLSHIFT[c, bpw-lim];
Shift the value to the right position
};
RETURN [c];
ENDLOOP;
};
SubstTailGoTos:
PUBLIC
PROC [node: Node, label: Label, subst: Node]
RETURNS [Node] = {
Finds all tail go to nodes and substitutes the subst node for them.
tail: NodeList ¬ NIL;
WITH node
SELECT
FROM
block: BlockNode => tail ¬ block.nodes;
source: SourceNode => tail ¬ source.nodes;
cond: CondNode =>
FOR each: CaseList ¬ cond.cases, each.rest
WHILE each #
NIL
DO
body: Node = each.body;
IF body # NIL THEN each.body ¬ SubstTailGoTos[body, label, subst];
ENDLOOP;
goto:
REF NodeRep.goto =>
IF goto.dest = label THEN RETURN [subst] ELSE RETURN [node];
ENDCASE => RETURN [node];
IF tail #
NIL
THEN {
lag: NodeList ¬ NIL;
DO
rest: NodeList ¬ tail.rest;
IF rest =
NIL
THEN {
new: Node ¬ SubstTailGoTos[tail.first, label, subst];
tail.first ¬ new;
IF new =
NIL
THEN
IF lag = NIL THEN RETURN [NIL] ELSE lag.rest ¬ NIL;
RETURN [node];
};
lag ¬ tail;
tail ¬ rest;
ENDLOOP;
};
RETURN [node];
};
CombineAssignments:
PUBLIC
PROC [nl: NodeList, assumeTemp:
BOOL]
RETURNS [
BOOL] = {
IF nl #
NIL
THEN {
this: Node = nl.first;
rest: NodeList = nl.rest;
IF rest #
NIL
THEN {
base: Var ¬ NIL;
expAccum: Node ¬ NIL;
expShift: NAT ¬ 0;
constAccum: Node ¬ NIL;
thisAssn: AssignNode ¬ NIL;
thisStart: INT ¬ 0;
thisLen: INT ¬ 0;
list: NodeList ¬ rest;
changeCount: NAT ¬ 0;
WITH this
SELECT
FROM
assn: AssignNode => {
var: Var = assn.lhs;
thisAssn ¬ assn;
WITH var.location
SELECT
FROM
field:
REF LocationRep.field => {
thisLen ¬ var.bits;
thisStart ¬ field.start;
WITH field.base
SELECT
FROM
fv: Var => {
WITH fv.location
SELECT
FROM
deref:
REF LocationRep.deref =>
IF NOT IntCodeUtils.SideEffectFree[fv, FALSE] THEN GO TO noDice;
local: REF LocationRep.localVar => {};
global: REF LocationRep.globalVar => {};
ENDCASE => GO TO noDice;
base ¬ fv;
};
ENDCASE => GO TO noDice;
};
ENDCASE => GO TO noDice;
};
ENDCASE => GO TO noDice;
IF thisLen >= bpw OR thisLen <= 0 THEN GO TO noDice;
IF thisAssn.bits # 0 THEN GO TO noDice;
IF (OffsetInWord[thisStart] + thisLen) > bpw THEN GO TO noDice;
IF
NOT assumeTemp
THEN
IF NOT IntCodeUtils.SideEffectFree[thisAssn.rhs, FALSE] THEN GO TO noDice;
{
acc: Node ¬ ShiftLeft[thisAssn.rhs, 0, bpw];
IF IsCard[thisAssn.rhs] THEN constAccum ¬ acc ELSE expAccum ¬ acc;
};
DO
nextStart: INT ¬ 0;
nextLen: [0..bpw) ¬ 0;
nextAssn: AssignNode ¬ NIL;
WITH list.first
SELECT
FROM
assn: AssignNode => {
var: Var = assn.lhs;
varBits: INT = var.bits;
off: BitIndex ¬ 0;
IF assn.bits # 0 THEN EXIT;
WITH var.location
SELECT
FROM
field:
REF LocationRep.field => {
nextStart ¬ field.start;
off ¬ OffsetInWord[nextStart];
IF field.base # base THEN EXIT;
};
ENDCASE => EXIT;
IF off # 0
AND (off + varBits) > bpw
AND MimP5U.IsZero[assn.rhs]
THEN {
We can get on a word boundary here by splitting the zero assignment into two assignments.
leadBits: NAT = bpw-off;
tailBits: INT = varBits-leadBits;
newAssign: Node ¬ MimP5U.Assign[
lhs: MimP5U.TakeFieldVar[base, nextStart, leadBits],
rhs: MimP5U.MakeConstCard[0, leadBits]
];
assn.lhs ¬ MimP5U.TakeFieldVar[assn.lhs, leadBits, tailBits];
assn.rhs ¬ MimP5U.TakeField[assn.rhs, leadBits, tailBits];
list ¬ MimP5U.MakeNodeList[newAssign, list];
changeCount ¬ changeCount + 1;
LOOP;
};
IF varBits >= bpw OR varBits <= 0 THEN EXIT;
IF (varBits+thisLen) > bpw THEN EXIT;
nextAssn ¬ assn;
nextLen ¬ varBits;
IF off = 0 OR (off + nextLen) > bpw THEN EXIT;
IF thisStart+thisLen # nextStart THEN EXIT;
IF
NOT assumeTemp
THEN
IF Intersects[node: nextAssn.rhs, var: base] THEN GO TO noDice;
};
ENDCASE => EXIT;
At this point we know that we will accumulate
changeCount ¬ changeCount + 1;
IF constAccum #
NIL
THEN
constAccum ¬ ShiftLeft[constAccum, nextLen, bpw];
expShift ¬ expShift + nextLen;
IF
NOT MimP5U.IsZero[nextAssn.rhs]
THEN {
We have something to accumulate
acc: Node = ShiftLeft[nextAssn.rhs, 0, bpw];
IF IsCard[acc]
THEN constAccum ¬ Accumulate[constAccum, acc]
ELSE {
IF expAccum #
NIL
THEN
expAccum ¬ ShiftLeft[expAccum, expShift, bpw];
expAccum ¬ Accumulate[expAccum, acc];
expShift ¬ 0;
};
};
thisLen ¬ thisLen + nextLen;
list ¬ list.rest;
IF list = NIL THEN EXIT;
ENDLOOP;
IF changeCount = 0 THEN GO TO noDice;
IF expShift # 0
AND expAccum #
NIL
THEN
expAccum ¬ ShiftLeft[expAccum, expShift, bpw];
SELECT
TRUE
FROM
expAccum = NIL AND constAccum = NIL => GO TO noDice;
expAccum = NIL => expAccum ¬ constAccum;
constAccum = NIL => {};
ENDCASE => expAccum ¬ Accumulate[expAccum, constAccum];
Now we have the accumulated result to assign in expAccum
IF thisLen # bpw
THEN
expAccum ¬ MimP5U.TakeField[expAccum, bpw-thisLen, thisLen];
nl.first ¬ MimP5U.Assign[
lhs: MimP5U.TakeFieldVar[base, thisStart, thisLen],
rhs: expAccum];
nl.rest ¬ list;
RETURN [TRUE];
};
};
RETURN [FALSE];
};
SplitAssignment:
PUBLIC
PROC [nl: NodeList]
RETURNS [
BOOL] = {
WITH nl.first
SELECT
FROM
assign: AssignNode => {
lhs: Var = assign.lhs;
rhs: Node = assign.rhs;
IF lhs.bits # rhs.bits THEN ERROR;
WITH lhs.location
SELECT
FROM
field:
REF LocationRep.field => {
lBits: INT = lhs.bits;
IF lBits <= bpw
THEN {
bits: NAT = lBits;
fStart: INT = field.start;
mod: BitIndex = OffsetInWord[fStart];
IF bits+mod > bpw
THEN
This field crosses a word boundary. For now, only split constants.
IF IsCard[assign.rhs]
THEN {
dst: Node = field.base;
bits1: NAT ¬ bpw - mod;
bits2: NAT ¬ bits - bits1;
assn1: Node = MimP5U.Assign[
lhs: MimP5U.TakeFieldVar[dst, fStart, bits1],
rhs: MimP5U.TakeField[rhs, 0, bits1]];
assn2: Node = MimP5U.Assign[
lhs: MimP5U.TakeFieldVar[dst, fStart+bits1, bits2],
rhs: MimP5U.TakeField[rhs, bits1, bits2]];
nl.first ¬ assn1;
nl.rest ¬ MimP5U.MakeNodeList[assn2, nl.rest];
RETURN [TRUE];
};
};
};
ENDCASE;
};
ENDCASE;
RETURN [FALSE];
};
Vulnerable:
PUBLIC
UNSAFE
PROC [t1: Tree.Link, t2: Tree.Link, lhs:
BOOL]
RETURNS [
BOOL] =
UNCHECKED {
DO
WITH e1: t1
SELECT TreeOps.GetTag[t1]
FROM
subtree => {
tp1: Tree.NodePtr = @tb[e1.index];
n: NAT = tp1.nSons;
IF n = 0 THEN RETURN [FALSE];
SELECT tp1.name
FROM
mwconst, nil, clit, llit, nil => RETURN [FALSE];
cast, loophole => {t1 ¬ tp1.son[1]; LOOP};
item => {t1 ¬ tp1.son[2]; LOOP};
dollar => {t1 ¬ tp1.son[1]; LOOP};
uparrow => {t1 ¬ tp1.son[1]; lhs ¬ FALSE; LOOP};
ENDCASE;
lhs ¬ FALSE;
FOR i:
NAT
IN [1..n)
DO
IF Vulnerable[tp1.son[i], t2, FALSE] THEN RETURN [TRUE];
ENDLOOP;
t1 ¬ tp1.son[n];
LOOP;
};
symbol => {
sep: Symbols.ISEPointer = @seb[e1.index];
IF lhs OR sep.immutable OR sep.constant THEN RETURN [FALSE];
};
ENDCASE => RETURN [FALSE];
WITH e2: t2
SELECT TreeOps.GetTag[t2]
FROM
subtree => {
tp2: Tree.NodePtr = @tb[e2.index];
n: NAT = tp2.nSons;
SELECT tp2.name
FROM
mwconst, nil, clit, llit, nil, stringinit, first, last, atom, typecode, textlit, signalinit, procinit => RETURN [FALSE];
pad, chop, ord, val, cast, loophole, length, addr, pred, succ, length, base, float, lengthen, shorten, abs, uminus, not, istype, safen =>
{t2 ¬ tp2.son[1]; LOOP};
item => {t2 ¬ tp2.son[2]; LOOP};
errorx, syserrorx => RETURN [FALSE];
apply, callx, portcallx, signalx, startx, fork, joinx => RETURN [TRUE];
assign, assignx => IF TreeIntersect[t1, tp2.son[1]] THEN RETURN [TRUE];
ENDCASE;
IF n = 0 THEN RETURN [FALSE];
FOR i:
NAT
IN [1..n)
DO
IF Vulnerable[t1, tp2.son[i], lhs] THEN RETURN [TRUE];
ENDLOOP;
t2 ¬ tp2.son[n];
LOOP;
};
ENDCASE;
RETURN [FALSE];
ENDLOOP;
};
SideEffectFree:
PUBLIC
UNSAFE
PROC [t: Tree.Link]
RETURNS [
BOOL] =
UNCHECKED {
This proc is only valid if evaluated after normal Pass4 processing.
IF t = Tree.Null
THEN
RETURN [
FALSE];
Implicit operand, safer to assume side effects
WITH v: t
SELECT TreeOps.GetTag[t]
FROM
subtree => {
tp: Tree.NodePtr ¬ @tb[v.index];
n: NAT ¬ tp.nSons;
realCheck: BOOL ¬ FALSE;
SELECT tp.name
FROM
mwconst, nil, clit, llit, stringinit, first, last, atom, typecode, textlit, signalinit, procinit, none =>
RETURN [
TRUE];
Always SEF
ifx, or, and, not, all, cast => {
Son checking, no REAL checking
realCheck ¬ TRUE;
};
uminus, all, first, last, pred, succ, ord, val, relE, relN, relL, relGE, relG, relLE, plus, minus, times, power, lengthen, intCC, intOC, intCO, intOO => {
All of these can be done solely on the basis of son checking (inclufing REAL checking)
realCheck ¬ TRUE;
};
addr, index => {};
min, max => {
If the first son is a list then we must use it instead of ourselves.
list: Tree.Link = tp.son[1];
WITH l: list
SELECT TreeOps.GetTag[list]
FROM
subtree => IF tb[l.index].name = list THEN {tp ¬ @tb[l.index]; n ¬ tp.nSons};
ENDCASE;
realCheck ¬ TRUE;
};
div, mod => {
Check for divisor # 0
son2: Tree.Link = tp.son[2];
WITH s2: son2
SELECT TreeOps.GetTag[son2]
FROM
literal => {
IF NOT LiteralOps.IsShort[s2.index] THEN RETURN [FALSE];
IF SymbolOps.DecodeCard[LiteralOps.Value[s2.index].val] = 0
THEN
RETURN [FALSE];
};
ENDCASE => RETURN [FALSE];
realCheck ¬ TRUE;
};
dollar => n ¬ 1;
Only check first son
seqindex =>
IF tp.attr3
THEN
GO
TO mustEval;
Bounds check, so could have side-effect
in, notin => {
Don't try to perform OperandType on an interval
IF NOT SideEffectFree[tp.son[2]] THEN GO TO mustEval;
realCheck ¬ TRUE;
n ¬ 1;
};
ENDCASE => GO TO mustEval;
FOR i:
NAT
IN [1..n]
DO
son: Tree.Link ¬ tp.son[i];
IF NOT SideEffectFree[son] THEN GO TO mustEval;
IF realCheck
THEN {
sonType: Symbols.Type = MimP5U.OperandType[son];
sonAC: ArithClass = MimP5U.ArithClassForType[sonType];
IF sonAC.kind >= real THEN RETURN [FALSE];
};
ENDLOOP;
};
ENDCASE;
RETURN [TRUE];
EXITS mustEval => RETURN [FALSE];
};
SimplifyParts:
PUBLIC
PROC [parts: NodeList, offset:
INT ¬ 0]
RETURNS [NodeList] = {
Destructively modifies the parts list to try to combine parts that fit within a single word. Assumes the given target offset to keep from combining across word boundaries.
this: NodeList ¬ parts;
maySimplify: BOOL ¬ FALSE;
lag: NodeList ¬ NIL;
IF NOT simplifyParts THEN RETURN [parts];
First, flatten out any embedded composite nodes.
WHILE this #
NIL
DO
rest: NodeList ¬ this.rest;
WITH this.first
SELECT
FROM
tv: Var =>
WITH tv.location
SELECT
FROM
tvc:
REF LocationRep.composite => {
tvcp: NodeList ¬ tvc.parts;
IF tvcp #
NIL
THEN {
IF lag = NIL THEN parts ¬ tvcp ELSE lag.rest ¬ tvcp;
WHILE tvcp.rest # NIL DO tvcp ¬ tvcp.rest; ENDLOOP;
tvcp.rest ¬ rest;
tvc.parts ¬ NIL;
LOOP;
};
};
ENDCASE;
ENDCASE;
IF this.first = NIL THEN ERROR;
IF this.first.bits < bpw THEN maySimplify ¬ TRUE;
lag ¬ this;
this ¬ rest;
ENDLOOP;
IF maySimplify
THEN {
Now, combine adjacent elements that do not appear to be overlapping word boundaries.
this ¬ parts;
WHILE this #
NIL
DO
rest: NodeList ¬ this.rest;
SELECT
TRUE
FROM
rest = NIL => EXIT;
this.first.bits >= bpw, rest.first.bits >= bpw => {};
ENDCASE => {
accum: Node ¬ this.first;
sum: INT = accum.bits + rest.first.bits;
mod: NAT = offset MOD bpw;
IF mod+sum <= bpw
THEN {
lim: NAT ¬ mod;
pos: NAT ¬ mod;
temp: NodeList ¬ this;
end: NodeList ¬ this;
accumConst: Node ¬ NIL;
WHILE end #
NIL
DO
nextLim: INT ¬ lim+end.first.bits;
IF nextLim > bpw THEN EXIT;
lim ¬ nextLim;
end ¬ end.rest;
ENDLOOP;
accum ¬ NIL;
WHILE temp # end
DO
n: Node ¬ temp.first;
pos ¬ pos + n.bits;
n ¬ ShiftLeft[n, lim-pos, bpw];
IF IsCard[n]
THEN accumConst ¬ Accumulate[accumConst, n]
ELSE accum ¬ Accumulate[accum, n];
temp ¬ temp.rest;
ENDLOOP;
accum ¬ Accumulate[accum, accumConst];
pos ¬ lim-mod;
IF pos # bpw
THEN
accum ¬ MimP5U.TakeField[accum, bpw-pos, pos];
this.first ¬ accum;
this.rest ¬ end;
rest ¬ end;
};
};
offset ¬ offset + this.first.bits;
this ¬ rest;
ENDLOOP;
};
RETURN [parts];
};
Accumulate:
PUBLIC
PROC [x: Node, y: Node]
RETURNS [Node] = {
IF x = NIL THEN RETURN [y];
IF y = NIL THEN RETURN [x];
IF IsCard[x]
AND IsCard[y]
THEN
RETURN [MimP5U.MakeConstCard[GetCard[x] + GetCard[y]]];
IF x.bits < bpw THEN x ¬ LocalZeroExtend[x];
IF y.bits < bpw THEN y ¬ LocalZeroExtend[y];
IF MimP5U.IsZero[x] THEN RETURN [y];
IF MimP5U.IsZero[y] THEN RETURN [x];
RETURN [MimP5U.BinaryArithOp[op: add, ac: [unsigned, FALSE, bpw], n1: x, n2: y]];
};
ShiftLeft:
PUBLIC
PROC [n: Node, shift:
NAT, bits:
NAT ¬ 0]
RETURNS [Node] = {
Generates code to shift the given node left by the given number of bits, resulting in a node with the given number of bits. The node given must be less than or equal to bpw wide. If bits = 0, then the resulting number of bits is the same as the given node.
IF n = NIL THEN RETURN [NIL];
IF bits = 0 THEN bits ¬ n.bits;
SELECT
TRUE
FROM
shift = 0 => {};
shift >= bpw => RETURN [MimP5U.MakeConstCard[0, bits]];
IsCard[n] => {
c: CARD = Basics.BITLSHIFT[GetCard[n], shift];
RETURN [MimP5U.MakeConstCard[c, bits]];
};
ENDCASE => {
zn: Node = LocalZeroExtend[KeepRightBits[n, bits-shift]];
mult: Node = MimP5U.MakeConstCard[Basics.BITLSHIFT[1, shift]];
n ¬ MimP5U.BinaryArithOp[
op: mul, ac: [unsigned, FALSE, bpw],
n1: zn, n2: mult];
};
SELECT n.bits
FROM
> bits => n ¬ MimP5U.TakeField[n, n.bits-bits, bits];
< bits => n ¬ LocalZeroExtend[n, bits];
ENDCASE;
RETURN [n];
};
ShiftRight:
PUBLIC PROC [n: Node, shift:
NAT, bits:
NAT ¬ 0]
RETURNS [Node] =
TRUSTED {
Generates code to shift the given node right by the given number of bits, resulting in a node with the given number of bits. The node given must be less than or equal to bpw wide. If bits = 0, then the resulting number of bits is the same as the given node.
IF n = NIL THEN RETURN [NIL];
IF bits = 0 THEN bits ¬ n.bits;
SELECT
TRUE
FROM
shift = 0 => {};
shift >= bpw => RETURN [MimP5U.MakeConstCard[0, bits]];
IsCard[n] => {
c: CARD ¬ Basics.BITRSHIFT[GetCard[n], shift];
RETURN [MimP5U.MakeConstCard[c, bits]];
};
ENDCASE => {
zn: Node ¬ LocalZeroExtend[n];
mult: Node ¬ MimP5U.MakeConstCard[Basics.BITLSHIFT[1, shift]];
n ¬ MimP5U.BinaryArithOp[
op: div, ac: [unsigned, FALSE, bpw],
n1: zn, n2: mult];
};
SELECT n.bits
FROM
> bits => n ¬ MimP5U.TakeField[n, n.bits-bits, bits];
< bits => n ¬ LocalZeroExtend[n, bits];
ENDCASE;
RETURN [n];
};
Private procedures
ContainsLabel:
PROC [n: Node, list: NodeList, object: Label]
RETURNS [
BOOL] = {
visitor: IntCodeUtils.LabelVisitor = {
[label: IntCodeDefs.Label, node: IntCodeDefs.Node, define: BOOL] RETURNS [IntCodeDefs.Label]
IF object = label THEN found ¬ TRUE;
RETURN [label];
};
found: BOOL ¬ FALSE;
IntCodeUtils.VisitLabels[n, visitor, TRUE, FALSE];
IF found THEN RETURN [TRUE];
WHILE list #
NIL
DO
IntCodeUtils.VisitLabels[list.first, visitor, TRUE, FALSE];
IF found THEN RETURN [TRUE];
list ¬ list.rest;
ENDLOOP;
RETURN [FALSE];
};
KeepRightBits:
PROC [n: Node, rightBits:
NAT]
RETURNS [Node] = {
When we are going to shift left we can ignore bits that get shifted off. This is a helper routine to peel off useless extensions and fields. We keep the # of bits on the right specified by rightBits.
nn: Node ¬ n;
DO
WITH nn
SELECT
FROM
app:
REF NodeRep.apply =>
WITH app.proc
SELECT
FROM
op:
REF NodeRep.oper =>
WITH op.oper
SELECT
FROM
cvt:
REF OperRep.convert =>
IF cvt.from.precision <= rightBits
THEN {
The extension adds no useful bits
nn ¬ app.args.first;
LOOP;
};
ENDCASE;
ENDCASE;
fv: Var =>
IF fv.bits >= rightBits
THEN
WITH fv.location
SELECT
FROM
ff: FieldLocation => {
bb: INT = ff.base.bits;
IF bb <= bpw
AND fv.bits+ff.start = bb
THEN {
Taking the field is completely unnecessary, since the high-order bits will get washed out anyway.
nn ¬ ff.base;
LOOP;
};
};
ENDCASE;
ENDCASE;
RETURN [nn];
ENDLOOP;
};
OffsetInWord:
PROC [offset:
CARD]
RETURNS [BitIndex] =
INLINE {
IF
NAT[
SIZE[BitIndex]] <
NAT[
SIZE[
CARD]]
THEN RETURN [Basics.LowHalf[offset] MOD bpw]
ELSE RETURN [offset MOD bpw];
};
ShiftLeftLocal:
PROC [expr: Node, dist: [0..bpw)]
RETURNS [Node] = {
IF expr.bits # bpw THEN expr ¬ LocalZeroExtend[expr];
IF dist # 0
THEN
expr ¬ MimP5U.BinaryArithOp[
mul, unsignedClass,
expr,
MimP5U.MakeConstCard[Basics.BITLSHIFT[1, dist]]];
RETURN [expr];
};
TreeIntersect:
UNSAFE
PROC [t1: Tree.Link, t2: Tree.Link]
RETURNS [
BOOL] =
UNCHECKED {
Returns TRUE if the variables denoted by t1 and t2 appear to intersect.
DO
WITH e1: t1
SELECT TreeOps.GetTag[t1]
FROM
subtree => {
tp1: Tree.NodePtr = @tb[e1.index];
n: NAT = tp1.nSons;
IF n = 0 THEN RETURN [FALSE];
FOR i:
NAT
IN [1..n)
DO
IF TreeIntersect[tp1.son[i], t2] THEN RETURN [TRUE];
ENDLOOP;
t1 ¬ tp1.son[n];
LOOP;
};
symbol => {
WITH e2: t2
SELECT TreeOps.GetTag[t2]
FROM
symbol => RETURN [e1.index = e2.index];
subtree => {
tp2: Tree.NodePtr = @tb[e2.index];
n: NAT = tp2.nSons;
IF n = 0 THEN RETURN [FALSE];
SELECT tp2.name
FROM
uparrow =>
RETURN [
TRUE];
Note, in the worst case assigning to dereference can affect anything.
dot => {
IF tp2.attr1
THEN
RETURN [
TRUE];
Note, in the worst case assigning to dereference can affect anything.
t2 ¬ tp2.son[1];
LOOP;
};
index, dindex, seqindex, reloc => {t2 ¬ tp2.son[1]; LOOP};
item => {t2 ¬ tp2.son[2]; LOOP};
ENDCASE;
IF n = 0 THEN RETURN [FALSE];
FOR i:
NAT
IN [1..n)
DO
IF TreeIntersect[t1, tp2.son[i]] THEN RETURN [TRUE];
ENDLOOP;
t2 ¬ tp2.son[n];
LOOP;
};
ENDCASE;
};
ENDCASE;
RETURN [FALSE];
ENDLOOP;
};
NeedsZeroInhibit:
PROC [n: Node]
RETURNS [
BOOL] = {
WITH n
SELECT
FROM
c: REF NodeRep.const => RETURN [FALSE];
v: Var =>
WITH v.location
SELECT
FROM
loc: REF LocationRep.localVar => RETURN [FALSE];
ENDCASE;
apply:
REF NodeRep.apply =>
IF apply.handler =
NIL
THEN {
FOR each: NodeList ¬ apply.args, each.rest
WHILE each #
NIL
DO
IF NeedsZeroInhibit[each.first] THEN RETURN [TRUE];
ENDLOOP;
WITH apply.proc
SELECT
FROM
op: REF NodeRep.oper => RETURN [FALSE];
mc: REF NodeRep.machineCode => RETURN [FALSE];
ENDCASE;
};
ENDCASE;
RETURN [TRUE];
};
FlattenList:
PROC [list: NodeList]
RETURNS [NodeList] = {
Removes NIL nodes
head: NodeList ¬ NIL;
tail: NodeList ¬ NIL;
src: NodeList ¬ list;
WHILE src #
NIL
DO
this: Node ¬ src.first;
rest: NodeList = src.rest;
redo: BOOL ¬ FALSE;
WITH this
SELECT
FROM
bbn: BlockNode => {
DO
bSrc: NodeList ¬ bbn.nodes;
IF bSrc = NIL THEN GO TO skip;
IF bSrc.first = NIL THEN {bbn.nodes ¬ bSrc.rest; LOOP};
WITH bSrc.first
SELECT
FROM
decl: DeclNode => {
bbn.nodes ¬ FlattenList[bSrc];
GO TO add;
};
source: SourceNode => {
bbn.nodes ¬ FlattenList[bSrc];
GO TO add;
};
ENDCASE;
src.first ¬ bSrc.first;
src.rest ¬ bSrc;
bbn.nodes ¬ bSrc.rest;
bSrc.rest ¬ rest;
bSrc.first ¬ bbn;
GO TO redo;
ENDLOOP;
EXITS
redo => LOOP;
add => {};
skip => {this ¬ NIL};
};
source: SourceNode =>
source.nodes ¬ FlattenList[source.nodes];
ENDCASE;
IF this #
NIL
THEN {
IF rest #
NIL
THEN
WITH rest.first
SELECT
FROM
labNode: LabelNode => this ¬ SubstTailGoTos[this, labNode.label,
NIL];
Any tail go to nodes are useless
ENDCASE;
IF this #
NIL
THEN {
src.first ¬ this;
src.rest ¬ NIL;
IF head = NIL THEN head ¬ src ELSE tail.rest ¬ src;
tail ¬ src;
};
};
src ¬ rest;
ENDLOOP;
RETURN [head];
};
LocalZeroExtend:
PROC [x: Node, bits:
INT ¬ bpw]
RETURNS [Node] = {
IF x #
NIL
AND bits = bpw
THEN
WITH x
SELECT
FROM
v: Var =>
WITH v.location
SELECT
FROM
fv:
REF LocationRep.field =>
IF fv.start # 0
AND fv.start + v.bits = bpw
THEN {
base: Node = fv.base;
IF base.bits = bpw
THEN {
max: CARD ¬ GuessRange[base];
IF Basics.
BITRSHIFT[max, v.bits] = 0
THEN {
We are extending something we did not have to take a field of to begin with, so just return the base!
IF IsCard[base] THEN RETURN [base];
RETURN [base];
};
};
};
ENDCASE;
ENDCASE;
RETURN [MimP5U.ZeroExtend[x, bits]];
};
GuessRange:
PROC [x: Node]
RETURNS [
CARD] = {
bits: INT = IF x = NIL THEN 0 ELSE x.bits;
guess: CARD ¬ CARD.LAST;
IF bits = 0 THEN RETURN [0];
IF IsCard[x] THEN RETURN [GetCard[x]];
IF bits > bitsPerWord THEN RETURN [guess];
IF bits < bitsPerWord THEN guess ¬ Basics.BITRSHIFT[guess, bitsPerWord-bits];
WITH x
SELECT
FROM
app:
REF NodeRep.apply =>
IF app.handler =
NIL
THEN
WITH app.proc
SELECT
FROM
operNode:
REF NodeRep.oper =>
WITH operNode.oper
SELECT
FROM
arith:
REF OperRep.arith =>
IF arith.class.kind = unsigned
THEN
SELECT arith.select
FROM
add, mul, div => {
left: Node = app.args.first;
right: Node = app.args.rest.first;
gL: CARD ¬ GuessRange[left];
gR: CARD ¬ GuessRange[right];
SELECT arith.select
FROM
add => {
sum: CARD = gL + gR;
IF sum >= gL AND sum >= gR AND sum < guess THEN guess ¬ sum;
};
mul =>
SELECT
TRUE
FROM
gL = 0 OR gR = 0 => guess ¬ 0;
guess / gL > gR
AND guess / gR > gL => guess ¬ gL*gR;
The product will not overflow, and is less than guess
ENDCASE;
div => {
IF IsCard[right]
THEN {
c: CARD ¬ GetCard[right];
IF c # 0 THEN {gL ¬ gL / c; gR ¬ 1};
};
IF gR # 0 AND gL < guess THEN guess ¬ gL;
};
ENDCASE;
};
ENDCASE;
cvt:
REF OperRep.convert =>
IF cvt.to.kind = unsigned
THEN
SELECT cvt.from.kind
FROM
signed => {
g: CARD = GuessRange[app.args.first];
guess ¬ guess / 2;
IF g < guess THEN guess ¬ g;
};
unsigned => {
g: CARD = GuessRange[app.args.first];
IF g < guess THEN guess ¬ g;
};
ENDCASE;
check:
REF OperRep.check => {
gX: CARD ¬ GuessRange[app.args.first];
IF check.class.kind = unsigned
THEN
SELECT check.sense
FROM
lt, le, eq => {
gY: CARD ¬ GuessRange[app.args.rest.first];
IF check.sense = lt AND gY # 0 THEN gY ¬ gY - 1;
IF gY < gX THEN gX ¬ gY;
};
ENDCASE;
IF gX < guess THEN guess ¬ gX;
};
ENDCASE;
ENDCASE;
ENDCASE;
RETURN [guess];
};
VulnerableNotify: Alloc.Notifier =
UNCHECKED {
called by allocator whenever table area is repacked
seb ¬ base[Symbols.seType];
tb ¬ base[Tree.treeType];
};
uselessGoToComment: Node = MimZones.permZone.NEW[NodeRep.comment
¬ [0, comment["eliminated useless go to node"]]];
tb: Tree.Base ¬ NIL; -- tree base (local copy)
seb: Symbols.Base ¬ NIL; -- semantic entry base (local copy)
TRUSTED {MimCode.RegisterNotifier[VulnerableNotify]};