MimFlow.mesa
Copyright Ó 1985, 1986, 1987, 1988, 1989, 1990, 1991 by Xerox Corporation. All rights reserved.
Sweet, May 31, 1986 9:49:07 pm PDT
Satterthwaite, April 17, 1986 11:29:24 am PST
Russ Atkinson (RRA) April 26, 1991 4:07 pm PDT
DIRECTORY
Alloc USING [Base, Notifier],
Convert USING [RopeFromCard, RopeFromInt],
ConvertUnsafe USING [ToRope],
IntCodeDefs USING [ArithClass, ArithPrecision, Comparator, FieldLocation, GlobalVarLocation, Label, LinkLocation, LocalVarLocation, MesaSelector, Node, NodeList, NodeRep, OperRep, Var],
LiteralOps USING [IsShort, StringValue, Value],
Literals USING [LitClass],
MimCode USING [BitCount, catchcount, CodeList, CodeNotImplemented, falseNode, LabelInfo, labelInfoNull, LabelInfoRecord, NamedLabelInfo, RegisterNotifier, trueNode, z],
MimData USING [switches],
MimosaLog USING [WarningNode],
MimP5 USING [Exp, MakeGlobal, StatementTree, TypeRel],
MimP5S USING [],
MimP5Stuff USING [Accumulate, GetCard, IsCard],
MimP5U USING [Address, AddrExtend, AllocLabel, ApplyOp, ArithClassForTree, ArithClassForType, ArithOp, ArithOpForTree, BinaryArithOp, BitsForType, BoolTest, CompareOp, ConvertOpNode, EqualTest, Extend, ForceBool, InsertLabel, IsZero, Jump, LabelAddress, MakeArgList, MakeBlock, MakeConstCard, MakeConstInt, MakeGoTo, MakeNodeList, MakeNodeList2, MakeTemp, MaybeBlock, MesaOpNode, MoreCode, NewCodeList, NodeAnd, NodeIf, NodeOr, OperandType, RealExtend, SignExtend, TakeField, ZeroExtend],
Rope USING [Concat, Match, ROPE, Substr],
SymbolOps USING [DecodeCard, DecodeInt, ToType],
Symbols USING [HTIndex, Type, UNSPEC],
Target: TYPE MachineParms USING [bitsPerReal, bitsPerWord],
Tree USING [Base, Index, Link, Node, NodeName, Null, Scan, treeType],
TreeOps USING [GetHash, GetNode, GetTag, ScanList];
MimFlow: PROGRAM
IMPORTS Convert, ConvertUnsafe, LiteralOps, MimCode, MimData, MimosaLog, MimP5Stuff, MimP5U, MimP5, Rope, SymbolOps, TreeOps
EXPORTS MimP5, MimP5S = {
OPEN MimCode, IntCodeDefs, Rope;
bitsPerBool: NAT = 1;
bitsPerWord: NAT = Target.bitsPerWord;
imported definitions
Comparator: TYPE = IntCodeDefs.Comparator;
HTIndex: TYPE = Symbols.HTIndex;
NodePtr: TYPE = LONG POINTER TO Tree.Node;
NodeName: TYPE = Tree.NodeName;
Type: TYPE = Symbols.Type;
labelStack: LabelInfo ¬ labelInfoNull;
UndeclaredLabel: SIGNAL [HTIndex] = CODE;
BogusJump: SIGNAL = CODE;
CompForNodeName: PACKED ARRAY NodeName[relE..relLE] OF Comparator ¬ [
relE: eq, relN: ne, relL: lt, relGE: ge, relG: gt, relLE: le];
NotNodeName: PACKED ARRAY NodeName[relE..notin] OF NodeName[relE..notin] ¬ [
relE: relN, relN: relE, relL: relGE, relGE: relL, relG: relLE, relLE: relG, in: notin, notin: in];
procedures
FlowExp: PUBLIC PROC [node: Tree.Index] RETURNS [l: Node] = {
generates code for a flow expression
tp: NodePtr = @tb[node];
Remember to extract all fields before calling anything that could cause relocation!
name: Tree.NodeName ¬ tp.name;
SELECT name FROM
ifx => l ¬ IfExp[tp.son[1], tp.son[2], tp.son[3]];
or => {
t1: Tree.Link = tp.son[1];
t2: Tree.Link = tp.son[2];
l ¬ MimP5U.NodeOr[MimP5.Exp[t1], MimP5.Exp[t2]];
};
and => {
t1: Tree.Link = tp.son[1];
t2: Tree.Link = tp.son[2];
l ¬ MimP5U.NodeAnd[MimP5.Exp[t1], MimP5.Exp[t2]];
};
not => l ¬ Not[tp.son[1]];
relE, relN, relL, relGE, relG, relLE, in, notin =>
l ¬ Rel[name, node, tp.son[1], tp.son[2]];
abs, uminus => {
generate code for ABS and unary minus
son1: Tree.Link = tp.son[1];
type: Type ¬ MimP5U.OperandType[son1];
ac: ArithClass ¬ MimP5U.ArithClassForType[type];
val: Node ¬ MimP5.Exp[son1];
bits: NAT ¬ MAX[NAT[ac.precision], NAT[val.bits], NAT[MimP5U.BitsForType[SymbolOps.ToType[tp.info]]]];
IF name = abs AND ac.kind = unsigned THEN RETURN [val];
IF bits MOD bitsPerWord # 0 THEN bits ¬ bits + (bitsPerWord-(bits MOD bitsPerWord));
ac.precision ¬ bits;
IF ac.kind # unsigned THEN
WITH val SELECT FROM
numLit: REF NodeRep.const.numLiteral => {
We may be able to process this literal right here!
contents: ROPE ¬ numLit.contents;
SELECT name FROM
abs => {
IF Rope.Match["-*", contents]
THEN contents ¬ Rope.Substr[contents, 1]
ELSE IF bits = val.bits THEN RETURN [val];
};
uminus => {
IF Rope.Match["-*", contents]
THEN contents ¬ Rope.Substr[contents, 1]
ELSE contents ¬ Rope.Concat["-", contents];
};
ENDCASE => ERROR;
RETURN [MimCode.z.NEW[NodeRep.const.numLiteral ¬ [
bits,
const[numLiteral[ac, contents]]]]];
};
ENDCASE;
IF bits # val.bits THEN val ¬ ArithExtend[val, bits, ac];
RETURN [MimP5U.ApplyOp[
MimP5U.ArithOp[IF name = abs THEN abs ELSE neg, ac],
MimP5U.MakeNodeList[val],
bits]];
};
float, shorten, lengthen => {
use a conversion operation to produce a new arithmetic result
{NOTE: we eventually want to handle looking deeper if this is a lengthen of a floating point literal}
son1: Tree.Link ¬ tp.son[1];
dstType: Type = SymbolOps.ToType[tp.info];
dstBits: INT = MimP5U.BitsForType[dstType];
WITH s: son1 SELECT TreeOps.GetTag[son1] FROM
subtree => {
stp: NodePtr = @tb[s.index];
IF stp.name = float THEN {
We can combine these
tp.son[1] ¬ son1 ¬ stp.son[1];
tp.name ¬ name ¬ float;
};
};
ENDCASE;
{
srcType: Type ¬ MimP5U.OperandType[son1];
n: Node ¬ MimP5.Exp[son1];
WITH s: son1 SELECT TreeOps.GetTag[son1] FROM
literal => IF name = float
AND LiteralOps.IsShort[s.index]
AND (dstBits = Target.bitsPerReal OR dstBits = Target.bitsPerReal*2) THEN {
class: Literals.LitClass;
val: Symbols.UNSPEC;
[class, val] ¬ LiteralOps.Value[s.index];
SELECT class FROM
unsigned => {
c: CARD = SymbolOps.DecodeCard[val];
RETURN [RealLiteralFromRope[
Rope.Concat[Convert.RopeFromCard[c], ".0"], dstType, dstBits]];
};
signed, either => {
i: INT = SymbolOps.DecodeInt[val];
RETURN [RealLiteralFromRope[
Rope.Concat[Convert.RopeFromInt[i], ".0"], dstType, dstBits]];
};
ENDCASE;
};
string =>
We got this puppy from the scanner!
SELECT name FROM
float => {
Hotcha!
string: LONG STRING = LiteralOps.StringValue[s.index];
rope: ROPE = ConvertUnsafe.ToRope[string];
RETURN [RealLiteralFromRope[rope, dstType, dstBits]];
};
ENDCASE => ERROR;
subtree => IF tb[s.index].name = cast THEN {
Somebody is trying to convert a LOOPHOLE
ac: ArithClass ¬ MimP5U.ArithClassForType[srcType];
IF ac.kind = signed AND ac.precision < n.bits THEN {
Somebody (most likely) did a LOOPHOLE to an INT16, which may not be properly sign extended. This is really a crock.
IF MimData.switches['y] THEN MimosaLog.WarningNode[notPortable, node];
};
};
ENDCASE;
l ¬ ArithConvert[n, dstType, srcType, name];
};
};
min, max => {
generates code for MIN[...] & MAX[...]
outerType: Type ¬ MimP5U.OperandType[ [subtree[node]] ];
op: Node ¬ MimP5U.ArithOpForTree[node, IF name = max THEN max ELSE min];
dstAc: ArithClass ¬ MimP5U.ArithClassForTree[node];
bits: BitCount ¬ dstAc.precision;
args: NodeList ¬ NIL;
tail: NodeList ¬ NIL;
eachSon: Tree.Scan = {
[t: Tree.Link]
type: Type = MimP5U.OperandType[t];
ac: ArithClass = MimP5U.ArithClassForType[type];
n: Node = ArithConvert[MimP5.Exp[t], outerType, type, lengthen];
new: NodeList ¬ MimP5U.MakeNodeList[
IF n.bits < bits THEN ArithExtend[n, bits, ac] ELSE n];
IF tail = NIL THEN args ¬ new ELSE tail.rest ¬ new;
tail ¬ new;
};
TreeOps.ScanList[tp.son[1], eachSon];
SELECT TRUE FROM
args = NIL, args.rest = NIL => ERROR;
Should have been handled in Pass4!
ENDCASE => l ¬ MimP5U.ApplyOp[op, args, bits];
};
istype => l ¬ MimP5.TypeRel[node];
signalinit =>
Anonymous signal or error initialization (see MimDriver.SignalForSei).
l ¬ MimP5U.Address[MimP5.MakeGlobal[bitsPerWord].v];
ENDCASE => SIGNAL MimCode.CodeNotImplemented;
};
Not: PROC [son1: Tree.Link] RETURNS [n: Node] = {
generate code for "NOT"
WITH e: son1 SELECT TreeOps.GetTag[son1] FROM
subtree => {
tp: NodePtr = @tb[e.index];
Remember to extract all fields before calling anything that could cause relocation!
name: Tree.NodeName = tp.name;
SELECT name FROM
relE, relN, relL, relGE, relG, relLE, in, notin =>
~ (X rel Y) ==> X ~rel Y
RETURN [Rel[NotNodeName[name], e.index, tp.son[1], tp.son[2]]];
not =>
~ ~ X ==> X
RETURN [MimP5.Exp[tp.son[1]]];
ifx =>
~ (IF Test THEN X ELSE Y) ==> IF Test THEN ~X ELSE ~Y
RETURN [IfExp[tp.son[1], tp.son[2], tp.son[3], TRUE]];
and, or => {
~ (X AND Y) ==> ~X OR ~Y
~ (X OR Y) ==> ~X AND ~Y
t1: Tree.Link ¬ tp.son[1];
t2: Tree.Link ¬ tp.son[2];
IF name = and
THEN RETURN [MimP5U.NodeOr[Not[t1], Not[t2]]]
ELSE RETURN [MimP5U.NodeAnd[Not[t1], Not[t2]]];
};
ENDCASE;
};
ENDCASE;
n ¬ MimP5.Exp[son1];
SELECT n FROM
MimCode.trueNode => RETURN [MimCode.falseNode];
MimCode.falseNode => RETURN [MimCode.trueNode];
ENDCASE;
RETURN [MimP5U.ForceBool[n, TRUE]];
};
Rel: PROC [name: NodeName, tn: Tree.Index, son1: Tree.Link, son2: Tree.Link]
RETURNS [Node] = {
e1: Node ¬ MimP5.Exp[son1];
type1: Type ¬ MimP5U.OperandType[son1];
ac1: ArithClass ¬ MimP5U.ArithClassForType[type1];
SELECT TRUE FROM
ac1.precision = 0 => {
e2: Node ¬ MimP5.Exp[son2];
type2: Type ¬ MimP5U.OperandType[son2];
bits: INT ¬ MIN[MimP5U.BitsForType[type1], MimP5U.BitsForType[type2]];
IF bits < e1.bits AND e1.bits > bitsPerWord THEN
e1 ¬ MimP5U.TakeField[e1, 0, bits] ;
IF bits < e2.bits AND e2.bits > bitsPerWord THEN
e2 ¬ MimP5U.TakeField[e2, 0, bits] ;
SELECT name FROM
relE => RETURN [MimP5U.EqualTest[e1, e2, FALSE]];
relN=> RETURN [MimP5U.EqualTest[e1, e2, TRUE]];
ENDCASE => ERROR;
};
ENDCASE => {
produces code for relationals
ac: ArithClass ¬ MimP5U.ArithClassForTree[tn];
MakeCompareOp: PROC
[sense: Comparator, n1, n2: Node, type2: Type] RETURNS [Node] = {
ac2: ArithClass ¬ MimP5U.ArithClassForType[type2];
bits: BitCount = MAX[n1.bits, n2.bits, ac.precision];
IF bits > n1.bits THEN n1 ¬ ArithExtend[n1, bits, ac1];
IF bits > n2.bits THEN {
IF ac2.kind = signed AND MimData.switches['z] THEN ERROR;
n2 ¬ ArithExtend[n2, bits, ac2];
};
ac.precision ¬ bits;
IF ac.kind = unsigned THEN SELECT TRUE FROM
MimP5U.IsZero[n2] =>
X >= 0 for all unsigned X
SELECT sense FROM
lt => RETURN [MimCode.falseNode];
ge => RETURN [MimCode.trueNode];
ENDCASE;
MimP5U.IsZero[n1] =>
0 <= X for all unsigned X
SELECT sense FROM
le => RETURN [MimCode.trueNode];
gt => RETURN [MimCode.falseNode];
ENDCASE;
ENDCASE;
SELECT sense FROM
eq, ne => IF bits = bitsPerWord THEN {
exp1, exp2: Node;
con1, con2: CARD;
[exp1, con1] ¬ SplitArith[n1];
[exp2, con2] ¬ SplitArith[n2];
{
We are comparing (exp1+con1) op (exp2+con2), so we can give a good shot at combining the constants to avoid the extra computation
IF con1 >= con2
THEN {con1 ¬ con1-con2; con2 ¬ 0}
ELSE {con2 ¬ con2-con1; con1 ¬ 0};
n1 ¬ MimP5Stuff.Accumulate[exp1, MimP5U.MakeConstCard[con1, bits]];
n2 ¬ MimP5Stuff.Accumulate[exp2, MimP5U.MakeConstCard[con2, bits]];
};
};
ENDCASE;
RETURN [MimP5U.ApplyOp[
oper: MimP5U.CompareOp[sense, ac],
args: MimP5U.MakeNodeList2[n1, n2],
bits: bitsPerBool]];
};
SELECT name FROM
relE, relN, relL, relGE, relG, relLE => {
type2: Type = MimP5U.OperandType[son2];
e2: Node = MimP5.Exp[son2];
RETURN [MakeCompareOp[CompForNodeName[name], e1, e2, type2]];
};
in, notin => {
WITH e: son2 SELECT TreeOps.GetTag[son2] FROM
subtree => {
cl: CodeList ¬ MimP5U.NewCodeList[];
var: Var ¬ NIL;
loSon: Tree.Link = tb[e.index].son[1];
loType: Type = MimP5U.OperandType[loSon];
loLim: Node ¬ MimP5.Exp[loSon];
hiSon: Tree.Link = tb[e.index].son[2];
hiType: Type = MimP5U.OperandType[hiSon];
hiLim: Node ¬ MimP5.Exp[hiSon];
intKind: Tree.NodeName ¬ tb[e.index].name;
n1, n2: Node ¬ NIL;
sense1, sense2: Comparator;
l: Node;
SELECT ac.kind FROM
unsigned =>
IF ac.precision <= NAT[BITS[CARD]]
AND MimP5Stuff.IsCard[loLim]
AND MimP5Stuff.IsCard[hiLim] THEN {
loCard: CARD ¬ MimP5Stuff.GetCard[loLim];
hiCard: CARD ¬ MimP5Stuff.GetCard[hiLim];
SELECT intKind FROM
intOO, intOC => {
IF loCard = CARD.LAST THEN GO TO duck;
loCard ¬ loCard + 1;
};
ENDCASE;
SELECT intKind FROM
intOO, intCO => {
IF hiCard = 0 THEN GO TO duck;
hiCard ¬ hiCard - 1;
};
ENDCASE;
IF hiCard < loCard THEN GO TO duck;
hiCard ¬ hiCard - loCard;
loLim ¬ MimP5U.MakeConstCard[loCard];
hiLim ¬ MimP5U.MakeConstCard[hiCard];
e1 ¬ MimP5U.BinaryArithOp[sub, ac, e1, loLim];
IF name = in THEN sense1 ¬ le ELSE sense1 ¬ gt;
l ¬ MakeCompareOp[sense1, e1, hiLim, hiType];
RETURN [MimP5U.MaybeBlock[cl, l]];
EXITS duck => {};
};
ENDCASE;
var ¬ SimpleVar[cl, e1];
IF name = in
THEN {
SELECT intKind FROM
intOO => {sense1 ¬ gt; sense2 ¬ lt};
intOC => {sense1 ¬ gt; sense2 ¬ le};
intCO => {sense1 ¬ ge; sense2 ¬ lt};
intCC => {sense1 ¬ ge; sense2 ¬ le};
ENDCASE => ERROR;
l ¬ MimP5U.NodeAnd[
MakeCompareOp[sense1, var, loLim, loType],
MakeCompareOp[sense2, var, hiLim, hiType]];
}
ELSE {
SELECT intKind FROM
intOO => {sense1 ¬ le; sense2 ¬ ge};
intOC => {sense1 ¬ le; sense2 ¬ gt};
intCO => {sense1 ¬ lt; sense2 ¬ ge};
intCC => {sense1 ¬ lt; sense2 ¬ gt};
ENDCASE => ERROR;
l ¬ MimP5U.NodeOr[
MakeCompareOp[sense1, var, loLim, loType],
MakeCompareOp[sense2, var, hiLim, hiType]];
};
RETURN [MimP5U.MaybeBlock[cl, l]];
};
ENDCASE => ERROR;
};
ENDCASE => ERROR;
};
};
IfExp: PROC [son1, son2, son3: Tree.Link, negate: BOOL ¬ FALSE] RETURNS [Node] = {
generates code for an IF expression
e1: Node ¬ NIL;
e2: Node ¬ NIL;
test: Node ¬ MimP5.Exp[son1];
SELECT MimP5U.BoolTest[test] FROM
true => RETURN [MimP5.Exp[IF negate THEN son3 ELSE son2]];
false => RETURN [MimP5.Exp[IF negate THEN son2 ELSE son3]];
ENDCASE;
IF negate
THEN {e1 ¬ Not[son2]; e2 ¬ Not[son3]}
ELSE {e1 ¬ MimP5.Exp[son2]; e2 ¬ MimP5.Exp[son3]};
IF e1 # NIL AND e2 # NIL THEN {
bits1: INT ¬ e1.bits;
bits2: INT ¬ e2.bits;
SELECT TRUE FROM
bits1 = bits2 => {};
bits1 < bits2 => e1 ¬ MimP5U.Extend[e1, bits2, MimP5U.OperandType[son2]];
bits2 < bits1 => e2 ¬ MimP5U.Extend[e2, bits1, MimP5U.OperandType[son3]];
ENDCASE;
};
RETURN [MimP5U.NodeIf[test, e1, e2]];
};
CatchMark: PUBLIC PROC [node: Tree.Index] RETURNS [Node] = {
process a CONTINUEd or RETRYed statement
cl: CodeList ¬ MimP5U.NewCodeList[];
retry: IntCodeDefs.Label = MimP5U.AllocLabel[];
continue: IntCodeDefs.Label = MimP5U.AllocLabel[];
l: LabelInfo ¬ MimCode.z.NEW[LabelInfoRecord.stmt ¬ [
thread: labelStack,
catchLevel: MimCode.catchcount,
body: stmt[retry: retry, continue: continue]]];
labelStack ¬ l;
MimP5U.InsertLabel[cl, retry];
MimP5U.MoreCode[cl, MimP5.StatementTree[tb[node].son[1]]];
MimP5U.InsertLabel[cl, continue];
IF labelStack # l THEN ERROR;
labelStack ¬ l.thread;
RETURN [MimP5U.MakeBlock[cl]];
};
LabelStmt: PUBLIC PROC [node: Tree.Index] RETURNS [Node] = {
process an exitable block
labelmark: LabelInfo = labelStack;
cl: CodeList = MimP5U.NewCodeList[];
son2: Tree.Link = tb[node].son[2];
IF son2 # Tree.Null THEN TreeOps.ScanList[son2, LabelCreate];
MimP5U.MoreCode[cl, MimP5.StatementTree[tb[node].son[1]]];
IF son2 # Tree.Null THEN {
elabel: IntCodeDefs.Label = MimP5U.AllocLabel[];
MimP5U.Jump[cl, elabel];
LabelList[cl, son2, elabel, labelmark];
MimP5U.InsertLabel[cl, elabel];
};
RETURN[MimP5U.MakeBlock[cl]];
};
GetLabelMark: PUBLIC PROC RETURNS [LabelInfo] = {
RETURN [labelStack];
};
ObscureLabels: PROC [mark: LabelInfo] RETURNS [first: LabelInfo] = {
first ¬ labelStack;
UNTIL labelStack.thread = mark DO
labelStack ¬ labelStack.thread;
ENDLOOP;
labelStack.thread ¬ labelInfoNull;
labelStack ¬ mark;
};
FindLabel: PROC [start: LabelInfo, hti: HTIndex] RETURNS [NamedLabelInfo] = {
FOR l: LabelInfo ¬ start, l.thread UNTIL l = labelInfoNull DO
WITH li: l SELECT FROM
named => IF li.hti = hti THEN RETURN [LOOPHOLE[l]];
ENDCASE;
ENDLOOP;
ERROR UndeclaredLabel[hti]
};
LabelList: PUBLIC PROC
[cl: CodeList, t: Tree.Link, elabel: IntCodeDefs.Label, mark: LabelInfo] = {
generates code for labels
toBind: LabelInfo = ObscureLabels[mark];
PutLabel: PROC [t: Tree.Link] = {
MimP5U.InsertLabel[cl, FindLabel[toBind, TreeOps.GetHash[t]].cci];
};
CLabelItem: PROC [t: Tree.Link] = {
generates code for a labelitem
node: Tree.Index = TreeOps.GetNode[t];
TreeOps.ScanList[tb[node].son[1], PutLabel];
MimP5U.MoreCode[cl, MimP5.StatementTree[tb[node].son[2]]];
MimP5U.Jump[cl, elabel];
};
TreeOps.ScanList[t, CLabelItem];
};
LabelCreate: PUBLIC PROC [t: Tree.Link] = {
sets up label cells for labels
node: Tree.Index = TreeOps.GetNode[t];
TreeOps.ScanList[tb[node].son[1], PushLabel];
};
PushLabel: PROC [t: Tree.Link] = {
stacks a label for an EXIT clause
hti: Symbols.HTIndex = TreeOps.GetHash[t];
l: LabelInfo = MimCode.z.NEW[LabelInfoRecord ¬ [
thread: labelStack,
catchLevel: MimCode.catchcount,
body: named[hti: hti, cci: MimP5U.AllocLabel[]]
]];
labelStack ¬ l;
};
MakeExitLabel: PUBLIC PROC RETURNS [exit, loop: IntCodeDefs.Label ¬ NIL] = {
sets up anonymous label for EXITs
exitL: IntCodeDefs.Label = MimP5U.AllocLabel[];
loopL: IntCodeDefs.Label = MimP5U.AllocLabel[];
l: LabelInfo = MimCode.z.NEW[LabelInfoRecord ¬ [
thread: labelStack,
catchLevel: MimCode.catchcount,
body: loop[exit: exitL, loop: loopL]]];
labelStack ¬ l;
RETURN [exitL, loopL];
};
Retry: PUBLIC PROC RETURNS [Node] = {
process RETRY statement
FOR l: LabelInfo ¬ labelStack, l.thread UNTIL l = labelInfoNull DO
WITH li: l SELECT FROM
stmt => RETURN [ExplicitJump[li.catchLevel, li.retry]];
ENDCASE;
ENDLOOP;
ERROR
};
Continue: PUBLIC PROC RETURNS [Node] = {
process CONTINUE statement
FOR l: LabelInfo ¬ labelStack, l.thread UNTIL l = labelInfoNull DO
WITH li: l SELECT FROM
stmt => RETURN[ExplicitJump[li.catchLevel, li.continue]];
ENDCASE;
ENDLOOP;
ERROR
};
Exit: PUBLIC PROC RETURNS [Node] = {
generate code for EXIT
FOR l: LabelInfo ¬ labelStack, l.thread UNTIL l = labelInfoNull DO
WITH li: l SELECT FROM
loop => RETURN[ExplicitJump[li.catchLevel, li.exit]];
ENDCASE;
ENDLOOP;
ERROR
};
Loop: PUBLIC PROC RETURNS [Node] = {
generate code for LOOP
FOR l: LabelInfo ¬ labelStack, l.thread UNTIL l = labelInfoNull DO
WITH li: l SELECT FROM
loop => RETURN[ExplicitJump[li.catchLevel, li.loop]];
ENDCASE;
ENDLOOP;
ERROR
};
GoTo: PUBLIC PROC [node: Tree.Index] RETURNS [Node] = {
generate code for GOTO
l: NamedLabelInfo = FindLabel[labelStack, TreeOps.GetHash[tb[node].son[1]]];
RETURN[ExplicitJump[l.catchLevel, l.cci]];
};
ExplicitJump: PROC [cc: CARDINAL, lc: IntCodeDefs.Label] RETURNS [Node] = {
process EXIT/REPEAT/GOTO/etc. statement
IF lc = NIL THEN SIGNAL BogusJump;
SELECT cc FROM
< MimCode.catchcount => {
An up-level GO TO
cl: CodeList ¬ MimP5U.NewCodeList[];
labelAddr: Node ¬ MimP5U.LabelAddress[lc];
levelConst: Node ¬ MimP5U.MakeConstInt[MimCode.catchcount-cc];
args: NodeList ¬ MimP5U.MakeArgList[labelAddr];
unwinder: Node = MimP5U.ApplyOp[oper: MimP5U.MesaOpNode[unwind], args: args];
MimP5U.MoreCode[cl, unwinder];
RETURN [MimP5U.MakeBlock[cl]];
};
> MimCode.catchcount => SIGNAL BogusJump;
This should have been caught earlier!
ENDCASE => {
No unwinding to perform
RETURN [MimP5U.MakeGoTo[lc]];
};
RETURN [NIL];
};
SimpleVar: PROC [cl: CodeList, exp: Node] RETURNS [var: Var ¬ NIL] = {
WITH exp SELECT FROM
expVar: Var => {
temp: Var ¬ expVar;
DO
next: Node ¬ NIL;
WITH temp.location SELECT FROM
loc: LocalVarLocation => RETURN [expVar];
glob: GlobalVarLocation => RETURN [expVar];
link: LinkLocation => RETURN [expVar];
field: FieldLocation => next ¬ field.base;
ENDCASE => EXIT;
WITH next SELECT FROM
nextVar: Var => IF (temp ¬ nextVar) = NIL THEN EXIT;
ENDCASE => EXIT;
ENDLOOP;
};
ENDCASE;
IF var = NIL THEN
var ¬ MimP5U.MakeTemp[cl, IF exp = NIL THEN 0 ELSE exp.bits, exp].var;
};
ArithExtend: PROC [n: Node, bits: BitCount, ac: ArithClass] RETURNS [Node] = {
SELECT TRUE FROM
bits = n.bits => {};
bits < n.bits => n ¬ MimP5U.TakeField[n, n.bits-bits, bits];
RRA: Careful, this assumes big-endian conventions
ac.kind = real => n ¬ MimP5U.RealExtend[n, bits];
ac.kind = signed => n ¬ MimP5U.SignExtend[n, bits];
ac.kind = address => n ¬ MimP5U.AddrExtend[n, bits];
ENDCASE => n ¬ MimP5U.ZeroExtend[n, bits, TRUE];
RETURN [n];
};
ArithConvert: PROC [n: Node, dstType: Type, srcType: Type, name: Tree.NodeName]
RETURNS [Node] = {
Arithmetic is always done in an integral # of words.
nBits: ArithPrecision = n.bits;
srcAc: ArithClass ¬ MimP5U.ArithClassForType[srcType];
srcBits: ArithPrecision ¬ srcAc.precision;
dstAc: ArithClass ¬ MimP5U.ArithClassForType[dstType];
dstBits: ArithPrecision ¬ dstAc.precision;
IF dstBits = 0 THEN dstBits ¬ dstAc.precision ¬ srcBits;
IF dstAc.kind = lastExtension THEN dstAc.kind ¬ srcAc.kind;
SELECT TRUE FROM
srcAc = dstAc => RETURN [n];
Same class => no conversion
(CARD[srcBits+bitsPerWord-1] / bitsPerWord)
# (CARD[dstBits+bitsPerWord-1] / bitsPerWord) => {};
Always force a conversion if the # of words is different
srcAc.kind = real OR dstAc.kind = real => {};
Always force a conversion if either is floating point
MimP5Stuff.IsCard[n] => RETURN [n];
The bounds checking has already been done statically
srcAc.kind = dstAc.kind AND nBits > dstBits => {
There is no need to convert, since the value is already long enough.
IF name # shorten THEN RETURN [n];
RETURN [ArithExtend[n, dstBits, dstAc]];
};
srcAc.kind = unsigned AND dstAc.kind = signed => {
There is no need to convert, since the unsigned quantity has been zero-extended, which guarantees compatibility with signed numbers.
IF nBits > dstBits OR (srcBits < dstBits AND nBits = dstBits) THEN RETURN [n];
};
ENDCASE;
An actual conversion is necessary.
SELECT TRUE FROM
dstAc.kind = signed AND srcAc.kind = unsigned
AND srcAc.precision < dstAc.precision => {
Special case to avoid bogus attempts at sign conversion
dstAc.kind ¬ unsigned;
dstAc.checked ¬ FALSE;
};
srcAc.kind # dstAc.kind, srcBits > dstBits =>
Force checking test
dstAc.checked ¬ TRUE;
ENDCASE;
srcAc.precision ¬ nBits;
n ¬ MimP5U.ApplyOp[
MimP5U.ConvertOpNode[from: srcAc, to: dstAc],
MimP5U.MakeNodeList[n],
dstBits];
RETURN [n];
};
RealLiteralFromRope: PROC [r: ROPE, dstType: Type, dstBits: INT] RETURNS [Node] = {
ac: ArithClass ¬ MimP5U.ArithClassForType[dstType];
RETURN [MimCode.z.NEW[NodeRep.const.numLiteral ¬ [
dstBits,
const[numLiteral[ac, r]]]]];
};
SplitArith: PUBLIC PROC [n: Node] RETURNS [exp: Node, const: CARD] = {
exp ¬ n;
const ¬ 0;
SELECT TRUE FROM
n = NIL, n.bits # bitsPerWord => {};
MimP5Stuff.IsCard[n] => {exp ¬ NIL; const ¬ MimP5Stuff.GetCard[n]};
ENDCASE =>
WITH n SELECT FROM
app: REF NodeRep.apply => {
WITH app.proc SELECT FROM
op: REF NodeRep.oper => WITH op.oper SELECT FROM
arith: REF OperRep.arith => SELECT arith.select FROM
add, sub => SELECT arith.class.kind FROM
signed, unsigned, address => IF NOT arith.class.checked THEN {
xExp, yExp: Node;
xCard, yCard: CARD;
[xExp, xCard] ¬ SplitArith[app.args.first];
[yExp, yCard] ¬ SplitArith[app.args.rest.first];
SELECT arith.select FROM
add => {
const ¬ xCard+yCard;
SELECT TRUE FROM
xExp = NIL => exp ¬ yExp;
yExp = NIL => exp ¬ xExp;
ENDCASE => {
exp ¬ MimP5U.ApplyOp[
app.proc,
MimP5U.MakeNodeList2[xExp, yExp],
bitsPerWord];
};
};
sub => {
min: CARD ¬ MIN[xCard, yCard];
IF yExp = NIL AND yCard = min THEN {
We have just cancelled out a constant
exp ¬ xExp;
const ¬ xCard-min;
RETURN;
};
xExp ¬ MimP5Stuff.Accumulate[xExp, MimP5U.MakeConstCard[xCard-min, bitsPerWord]];
yExp ¬ MimP5Stuff.Accumulate[yExp, MimP5U.MakeConstCard[yCard-min, bitsPerWord]];
exp ¬ MimP5U.ApplyOp[
app.proc,
MimP5U.MakeNodeList2[xExp, yExp],
bitsPerWord];
};
ENDCASE;
};
ENDCASE;
ENDCASE;
ENDCASE;
ENDCASE;
};
ENDCASE;
};
bases & notifier
tb: Tree.Base ¬ NIL;  -- tree base (local copy)
FlowNotify: PUBLIC Alloc.Notifier = {
called by allocator whenever table area is repacked
tb ¬ base[Tree.treeType];
};
MimCode.RegisterNotifier[FlowNotify];
}.