DIRECTORY
Alloc USING [Base, Handle, Notifier],
Basics USING [BITLSHIFT, BITRSHIFT, LowHalf],
ConstArith USING [Add, Const, Div, FromCard, FromInt, Mod, Mul, Overflow, Sub, ToCard, ToInt],
IntCodeDefs USING [ApplyNode, ArithClass, ArithPrecision, ArithSelector, AssignNode, BytesConstNode, BlockNode, CaseList, CaseListRep, CedarSelector, Comparator, CompositeLocation, CondNode, ConstNode, DeclNode, DerefLocation, DummyLocation, FieldLocation, GlobalVarLocation, IndexedLocation, Label, LabelRep, LocalVarLocation, Location, LocationRep, LogicalId, MesaSelector, Node, NodeList, NodeListRep, NodeRep, nullVariableFlags, nullVariableId, Oper, OperNode, OperRep, Var, VariableFlags, VariableId, VarList, VarListRep, VarRep, Word, WordConstNode],
IntCodeStuff USING [GenApply, GenAssign, GenDecl, GenReturn],
IntCodeUtils USING [CardToWord, IntToWord, IsSimple, SideEffectFree, SimplicityLevel, WordToCard, WordToInt],
LiteralOps USING [DescriptorValue, IsShort, Value, ValueCard, ValueInt],
Literals USING [LitDescriptor, LTIndex],
MimCode USING [BitAddress, BitCount, caseType, CodeList, CodeListRep, curctxlvl, falseNode, fileLoc, Info, nC0, nC1, RegisterNotifier, tempcontext, trueNode, VLoc, xtracting, xtractsei, z],
MimData USING [ownSymbols, idCARDINAL, idINTEGER, idNAT, idREAL, idSTRING, wordAlignment, worstAlignment],
MimP5 USING [Clarify, Exp, Normalize, VarForSei, visibleContext],
MimP5U USING [BoolTestValue, RecOrFnProc],
MimP5S USING [EvalToTemp],
MimP5Stuff USING [BlockValSimplify, CanonBlock, GetCard, IsCard, IsSimpleVar, SideEffectFree],
MimZones USING [permZone],
RCMap,
RCMapOps USING [Acquire, Create, Destroy, GetSpan, RCMT],
Rope USING [ActionType, Map],
SourceMap USING [Cons],
SymbolOps USING [BitsForRange, Cardinality, CtxEntries, DecodeCard, DecodeInt, DecodeType, EncodeInt, FnField, MakeCtxSe, NewCtx, NextSe, own, PackedSize, RecField, ToBti, ToType, TypeRoot],
Symbols USING [Alignment, Base, BitAddress, BitCount, bodyType, BTIndex, BTNull, CSEIndex, CSENull, CTXIndex, CTXNull, ctxType, HTNull, ISEIndex, ISENull, lZ, nullType, RecordSEIndex, SERecord, seType, Type, typeANY, typeTYPE],
SymLiteralOps USING [TypeRef],
Table USING [Base],
Target: TYPE MachineParms USING [bitsPerAU, bitsPerLongWord, bitsPerProc, bitsPerReal, bitsPerRef, bitsPerWord, logBitsPerWord, PackedBitCount],
Tree USING [Base, Index, Info, Link, Map, Node, NodeName, Null, SubInfo, treeType],
TreeOps USING [GetTag, UpdateList],
UnsafeStorage USING [GetSystemUZone];
Cacheing & id generation
generatedLabel: LogicalId ¬ 0;
cachedCodeList:
ARRAY [0..cachedCodeListCount)
OF CodeList ¬
ALL[
NIL];
cachedCodeListCount: NAT = 4;
generatedVar: LogicalId ¬ 0;
CachedMesaOperRep: TYPE = ARRAY MesaSelector OF Node;
cachedMesaOper: REF CachedMesaOperRep ¬ NIL; -- *** reset if z goes away
boundCheckOp: Node ¬
NIL;
-- *** reset if z goes away
boundCheckOpBits: INT ¬ -1;
cachedCedarOper:
REF CachedCedarOperRep ¬
NIL;
-- *** reset if z goes away
CachedCedarOperRep: TYPE = ARRAY CedarSelector OF Node;
cachedArithOper:
REF CachedArithOperRep ¬
NIL;
-- *** reset if z goes away
CachedArithOperRep: TYPE = ARRAY ArithIndex OF ARRAY ArithSelector OF Node;
cachedExtendOp:
REF CachedExtendOpRep ¬
NIL;
-- clear if z goes away
CachedExtendOpRep: TYPE = ARRAY [0..bitsPerWord) OF OperNode;
cachedConvertOper:
REF CachedConvertOperRep ¬
NIL;
-- *** reset if z goes away
CachedConvertOperRep: TYPE = ARRAY ArithIndex OF ARRAY ArithIndex OF Node;
cachedCompareOper:
REF CachedCompareOperRep ¬
NIL;
-- *** reset if z goes away
CachedCompareOperRep: TYPE = ARRAY ArithIndex OF ARRAY Comparator OF Node;
cachedNotOper: OperNode ¬ NIL;
cachedEmptyReturn: Node ¬ NIL;
arithIndexSeq: REF ArithIndexSeq ¬ NIL;
ArithIndexSeq:
TYPE =
RECORD [
current: ArithIndex ¬ 0,
elements: SEQUENCE max: ArithIndex OF ArithClass];
ArithIndex: TYPE = [0..32);
reallySimple: IntCodeUtils.SimplicityLevel = [
derefs: 0, simpleOps: 0, noSignals:
TRUE, maxBits: 0];
ExtendCacheType:
TYPE =
RECORD [to, from: ArithPrecision, oper: OperNode];
lastAddrExtend: ExtendCacheType ¬ [0, 0, NIL];
lastRealExtend: ExtendCacheType ¬ [0, 0, NIL];
lastSignExtend: ExtendCacheType ¬ [0, 0, NIL];
CgenUtilInit:
PUBLIC
UNSAFE PROC [ownTable: Alloc.Handle] =
UNCHECKED {
table ¬ ownTable;
MimCode.tempcontext ¬ SymbolOps.NewCtx[Symbols.lZ];
MimCode.fileLoc ¬ SourceMap.Cons[0];
generatedLabel ¬ 100000;
z.FREE[@cachedArithOper];
z.FREE[@boundCheckOp];
z.FREE[@cachedCedarOper];
z.FREE[@cachedExtendOp];
z.FREE[@cachedConvertOper];
generatedVar ¬ 200000;
cachedCodeList ¬ ALL[NIL];
z.FREE[@cachedMesaOper];
z.FREE[@lastAddrExtend.oper];
z.FREE[@lastRealExtend.oper];
z.FREE[@lastSignExtend.oper];
IF rcmt # NIL THEN rcmt ¬ RCMapOps.Destroy[rcmt];
rcmt ¬ RCMapOps.Create[
zone: UnsafeStorage.GetSystemUZone[],
expansionOK: TRUE];
z.FREE[@cachedEmptyReturn];
};
procedures
Address:
PUBLIC
PROC [node: Node]
RETURNS [Node] = {
RRA: the initial code is to try to force addresses onto word boundaries. Some of the confusion that can arise from right-justification is that a field may be appear to be a full word in one part of the compiler yet be a subword that is right-justified in a word in another part of the compiler.
WITH node
SELECT
FROM
var: Var =>
WITH var.location
SELECT
FROM
fv:
REF LocationRep.field => {
WITH fv.base
SELECT
FROM
baseVar: Var =>
WITH baseVar.location
SELECT
FROM
dv:
REF LocationRep.deref => {
start: INT = fv.start;
mod: NAT = start MOD bitsPerWord;
IF start < bitsPerWord
THEN
RETURN [dv.addr];
A shortcut when the address is in the first word
IF mod # 0
THEN
force the start onto a word boundary
node ¬ TakeField[baseVar, start - mod, var.bits+mod];
};
ENDCASE;
ENDCASE;
};
ENDCASE;
ENDCASE;
RETURN [ApplyOp[MesaOpNode[addr], MakeNodeList[node], bitsPerPtr]];
};
AddrExtend:
PUBLIC
PROC [n: Node, to: BitCount ¬ bitsPerWord]
RETURNS [Node] = {
IF n #
NIL
THEN {
from: INT ¬ n.bits;
IF from < to
THEN {
ext: OperNode ¬ lastAddrExtend.oper;
IF ext =
NIL
OR from # lastAddrExtend.from
OR to # lastAddrExtend.to
THEN {
lastAddrExtend.to ¬ to;
lastAddrExtend.from ¬ from;
ext ¬ lastAddrExtend.oper ¬
RawConvertOp[
srcAc: [kind: address, checked: FALSE, precision: n.bits],
dstAc: [kind: address, checked: FALSE, precision: to]];
};
RETURN [ApplyOp[oper: ext, args: MakeNodeList[n], bits: to]];
};
};
RETURN [n];
};
AdjustLoc:
PUBLIC
UNSAFE
PROC
[vl: VLoc, rSei: Symbols.RecordSEIndex, fSei: Symbols.ISEIndex, tBits: BitCount]
RETURNS [VLoc] =
UNCHECKED {
length: BitCount = seb[rSei].length;
IF length < bitsPerWord
THEN {
delta: BitCount ¬ tBits - length;
IF delta # 0
THEN {
first: BOOL = (SymbolOps.DecodeCard[seb[fSei].idValue] = 0);
IF first THEN vl.size ¬ vl.size + delta ELSE vl.disp ¬ vl.disp + delta;
};
};
RETURN [vl]
};
AlignmentFromTree:
PUBLIC
UNSAFE
PROC [t: Tree.Link, needsDeref:
BOOL]
RETURNS [Symbols.Alignment] =
UNCHECKED {
type: Type = OperandType[t];
RETURN [AlignmentFromType[type, needsDeref]];
};
AlignmentFromType:
PUBLIC
UNSAFE
PROC [type: Type, needsDeref:
BOOL]
RETURNS [Symbols.Alignment] =
UNCHECKED {
wordy: BOOL ¬ needsDeref;
DO
sei: Symbols.CSEIndex = MimP5.Clarify[type];
sep: LONG POINTER TO Symbols.SERecord.cons = @seb[sei];
align: Symbols.Alignment ¬ sep.align;
IF needsDeref
THEN
WITH se: sep
SELECT
FROM
arraydesc => {
needsDeref ¬ FALSE;
type ¬ se.describedType;
LOOP;
};
relative => {
needsDeref ¬ FALSE;
type ¬ se.resultType;
LOOP;
};
ref => {
IF se.counted THEN RETURN [MimData.worstAlignment];
needsDeref ¬ FALSE;
type ¬ se.refType;
LOOP;
};
zone =>
RETURN [MimData.worstAlignment];
ENDCASE;
WITH se: sep
SELECT
FROM
record => IF se.machineDep THEN wordy ¬ FALSE;
union => IF se.machineDep THEN wordy ¬ FALSE;
sequence => IF se.machineDep THEN wordy ¬ FALSE;
ENDCASE;
IF wordy
THEN
We need to make this at least word-aligned
align ¬ VAL[MAX[align.ORD, MimData.wordAlignment.ORD]];
RETURN [align];
ENDLOOP;
};
AllocLabel:
PUBLIC
PROC [id: LogicalId]
RETURNS [Label] = {
IF id = LAST[LogicalId] THEN {id ¬ generatedLabel; generatedLabel ¬ generatedLabel + 1};
RETURN [z.NEW [LabelRep ¬
[id: id, node: NIL, backTarget: FALSE, jumpedTo: FALSE, used: FALSE]]];
};
AppendNodeList:
PUBLIC
PROC [cl: CodeList, nodes: NodeList] = {
Destructive appending of the node list
IF nodes #
NIL
THEN {
tail: NodeList ¬ cl.tail;
IF tail = NIL THEN cl.head ¬ nodes ELSE tail.rest ¬ nodes;
DO
next: NodeList ¬ nodes.rest;
IF next = NIL THEN EXIT;
nodes ¬ next;
ENDLOOP;
cl.tail ¬ nodes;
};
};
ApplyOp:
PUBLIC
PROC [oper: Node, args: NodeList, bits: BitCount ¬ 0]
RETURNS [Node] = {
first: Node ¬ IF args = NIL THEN NIL ELSE args.first;
second: Node ¬ IF args = NIL OR args.rest = NIL THEN NIL ELSE args.rest.first;
case: NAT ¬ 0;
SELECT oper.bits
FROM
0, Target.bitsPerProc => {};
ENDCASE => SIGNAL CantHappen;
WITH oper
SELECT
FROM
op:
REF NodeRep.oper =>
WITH op.oper
SELECT
FROM
cvt:
REF OperRep.convert =>
{
srcAc: ArithClass ¬ cvt.from;
dstAc: ArithClass ¬ cvt.to;
srcBits: NAT = srcAc.precision;
dstBits: NAT = dstAc.precision;
IF srcBits = 0 OR dstBits = 0 THEN SIGNAL CantHappen;
IF dstBits = bitsPerWord
AND srcBits < dstBits
THEN
In cases where we are taking a field of a bounds-checked quantity and extending the result, we can use the results of the bounds check if they are already of the right size
WITH first
SELECT
FROM
fv: Var =>
WITH fv.location
SELECT
FROM
ff: FieldLocation =>
IF first.bits+ff.start = dstBits
THEN
WITH ff.base
SELECT
FROM
app: ApplyNode =>
IF app.proc = boundCheckOp
THEN {
aa: NodeList = app.args;
a1: Node ¬ aa.first;
a2: Node ¬ aa.rest.first;
IF a1.bits = dstBits
AND MimP5Stuff.IsCard[a2]
THEN {
c: CARD ¬ MimP5Stuff.GetCard[a2];
IF Basics.
BITRSHIFT[c, first.bits] = 0
THEN {
We know that app is properly bounded and sized
RETURN [app];
};
};
};
ENDCASE;
ENDCASE;
ENDCASE;
IF srcAc.kind
IN [signed..unsigned]
AND dstAc.kind
IN [signed..unsigned]
THEN
Try to collapse converts of converts
WITH first
SELECT
FROM
fApp:
REF NodeRep.apply =>
WITH fApp.proc
SELECT
FROM
fOp:
REF NodeRep.oper =>
WITH fOp.oper
SELECT
FROM
fCvt:
REF OperRep.convert =>
IF fCvt.from.precision < fCvt.to.precision
AND srcBits = fCvt.to.precision
THEN
SELECT fCvt.to.kind
FROM
srcAc.kind, unsigned =>{
srcAc ¬ fCvt.from;
RETURN [ApplyOp[
RawConvertOp[srcAc: srcAc, dstAc: dstAc],
fApp.args,
bits]];
};
ENDCASE;
ENDCASE;
ENDCASE;
ENDCASE;
SELECT
TRUE
FROM
srcAc = dstAc => RETURN [first];
bits # dstBits => case ¬ 1; -- should this happen?
dstBits < srcBits => case ¬ 2;
srcAc.kind = unsigned
AND dstAc.kind = unsigned =>
IF dstBits <= bitsPerWord
AND MimP5Stuff.IsCard[first]
THEN
RETURN [MakeConstCard[MimP5Stuff.GetCard[first], dstBits]];
dstAc.kind = real
AND (srcBits
MOD bitsPerWord) # 0 => {
nBits: NAT = srcBits + (bitsPerWord - (srcBits MOD bitsPerWord));
first ¬ IF srcAc.kind = signed
THEN SignExtend[first, nBits]
ELSE ZeroExtend[first, nBits];
cvt.from.precision ¬ nBits;
};
bits # bitsPerWord, srcBits # dstBits => case ¬ 3;
dstAc.kind = signed
AND srcAc.kind = unsigned,
dstAc.kind = unsigned
AND srcAc.kind = signed =>
IF signCheckHack
THEN {
bound: CARD ¬ Basics.BITLSHIFT[1, first.bits-1];
RETURN [BoundsCheck[first, MakeConstCard[bound]]];
};
ENDCASE;
IF dstBits > srcBits
THEN
WITH first
SELECT
FROM
numLit:
REF NodeRep.const.numLiteral =>
This conversion is quite easy, since we can hand it off
RETURN [MimCode.z.
NEW[NodeRep.const.numLiteral ¬ [
dstBits,
const[numLiteral[dstAc, numLit.contents]]]]];
ENDCASE;
};
cmp:
REF OperRep.compare => {
ac: ArithClass = cmp.class;
SELECT
TRUE
FROM
first = NIL, second = NIL => SIGNAL CantHappen;
ac.precision # first.bits, ac.precision # second.bits, first.bits # second.bits => SIGNAL CantHappen;
ac.precision > bitsPerWord
AND ac.kind # real =>
Hack to make some equality testing faster
SELECT cmp.sense
FROM
eq => oper ¬ MesaOpNode[equal, ac.precision];
ne => oper ¬ MesaOpNode[notEqual, ac.precision];
ENDCASE;
ENDCASE;
};
ENDCASE;
ENDCASE;
RETURN [IntCodeStuff.GenApply[oper, args, bits]];
};
ArithOp:
PUBLIC PROC [op: ArithSelector, ac: ArithClass]
RETURNS [l: Node] = {
oper: IntCodeDefs.Oper;
ax: ArithIndex;
SELECT op
FROM
add, sub => IF useUnsignedAddSub AND ac.kind = signed THEN ac.kind ¬ unsigned;
abs, neg => IF ac.kind = unsigned THEN ac.kind ¬ signed;
ENDCASE;
ax ¬ ArithClassToArithIndex[ac];
IF cachedArithOper =
NIL
THEN cachedArithOper ¬ z.NEW[CachedArithOperRep] -- all NIL from allocator
ELSE IF (l ¬ cachedArithOper[ax][op]) # NIL THEN RETURN;
oper ¬ z.NEW[OperRep.arith ¬ [arith[class: ac, select: op]]];
cachedArithOper[ax][op] ¬ l ¬ GenOper[oper];
};
ArithOpForTree:
PUBLIC UNSAFE
PROC
[node: Tree.Index, op: ArithSelector]
RETURNS [Node] =
UNCHECKED {
RETURN [ArithOp[op, ArithClassForTree[node]]];
};
arithSanity: ArithPrecision ¬ 3;
ArithClassForTree:
PUBLIC
UNSAFE
PROC
[node: Tree.Index]
RETURNS [ac: ArithClass] =
UNCHECKED {
precision: ArithPrecision ¬ tb[node].subInfo;
IF precision NOT IN [0..arithSanity] THEN ERROR;
IF precision = Tree.SubInfo.LAST THEN precision ¬ 0 ELSE precision ¬ precision + 1;
ac ¬ [signed, FALSE, 0];
SELECT
TRUE
FROM
tb[node].attr1 => {
ac.kind ¬ real;
ac.precision ¬ precision * Target.bitsPerReal;
ac.checked ¬ TRUE;
};
tb[node].attr2 => {
ac.kind ¬ address;
ac.precision ¬ precision * Target.bitsPerWord;
ac.checked ¬ FALSE;
};
tb[node].attr3 => {
ac.kind ¬ signed;
ac.precision ¬ precision * Target.bitsPerWord;
ac.checked ¬ FALSE;
};
ENDCASE => {
ac.kind ¬ unsigned;
ac.precision ¬ precision * Target.bitsPerWord;
ac.checked ¬ FALSE;
};
};
ArithClassForType:
PUBLIC
UNSAFE PROC
[type: Type]
RETURNS [ac: ArithClass] =
UNCHECKED {
bits: INT = BitsForType[type];
prec: ArithPrecision ¬ IF bits <= 2*bitsPerWord THEN bits ELSE 0;
ac ¬ [lastExtension, TRUE, prec];
DO
ut: CSEIndex = MimP5.Clarify[type];
WITH se: seb[ut]
SELECT
FROM
real => {ac.kind ¬ real; ac.checked ¬ TRUE};
signed => {ac.kind ¬ signed; ac.checked ¬ FALSE};
basic => {ac.kind ¬ unsigned; ac.checked ¬ FALSE};
unsigned => {ac.kind ¬ unsigned; ac.checked ¬ FALSE};
enumerated => {ac.kind ¬ unsigned; ac.checked ¬ FALSE};
ref => {ac.kind ¬ address; ac.checked ¬ FALSE};
relative => {type ¬ se.offsetType; LOOP};
subrange => {
IF se.biased
OR se.origin >= 0
THEN {
By convention, biased subranges are treated as unsigned. This is primarily for conversion purposes, rather than for arithmetic.
ac.kind ¬ unsigned;
ac.checked ¬ FALSE;
EXIT;
};
type ¬ se.rangeType;
LOOP;
};
record => {
May just be a silly little wrapper
IF se.hints.unifield
AND SymbolOps.CtxEntries[SymbolOps.own, se.fieldCtx] = 1
THEN {
type ¬ seb[ctxb[se.fieldCtx].seList].idType;
LOOP;
};
GO TO bogus;
};
ENDCASE =>
GO
TO bogus;
Non-arithmetic, determine precision later
EXIT;
ENDLOOP;
EXITS bogus => {ac.checked ¬ FALSE; ac.kind ¬ lastExtension};
};
Assign:
PUBLIC
PROC [lhs: Var, rhs: Node]
RETURNS [Node] = {
assign: AssignNode ¬ IntCodeStuff.GenAssign[lhs, rhs];
IF lhs # NIL AND rhs # NIL AND lhs.bits # rhs.bits THEN SIGNAL CantHappen;
WITH rhs
SELECT
FROM
bn: BlockNode =>
IF bn.nodes #
NIL
THEN {
WITH bn.nodes.first
SELECT
FROM
dn: DeclNode => {
cl: CodeList ¬ NewCodeList[];
IF MimP5Stuff.BlockValSimplify[cl, assign, bn] THEN RETURN [MakeBlock[cl, 0]];
FreeCodeList[cl];
};
ENDCASE;
};
ENDCASE;
RETURN [assign];
};
AssignRC:
PUBLIC
UNSAFE
PROC
[lhs: Var, rhs: Node, type: Type, init:
BOOL]
RETURNS [Node] =
UNCHECKED {
root: Type = MimP5.Clarify[SymbolOps.TypeRoot[SymbolOps.own, type]];
rcMap: RCMap.Index ¬ RCMapForType[type];
cl: CodeList ¬ NIL;
innerAssignFromMap:
UNSAFE
PROC
[lhs: Var, rhs: Node, rcMap: RCMap.Index] =
UNCHECKED {
IF init AND skipRCinit0 AND IsZero[rhs] THEN RETURN;
SELECT rcMap
FROM
RCMap.nullIndex => {
Not a counted assignment
MoreCode [cl, Assign[lhs, rhs]];
RETURN;
};
RCMap.controlLinkIndex => {
Not a counted assignment (for now)
MoreCode [cl, Assign[lhs, rhs]];
RETURN;
};
ENDCASE;
IF lhs.bits > bitsPerRef
THEN {
We may need temporaries
simpleLevel: IntCodeUtils.SimplicityLevel = [
derefs: 2, simpleOps: 1, noSignals: FALSE, maxBits: 0];
IF
NOT IntCodeUtils.IsSimple[lhs, simpleLevel]
THEN {
The left-hand side needs to be made into an address
addr: Node ¬ MakeTemp[cl, bitsPerRef, Address[lhs]].var;
lhs ¬ Deref[addr, lhs.bits, MimData.worstAlignment];
};
IF
NOT IntCodeUtils.IsSimple[rhs, simpleLevel]
THEN {
The right-hand side needs to be put into a temporary
rhs ¬ MakeTemp[cl, rhs.bits, rhs].var;
};
};
SELECT rcMap
FROM
RCMap.refIndex => {
This is a simple assignment
part: Node ¬ innerSimpleAssign[lhs, rhs, 0];
rem: INT ¬ lhs.bits - bitsPerRef;
MoreCode[cl, part];
SELECT rem
FROM
> 0 => MoreCode[cl, innerAssignPart[lhs, rhs, bitsPerRef, rem]];
< 0 => ERROR;
ENDCASE;
};
ENDCASE => {
base: RCMap.Base ¬ GetRCMapBase[];
cedarOp: Node ¬ CedarOpNode[IF init THEN complexAssignInit ELSE complexAssign];
addrRhs: Node ¬ NIL;
args: NodeList ¬ NIL;
bits: INT ¬ 0;
WITH rcm: base[rcMap]
SELECT
FROM
oneRef => {
This record has a single simple REF
offset:
INT ¬ rcm.offset * bitsPerWord;
Note: offset is word offset, see RCMapBuilderImpl
offsetPlus: INT ¬ offset + bitsPerRef;
rem: INT ¬ lhs.bits - offsetPlus;
IF offset > 0
THEN MoreCode[cl, innerAssignPart[lhs, rhs, 0, offset]];
There is a prefix part
MoreCode[cl, innerSimpleAssign[lhs, rhs, offset]];
Assign the single REF
IF rem > 0
THEN MoreCode[cl, innerAssignPart[lhs, rhs, offsetPlus, rem]];
Assign the remaining stuff
GO TO done;
};
simple => {
This record has a small number of simple REF's
offset: INT ¬ 0;
rem: INT ¬ lhs.bits;
refs: NAT = rcm.length;
IF refs <= 4
THEN
WITH rhs
SELECT
FROM
rVar: Var => {
This can be done piecewise
FOR index:
NAT
IN [0..refs)
DO
IF rcm.refs[index]
THEN MoreCode[cl, innerSimpleAssign[lhs, rhs, offset]]
ELSE MoreCode[cl, innerAssignPart[lhs, rhs, offset, bitsPerRef]];
offset ¬ offset + bitsPerWord;
Note: index is word offset, see RCMapBuilderImpl
rem ¬ rem - bitsPerWord;
ENDLOOP;
IF rem > 0
THEN
Assign the remaining stuff
MoreCode[cl, innerAssignPart[lhs, rhs, offset, rem]];
GO TO done;
};
ENDCASE;
};
sequence => {
This could be just the initialization of the common part
IF lhs.bits > rcm.fdLength.bitOffset
THEN
ERROR;
This must not happen! We do not yet support initialization for the sequence elements.
innerAssignFromMap[lhs, rhs, rcm.commonPart];
RETURN;
};
ENDCASE;
This is a complex assignment
WITH rhs
SELECT
FROM
rVar: Var =>
At this point we can take the address of the variable
addrRhs ¬ Address[rVar];
ENDCASE => {
Sigh, we need a temporary to hold the bits so we can make an address
rTemp: Var ¬ MakeTemp[cl, rhs.bits, rhs].var;
addrRhs ¬ Address[rTemp];
};
args ¬ MakeArgList2[NodeForType[root], MakeConstInt[rhs.bits]];
args ¬ MakeArgList[addrRhs, args];
args ¬ MakeArgList[Address[lhs], args];
MoreCode[cl, ApplyOp[cedarOp, args]];
EXITS done => {};
};
};
innerSimpleAssign:
PROC [lhs: Var, rhs: Node, offset:
INT]
RETURNS [Node] =
CHECKED {
cedarOp: Node ¬ CedarOpNode[IF init THEN simpleAssignInit ELSE simpleAssign];
IF init AND skipRCinit0 AND IsZero[rhs] THEN RETURN [NIL];
IF offset # 0
OR lhs.bits # bitsPerRef
THEN
lhs ¬ TakeFieldVar[lhs, offset, bitsPerRef];
IF offset # 0
OR rhs.bits # bitsPerRef
THEN
rhs ¬ TakeField[rhs, offset, bitsPerRef];
RETURN [ApplyOp[cedarOp, MakeArgList2[Address[lhs], rhs]]];
};
innerAssignPart:
PROC
[lhs: Var, rhs: Node, offset:
INT, bits:
INT]
RETURNS [Node] =
CHECKED {
IF init AND skipRCinit0 AND IsZero[rhs] THEN RETURN [NIL];
IF bits > 0
THEN {
IF offset # 0
OR bits # lhs.bits
THEN {
lhs ¬ TakeFieldVar[lhs, offset, bits];
rhs ¬ TakeField[rhs, offset, bits];
};
RETURN [Assign[lhs, rhs]];
};
RETURN [NIL];
};
IF init AND skipRCinit0 AND IsZero[rhs] THEN RETURN [NIL];
IF emitRCassigns
THEN
SELECT rcMap
FROM
RCMap.nullIndex => {};
Not a counted assignment
RCMap.controlLinkIndex => {};
Not a counted assignment (for now)
ENDCASE => {
We will have to emit RC assignments
cl ¬ NewCodeList[];
innerAssignFromMap[lhs, rhs, rcMap];
RETURN [MakeBlock[cl, 0]];
};
RETURN [Assign[lhs, rhs]];
};
NodeConstWord: TYPE = REF IntCodeDefs.NodeRep.const.word;
BinaryArithOp:
PUBLIC
PROC
[op: ArithSelector, ac: ArithClass, n1, n2: Node]
RETURNS [Node] =
TRUSTED {
This routine returns a binary arithmetic node with appropriate constant folding. The reason to do constant folding is that we may have to calculate values after the "normal" constant folding that takes place in Pass4. This includes things like the number of words passed through to allocation.
n: NodeConstWord;
bits: NAT ¬ ac.precision;
w: Word ¬ IntCodeUtils.CardToWord[0];
IF n1 = NIL OR n2 = NIL THEN SIGNAL CantHappen;
IF bits = bitsPerWord
THEN {
ENABLE ConstArith.Overflow => GO TO notFolded;
w1: Word ¬ w;
w2: Word ¬ w;
isC1, isC2, bothC: BOOL ¬ FALSE;
bits1: NAT ¬ bitsPerWord+1;
bits2: NAT ¬ bitsPerWord+1;
x1, x2: ConstArith.Const;
WITH n1
SELECT
FROM
const1: REF NodeRep.const.word => {isC1 ¬ TRUE; w1 ¬ const1.word};
ENDCASE;
WITH n2
SELECT
FROM
const2:
REF NodeRep.const.word => {
isC2 ¬ TRUE;
bothC ¬ isC1;
w2 ¬ const2.word;
};
ENDCASE;
SELECT ac.kind
FROM
signed => {
i1: INT ¬ IntCodeUtils.WordToInt[w1];
i2: INT ¬ IntCodeUtils.WordToInt[w2];
IF bothC THEN {x1 ¬ ConstArith.FromInt[i1]; x2 ¬ ConstArith.FromInt[i2]};
SELECT op
FROM
add =>
SELECT
TRUE
FROM
bothC =>
w ¬ IntCodeUtils.IntToWord[ConstArith.ToInt[ConstArith.Add[x1, x2]]];
isC1 AND i1 = 0 => RETURN [n2];
isC2 AND i2 = 0 => RETURN [n1];
ENDCASE => GO TO notFolded;
sub =>
SELECT
TRUE
FROM
bothC =>
w ¬ IntCodeUtils.IntToWord[ConstArith.ToInt[ConstArith.Sub[x1, x2]]];
isC2 AND i2 = 0 => RETURN [n1];
ENDCASE => GO TO notFolded;
mul =>
SELECT
TRUE
FROM
bothC =>
w ¬ IntCodeUtils.IntToWord[ConstArith.ToInt[ConstArith.Mul[x1, x2]]];
isC1 =>
SELECT i1
FROM
0 => GO TO foldIfSEF;
1 => RETURN [n1];
ENDCASE => GO TO notFolded;
isC2 =>
SELECT i2
FROM
0 => GO TO foldIfSEF;
1 => RETURN [n2];
ENDCASE => GO TO notFolded;
ENDCASE => GO TO notFolded;
div =>
SELECT
TRUE
FROM
bothC
AND i2 # 0 =>
w ¬ IntCodeUtils.IntToWord[ConstArith.ToInt[ConstArith.Div[x1, x2]]];
isC2 =>
SELECT i2
FROM
1 => RETURN [n1];
ENDCASE => GO TO notFolded;
isC1 =>
SELECT i1
FROM
0 => GO TO foldIfSEF;
ENDCASE => GO TO notFolded;
ENDCASE => GO TO notFolded;
mod =>
SELECT
TRUE
FROM
bothC
AND i2 # 0 =>
w ¬ IntCodeUtils.IntToWord[ConstArith.ToInt[ConstArith.Mod[x1, x2]]];
isC1 =>
SELECT i1
FROM
0 => GO TO foldIfSEF;
ENDCASE => GO TO notFolded;
isC2 =>
SELECT i2
FROM
1 => GO TO foldIfSEF;
ENDCASE => GO TO notFolded;
ENDCASE => GO TO notFolded;
min =>
SELECT
TRUE
FROM
bothC => w ¬ IntCodeUtils.IntToWord[MIN[i1, i2]];
ENDCASE => GO TO notFolded;
max =>
SELECT
TRUE
FROM
bothC => w ¬ IntCodeUtils.IntToWord[MAX[i1, i2]];
ENDCASE => GO TO notFolded;
ENDCASE => GO TO notFolded;
};
unsigned, address => {
c1: CARD ¬ IntCodeUtils.WordToCard[w1];
c2: CARD ¬ IntCodeUtils.WordToCard[w2];
IF bothC THEN {x1 ¬ ConstArith.FromCard[c1]; x2 ¬ ConstArith.FromCard[c2]};
SELECT op
FROM
add =>
SELECT
TRUE
FROM
bothC =>
w ¬ IntCodeUtils.CardToWord[ConstArith.ToCard[ConstArith.Add[x1, x2]]];
isC1 AND c1 = 0 => RETURN [n2];
isC2 AND c2 = 0 => RETURN [n1];
ENDCASE => GO TO notFolded;
sub =>
SELECT
TRUE
FROM
bothC =>
w ¬ IntCodeUtils.CardToWord[ConstArith.ToCard[ConstArith.Sub[x1, x2]]];
isC2 AND c2 = 0 => RETURN [n1];
ENDCASE => GO TO notFolded;
mul =>
SELECT
TRUE
FROM
bothC =>
w ¬ IntCodeUtils.CardToWord[ConstArith.ToCard[ConstArith.Mul[x1, x2]]];
isC1 =>
SELECT c1
FROM
0 => GO TO foldIfSEF;
1 => RETURN [n2];
ENDCASE => GO TO notFolded;
isC2 =>
SELECT c2
FROM
0 => GO TO foldIfSEF;
1 => RETURN [n1];
ENDCASE => GO TO notFolded;
ENDCASE => GO TO notFolded;
div =>
SELECT
TRUE
FROM
bothC
AND c2 # 0 =>
w ¬ IntCodeUtils.CardToWord[c1 / c2];
isC1 =>
SELECT c1
FROM
0 => GO TO foldIfSEF;
ENDCASE => GO TO notFolded;
isC2 =>
SELECT c2
FROM
1 => RETURN [n1];
ENDCASE => GO TO notFolded;
ENDCASE => GO TO notFolded;
mod =>
SELECT
TRUE
FROM
bothC
AND c2 # 0 =>
w ¬ IntCodeUtils.CardToWord[c1 MOD c2];
isC2 =>
SELECT c2
FROM
1 => GO TO foldIfSEF;
ENDCASE => GO TO notFolded;
isC1 =>
SELECT c1
FROM
0 => GO TO foldIfSEF;
ENDCASE => GO TO notFolded;
ENDCASE => GO TO notFolded;
min =>
SELECT
TRUE
FROM
bothC => w ¬ IntCodeUtils.CardToWord[MIN[c1, c2]];
ENDCASE => GO TO notFolded;
max =>
SELECT
TRUE
FROM
bothC => w ¬ IntCodeUtils.CardToWord[MAX[c1, c2]];
ENDCASE => GO TO notFolded;
ENDCASE => GO TO notFolded;
};
ENDCASE => GO TO notFolded;
n ¬ z.NEW [NodeRep.const.word];
n ¬ [bits, const[word[w]]];
RETURN [n];
--RETURN [z.NEW [NodeRep.const.word ¬ [bits, const[word[w]]]]];
EXITS
foldIfSEF =>
SELECT
TRUE
FROM
NOT IntCodeUtils.SideEffectFree[n1, TRUE] => {};
NOT IntCodeUtils.SideEffectFree[n2, TRUE] => {};
ENDCASE =>
{
n: NodeConstWord ¬ z.NEW [NodeRep.const.word];
n ¬ [bits, const[word[w]]];
RETURN [n];
--RETURN [z.NEW [NodeRep.const.word ¬ [bits, const[word[w]]]]];
};
notFolded => {};
};
RETURN [ApplyOp[ArithOp[op, ac], MakeNodeList2[n1, n2], bits]];
};
BitsForOperand:
PUBLIC
UNSAFE PROC [t: Tree.Link]
RETURNS [
INT] =
UNCHECKED {
WITH e: t
SELECT TreeOps.GetTag[t]
FROM
literal => {
lti: Literals.LTIndex = e.index;
IF LiteralOps.IsShort[lti]
THEN RETURN [bitsPerWord]
ELSE {
desc: Literals.LitDescriptor = LiteralOps.DescriptorValue[lti];
RETURN [desc.bits];
};
};
symbol => {
sei: ISEIndex = e.index;
idType: Symbols.Type = seb[sei].idType;
uType: Symbols.CSEIndex = MimP5.Clarify[idType];
SELECT
TRUE
FROM
uType = Symbols.typeTYPE => RETURN [bitsPerWord];
seb[sei].constant => {};
ENDCASE => RETURN [SymbolOps.DecodeInt[seb[sei].idInfo]];
};
ENDCASE;
RETURN [BitsForType[OperandType[t]]];
};
BitsForType:
PUBLIC
UNSAFE PROC
[type: Type]
RETURNS [nBits: BitCount ¬ 0] =
UNCHECKED {
assumes that Pass4 processing is done (copied more or less from Pass4L.BitsForType)
sei: CSEIndex = MimP5.Clarify[type];
IF sei # Symbols.CSENull
THEN {
sep: LONG POINTER TO Symbols.SERecord.cons = @seb[sei];
WITH se: sep
SELECT
FROM
definition => nBits ¬ Target.bitsPerLongWord;
RRA: this is speculative. We need to do something about links to interface records.
basic => nBits ¬ se.length;
real => nBits ¬ se.length;
signed => nBits ¬ se.length;
unsigned => nBits ¬ se.length;
enumerated =>
IF
NOT se.empty
THEN
nBits ¬ SymbolOps.BitsForRange[SymbolOps.Cardinality[SymbolOps.own, sei]-1];
ref => nBits ¬ se.length;
transfer => nBits ¬ se.length;
arraydesc => nBits ¬ se.length;
relative => nBits ¬ BitsForType[se.offsetType];
zone => nBits ¬ se.length;
record => IF ~ sep.mark4 THEN ERROR ELSE nBits ¬ se.length;
array =>
IF ~ sep.mark4
THEN
ERROR
ELSE {
n: CARD = SymbolOps.Cardinality[SymbolOps.own, se.indexType];
b: BitCount ¬ BitsForType[se.componentType];
IF se.packed
AND (b#0
AND b<=Target.PackedBitCount.
LAST)
THEN {
packedSize: CARDINAL = SymbolOps.PackedSize[b];
itemsPerWord: CARDINAL = Target.bitsPerWord/packedSize;
IF n <= itemsPerWord
THEN nBits ¬ n*packedSize
ELSE nBits ¬ BitsForWords[(n+(itemsPerWord-1))/itemsPerWord];
}
ELSE {
IF b # bitsPerWord
THEN
Round up the bits
b ¬ BitsForWords[WordsForBits[b]];
nBits ¬ n*b;
};
};
opaque => IF ~ sep.mark4 THEN ERROR ELSE nBits ¬ se.length;
subrange =>
SELECT
TRUE
FROM
~ sep.mark4 => ERROR;
se.empty => {};
ENDCASE =>
nBits ¬ SymbolOps.BitsForRange[SymbolOps.Cardinality[SymbolOps.own, sei]-1];
ENDCASE;
};
};
BoolTest:
PUBLIC
PROC [exp: Node]
RETURNS [MimP5U.BoolTestValue] = {
SELECT exp
FROM
MimCode.falseNode, MimCode.nC0 => RETURN [false];
MimCode.trueNode, MimCode.nC1 => RETURN [true];
ENDCASE;
WITH exp
SELECT
FROM
word:
REF NodeRep.const.word =>
SELECT IntCodeUtils.WordToInt[word.word]
FROM
0 => RETURN [false];
1 => RETURN [true];
ENDCASE;
ENDCASE;
RETURN [unknown];
};
BoundsCheck:
PUBLIC
PROC [exp, bound: Node]
RETURNS [Node] = {
WITH exp
SELECT
FROM
ec:
REF NodeRep.const.word =>
WITH bound
SELECT
FROM
bc:
REF NodeRep.const.word =>
Both values are small constants, so we can bounds check (unsigned, of course).
IF IntCodeUtils.WordToCard[ec.word]
< IntCodeUtils.WordToCard[bc.word] THEN RETURN [exp];
ENDCASE;
ENDCASE;
IF boundCheckOp =
NIL
THEN {
bo: Oper ¬ z.NEW[OperRep.check ¬
[check[class: [unsigned, FALSE, bitsPerWord], sense: lt]]];
boundCheckOp ¬ GenOper[bo];
};
RETURN [ApplyOp[boundCheckOp, MakeArgList2[exp, bound], exp.bits]];
};
CedarOpNode:
PUBLIC
PROC [op: CedarSelector, info:
INT ¬ 0]
RETURNS [l: Node] = {
SELECT
TRUE
FROM
info # 0 => {};
cachedCedarOper = NIL => cachedCedarOper ¬ z.NEW[CachedCedarOperRep];
(l ¬ cachedCedarOper[op]) # NIL => RETURN [l];
ENDCASE;
l ¬ GenOper[z.NEW[OperRep.cedar ¬ [cedar[cedar: op, info: info]]]];
IF info = 0 THEN cachedCedarOper[op] ¬ l;
};
CJump:
PUBLIC
PROC [cl: CodeList, test: Comparator, op1, op2: Node, ac: ArithClass, target: Label, backwards:
BOOL ¬
FALSE] = {
cn: Node = CompareOp[test, ac];
comp: Node = ApplyOp[oper: cn, args: MakeArgList2[op1, op2], bits: 1];
case: CaseList ¬ MakeCaseList[MakeNodeList[comp], MakeGoTo[target, backwards]];
cond: Node = z.NEW[NodeRep.cond ¬ [details: cond[case]]];
MoreCode[cl, cond];
};
CompareOp:
PUBLIC
PROC [sense: Comparator, ac: ArithClass]
RETURNS [l: Node] = {
oper: IntCodeDefs.Oper;
ax: ArithIndex = ArithClassToArithIndex[ac];
IF cachedCompareOper =
NIL
THEN cachedCompareOper ¬ z.NEW[CachedCompareOperRep] -- all NIL from allocator
ELSE IF (l ¬ cachedCompareOper[ax][sense]) # NIL THEN RETURN;
oper ¬ z.NEW[OperRep.compare ¬ [compare [class: ac, sense: sense]]];
cachedCompareOper[ax][sense] ¬ l ¬ GenOper[oper];
};
ConvertOpNode:
PUBLIC
PROC [from, to: ArithClass]
RETURNS [l: Node] = {
fromX: ArithIndex = ArithClassToArithIndex[from];
toX: ArithIndex = ArithClassToArithIndex[to];
SELECT
TRUE
FROM
cachedConvertOper =
NIL =>
cachedConvertOper ¬ z.
NEW[CachedConvertOperRep];
all NIL from allocator
(l ¬ cachedConvertOper[fromX][toX]) # NIL => RETURN [l];
ENDCASE;
cachedConvertOper[fromX][toX] ¬ l ¬ RawConvertOp[from, to];
};
CreateTemp:
PUBLIC
UNSAFE PROC
[bits: BitCount, type: Type ¬ typeANY]
RETURNS [var: Var, sei: ISEIndex] =
UNCHECKED {
pad: CARDINAL ¬ Basics.LowHalf[bits] MOD bitsPerWord;
IF pad # 0 THEN pad ¬ bitsPerWord - pad;
sei ¬ SymbolOps.MakeCtxSe[Symbols.HTNull, Symbols.CTXNull];
seb[sei].constant ¬ seb[sei].extended ¬ seb[sei].linkSpace ¬ FALSE;
seb[sei].immutable ¬ TRUE;
seb[sei].idCtx ¬ MimCode.tempcontext;
seb[sei].idInfo ¬ SymbolOps.EncodeInt[bits+pad];
Note the padding to keep bit counts consistent.
seb[sei].idType ¬ type;
var ¬ MimP5.VarForSei[sei];
var.flags[named] ¬ FALSE;
};
Declare:
PUBLIC
PROC [cl: CodeList, var: Var, init: Node ¬
NIL] = {
dn: DeclNode ¬ IntCodeStuff.GenDecl[var, init];
IF init #
NIL
AND var.bits # init.bits
THEN
SIGNAL CantHappen;
This check is here because we don't know how to extend the value. Is it signed?
WITH var.location
SELECT
FROM
local: IntCodeDefs.LocalVarLocation =>
IF MimP5.visibleContext #
NIL
THEN {
Force the parent to be at the right level, which may be initially wrong due to the need to generate procedures for catch phrases (see SCatchPhrase for details).
local.parent ¬ MimP5.visibleContext[MimCode.curctxlvl];
};
ENDCASE;
WITH init
SELECT
FROM
bn:
REF NodeRep.block =>
The initialization expression is a block expression that we might be able to substitute right here!
IF MimP5Stuff.BlockValSimplify[cl, dn, bn] THEN RETURN;
ENDCASE;
MoreCode[cl, dn];
};
Deref:
PUBLIC
PROC [n: Node, bits: BitCount, align: Symbols.Alignment]
RETURNS [v: Var] = {
alignBits:
NAT =
SELECT align
FROM
twoAU => 2*bitsPerAU,
fourAU => 4*bitsPerAU,
eightAU => 8*bitsPerAU,
ENDCASE => bitsPerAU;
WITH n
SELECT
FROM
app: ApplyNode => {
addrOp: Node = MesaOpNode[addr];
IF app.proc = addrOp
THEN {
first: Node = app.args.first;
IF first.bits = bits AND MimP5Stuff.IsSimpleVar[first] THEN RETURN [NARROW[first]];
};
};
ENDCASE;
v ¬ z.NEW[VarRep ¬ [bits: bits, details: var[location: z.NEW[LocationRep.deref
¬ [deref[addr: n, align: MAX[minAlignBits, alignBits]]]]]]];
};
EqualTest:
PUBLIC
PROC [n1, n2: Node, negate:
BOOL]
RETURNS [Node] = {
bits: INT ¬ MAX[n1.bits, n2.bits, bitsPerWord];
op: Node ¬
SELECT bits
FROM
= bitsPerWord =>
Can do the comparison the "short" way
CompareOp[IF negate THEN ne ELSE eq, [unsigned, FALSE, bitsPerWord]]
ENDCASE =>
Must do the comparison the "long" way
GenOper[z.NEW[OperRep.mesa ¬ [mesa [
mesa: IF negate THEN notEqual ELSE equal,
info: bits]]]];
IF n1.bits < bits THEN n1 ¬ ZeroExtend[n1, bits, bits <= bitsPerWord];
IF n2.bits < bits THEN n2 ¬ ZeroExtend[n2, bits, bits <= bitsPerWord];
IF MimP5Stuff.IsCard[n1]
AND MimP5Stuff.IsCard[n2]
THEN {
We collapsed to a pair of constants, probably due to record constructor folding
c1: CARD ¬ MimP5Stuff.GetCard[n1];
c2: CARD ¬ MimP5Stuff.GetCard[n2];
ret: Node ¬ MimCode.trueNode;
SELECT
TRUE
FROM
negate => IF c1 = c2 THEN ret ¬ MimCode.falseNode;
ENDCASE => IF c1 # c2 THEN ret ¬ MimCode.falseNode;
RETURN [ret];
};
RETURN [ApplyOp[op, MakeNodeList2[n1, n2], bitsPerBool]];
};
Extend:
PUBLIC
UNSAFE
PROC
[n: Node, bits: BitCount, type: Type]
RETURNS [Node] =
UNCHECKED {
Extends the node n with the assumption that the container has the given number of bits, and the starting type of the node is type. Note that type does not specify the resulting type of the container.
srcAc: ArithClass = ArithClassForType[type];
nBits: INT ¬ n.bits;
IF nBits = bits THEN RETURN [n];
SELECT srcAc.kind
FROM
signed => RETURN [SignExtend[n, bits]];
address => RETURN [AddrExtend[n, bits]];
real => RETURN [RealExtend[n, bits]];
ENDCASE => RETURN [ZeroExtend[n, bits]];
};
ExtractList:
PUBLIC PROC [cl: CodeList]
RETURNS [nl: NodeList] = {
nl ¬ cl.head;
FreeCodeList[cl];
};
ForceBool:
PUBLIC PROC [n: Node, negate:
BOOL ¬
FALSE]
RETURNS [Node] = {
SELECT BoolTest[n]
FROM
true => IF negate THEN n ¬ MimCode.falseNode ELSE n ¬ MimCode.trueNode;
false => IF negate THEN n ¬ MimCode.trueNode ELSE n ¬ MimCode.falseNode;
ENDCASE =>
SELECT n.bits
FROM
bitsPerBool => {
IF negate
THEN {
IF cachedNotOper =
NIL
THEN {
cachedNotOper ¬ GenOper[
z.NEW[OperRep.boolean ¬ [boolean[class: not, bits: bitsPerBool]]]];
};
n ¬ ApplyOp[
oper: cachedNotOper,
args: MakeNodeList[n],
bits: bitsPerBool];
};
};
<= bitsPerWord => {
op: Node ¬ CompareOp[
IF negate THEN eq ELSE ne,
[unsigned, FALSE, bitsPerWord]];
false: Node ¬ MakeConstCard[0, bitsPerWord];
n ¬ ApplyOp[op, MakeNodeList2[false, ZeroExtend[n, bitsPerWord]], bitsPerBool];
};
ENDCASE => {
mod: NAT ¬ Basics.LowHalf[n.bits] MOD bitsPerWord;
bits: NAT ¬ n.bits + (IF mod = 0 THEN 0 ELSE bitsPerWord-mod);
false: Node ¬ ZeroExtend[MakeConstCard[0, bitsPerWord], bits];
op: Node ¬ MesaOpNode[IF negate THEN equal ELSE notEqual];
n ¬ ApplyOp[op, MakeNodeList2[false, ZeroExtend[n, bits]], bitsPerBool];
};
RETURN [n];
};
FormalVar:
PUBLIC
PROC [bits: BitCount]
RETURNS [v: Var] = {
Only used to generate special unnamed formal variables for special procedures (like signal handlers).
v ¬ z.NEW[NodeRep.var ¬ [bits: bits, details: var[id: generatedVar]]];
generatedVar ¬ generatedVar + 1;
};
FreeCodeList:
PRIVATE
PROC [cl: CodeList] = {
cl ¬ [NIL, NIL];
FOR i:
CARDINAL
IN [0..cachedCodeListCount)
DO
IF cachedCodeList[i] = cl THEN ERROR;
ENDLOOP;
FOR i:
CARDINAL
IN [0..cachedCodeListCount)
DO
IF cachedCodeList[i] = NIL THEN {cachedCodeList[i] ¬ cl; EXIT};
ENDLOOP;
otherwise drop on floor for REF case
};
FullWordBits:
PUBLIC
PROC [bits: BitCount]
RETURNS [BitCount] = {
mod: NAT = Basics.LowHalf[bits] MOD bitsPerWord;
IF mod # 0 THEN bits ¬ bits + (bitsPerWord-mod);
RETURN [bits];
};
InsertLabel:
PUBLIC
PROC [cl: CodeList, lbl: Label] = {
n: Node ¬ z.NEW [NodeRep.label ¬ [details: label[lbl]]];
MoreCode[cl, n];
};
IsZero:
PUBLIC
PROC [n: Node]
RETURNS [
BOOL] = {
DO
WITH n
SELECT
FROM
var: Var =>
WITH var.location
SELECT
FROM
field: FieldLocation => {n ¬ field.base; LOOP};
index: IndexedLocation => {n ¬ index.base; LOOP};
comp: CompositeLocation => {
FOR each: NodeList ¬ comp.parts, each.rest
WHILE each #
NIL
DO
IF NOT IsZero[each.first] THEN RETURN [FALSE];
ENDLOOP;
RETURN [TRUE];
};
dummy: DummyLocation => RETURN [TRUE];
ENDCASE;
assign: AssignNode => {
n ¬ assign.rhs;
LOOP;
};
const: ConstNode =>
WITH const
SELECT
FROM
w: WordConstNode =>
IF IntCodeUtils.WordToCard[w.word] = 0 THEN RETURN [TRUE];
b: BytesConstNode =>
CHECKED {
eachChar: Rope.ActionType = CHECKED {RETURN [c # 0C]};
RETURN [NOT Rope.Map[base: b.bytes, action: eachChar]];
};
ENDCASE => RETURN [FALSE];
apply: ApplyNode =>
IF apply.bits < bitsPerWord
THEN
WITH apply.proc
SELECT
FROM
oper: OperNode => {
WITH oper.oper
SELECT
FROM
cvt: REF OperRep.convert => GO TO ifFirstArg;
mesa:
REF OperRep.mesa =>
SELECT mesa.mesa
FROM
all => GO TO ifFirstArg;
ENDCASE;
cedar:
REF OperRep.cedar =>
SELECT cedar.cedar
FROM
simpleAssign, simpleAssignInit => GO TO ifSecondArg;
complexAssign, complexAssignInit => GO TO ifSecondArg;
procCheck => GO TO ifFirstArg;
ENDCASE;
ENDCASE;
EXITS
ifFirstArg => {n ¬ apply.args.first; LOOP};
ifSecondArg => {n ¬ apply.args.rest.first; LOOP};
};
ENDCASE;
block: BlockNode => {
nodes: NodeList ¬ block.nodes;
decl: DeclNode ¬ NIL;
var: Var ¬ NIL;
WHILE nodes #
NIL
DO
first: Node = nodes.first;
rest: NodeList = nodes.rest;
nodes ¬ rest;
WITH first
SELECT
FROM
dn: DeclNode =>
IF decl =
NIL
THEN {
decl ¬ dn;
var ¬ decl.var;
IF decl.init = NIL OR IsZero[decl.init] THEN LOOP;
};
an: AssignNode =>
WITH an.lhs
SELECT
FROM
av: Var =>
WITH av.location
SELECT
FROM
avf: FieldLocation => IF avf.base = var AND IsZero[an.rhs] THEN LOOP;
ENDCASE;
ENDCASE;
vn: Var => RETURN [vn = var AND rest = NIL];
ENDCASE;
EXIT;
ENDLOOP;
RETURN [FALSE];
};
ENDCASE;
RETURN [FALSE];
ENDLOOP;
};
Jump:
PUBLIC
PROC [cl: CodeList, target: Label, backwards:
BOOL ¬
FALSE] = {
MoreCode[cl, MakeGoTo[target, backwards]];
};
LabelAddress:
PUBLIC
PROC [label: Label, direct:
BOOL]
RETURNS [Node] = {
oper: Oper ¬ z.NEW[OperRep.code ¬ [code[label: label, offset: 0, direct: direct]]];
label.used ¬ TRUE;
RETURN [GenOper[oper, bitsPerPtr]];
};
MakeArgList2:
PUBLIC
PROC [first: Node, second: Node]
RETURNS [NodeList] = {
RETURN [PadArgList[MakeNodeList2[first, second]]];
};
MakeArgList:
PUBLIC
PROC [first: Node, last: NodeList ¬
NIL]
RETURNS [NodeList] = {
RETURN [PadArgList[MakeNodeList[first, last]]];
};
MakeBlock:
PUBLIC
PROC [cl: CodeList, bits: BitCount]
RETURNS [Node] = {
Remove NIL nodes (essentially a courtesy to later passes)
b: Node ¬ z.NEW [NodeRep.block ¬ [bits: bits, details: block[cl.head]]];
b ¬ MimP5Stuff.CanonBlock[b];
FreeCodeList[cl];
RETURN [b];
};
MakeCaseList:
PUBLIC
PROC
[tests: NodeList, body: Node, rest: CaseList ¬
NIL]
RETURNS [CaseList] = {
temp: NodeList ¬ tests;
testHead: NodeList ¬ NIL;
testTail: NodeList ¬ NIL;
WHILE temp #
NIL
DO
first: Node ¬ temp.first;
WITH first
SELECT
FROM
cond: CondNode => {
cases: CaseList ¬ cond.cases;
innerHead: NodeList ¬ NIL;
innerTail: NodeList ¬ NIL;
WHILE cases #
NIL
AND cases.body = MimCode.trueNode
DO
innerTests: NodeList ¬ cases.tests;
IF innerTests = NIL THEN EXIT;
WHILE innerTests #
NIL
DO
new: NodeList ¬ MakeNodeList[innerTests.first];
IF innerTail = NIL THEN innerHead ¬ new ELSE innerTail.rest ¬ new;
innerTail ¬ new;
innerTests ¬ innerTests.rest;
ENDLOOP;
cases ¬ cases.rest;
ENDLOOP;
IF innerTail #
NIL
THEN {
We were able to peel off some cases from the inner cond and put them into the test list. We may have been able to peel off all cases.
IF testTail = NIL THEN testHead ¬ innerHead ELSE innerTail.rest ¬ innerHead;
testTail ¬ innerTail;
SELECT
TRUE
FROM
cases =
NIL =>
No cases remain
first ¬ NIL;
cases.tests =
NIL =>
The last case is the ENDCASE
first ¬ cases.body;
ENDCASE =>
There are multiple residual cases
first ¬ z.NEW[NodeRep.cond ¬ [bits: cond.bits, details: cond[cases]]];
};
};
ENDCASE;
IF testTail # NIL AND first # NIL THEN testTail ¬ testTail.rest ¬ MakeNodeList[first];
temp ¬ temp.rest;
ENDLOOP;
IF testTail # NIL THEN tests ¬ testHead;
RETURN [z.NEW [CaseListRep ¬ [tests, body, rest]]];
};
MakeComposite:
PUBLIC
PROC [parts: NodeList, bits: BitCount]
RETURNS [Var] = {
loc: Location ¬ z.NEW[LocationRep.composite ¬ [composite[parts]]];
cBits: INT ¬ 0;
FOR each: NodeList ¬ parts, each.rest
WHILE each #
NIL
DO
cBits ¬ cBits + each.first.bits;
ENDLOOP;
IF bits # 0 AND cBits # bits THEN SIGNAL CantHappen;
RETURN [MakeVar[cBits, 0, loc]];
};
MakeConstCard:
PUBLIC
PROC [card:
CARD, bits: BitCount ¬ bitsPerWord]
RETURNS [Node] = {
n: NodeConstWord;
SELECT bits
FROM
1 => IF card = 0 OR card = 1 THEN RETURN [constBoolArray[card]];
bitsPerWord =>
IF card <= constWordMax THEN RETURN [constWordArray[card]];
ENDCASE;
n ¬ z.NEW [NodeRep.const.word];
n ¬ [bits, const[word[IntCodeUtils.CardToWord[card]]]];
RETURN [n];
};
MakeConstInt:
PUBLIC
PROC [int:
INT, bits: BitCount ¬ bitsPerWord]
RETURNS [Node] = {
n: NodeConstWord;
SELECT bits
FROM
1 => IF int = 0 OR int = 1 THEN RETURN [constBoolArray[int]];
bitsPerWord =>
IF int >= 0 AND int <= constWordMax THEN RETURN [constWordArray[int]];
ENDCASE;
n ¬ z.NEW [NodeRep.const.word];
n ¬ [bits, const[word[IntCodeUtils.IntToWord[int]]]];
RETURN [n];
};
MakeDummy:
PUBLIC
PROC [bits: BitCount]
RETURNS [Node] = {
RETURN [MakeVar[bits: bits, id: 0, loc: dummyLoc]];
};
MakeGoTo:
PUBLIC
PROC [label: Label, backwards:
BOOL ¬
FALSE]
RETURNS [Node] = {
node: Node = z.NEW[NodeRep.goto ¬ [details: goto[label, backwards]]];
label.jumpedTo ¬ label.used ¬ TRUE;
IF backwards THEN label.backTarget ¬ TRUE;
RETURN [node];
};
MakeNodeList2:
PUBLIC
PROC [first, second: Node]
RETURNS [NodeList] = {
RETURN [z.NEW [NodeListRep ¬ [first, z.NEW[NodeListRep ¬ [second, NIL]]]]];
};
MakeNodeList:
PUBLIC
PROC [first: Node, last: NodeList ¬
NIL]
RETURNS [NodeList] = {
RETURN [z.NEW [NodeListRep ¬ [first, last]]];
};
MakeReturn:
PUBLIC
PROC [rets: NodeList]
RETURNS [new: Node ¬
NIL] = {
rets ¬ PadArgList[rets];
IF rets = NIL AND cachedEmptyReturn # NIL THEN RETURN [cachedEmptyReturn];
new ¬ IntCodeStuff.GenReturn[rets];
IF rets = NIL THEN cachedEmptyReturn ¬ new;
};
MakeTemp:
PUBLIC
UNSAFE
PROC
[cl: CodeList, bits: BitCount, init: Node ¬
NIL, type: Type ¬ typeANY]
RETURNS [var: Var, sei: ISEIndex] =
UNCHECKED {
[var, sei] ¬ CreateTemp[bits, type];
IF init #
NIL
AND init.bits < var.bits
THEN
init ¬ Extend[init, var.bits, type];
Declare[cl: cl, var: var, init: init];
};
MakeVar:
PUBLIC
PROC [bits: BitCount, id: VariableId, loc: Location]
RETURNS [Var] = {
flags: VariableFlags ¬ nullVariableFlags;
IF id > nullVariableId THEN flags[named] ¬ TRUE;
WITH loc
SELECT
FROM
dummy: DummyLocation => flags[constant] ¬ TRUE;
ENDCASE;
RETURN [z.NEW[NodeRep.var ¬ [bits: bits, details: var[flags: flags, id: id, location: loc]]]];
};
MakeVarList:
PUBLIC
PROC [first: Var, last: VarList ¬
NIL]
RETURNS [VarList] = {
RETURN [z.NEW[VarListRep ¬ [first, last]]];
};
MaybeBlock:
PUBLIC
PROC [cl: CodeList, l: Node]
RETURNS [Node] = {
SELECT
TRUE
FROM
cl = NIL => RETURN [l];
cl.head #
NIL => {
bits: INT ¬ 0;
IF l # NIL THEN {cl.tail.rest ¬ MakeNodeList[l]; bits ¬ l.bits};
RETURN [MakeBlock[cl, bits]];
};
ENDCASE;
FreeCodeList[cl];
RETURN [l];
};
MesaOpNode:
PUBLIC
PROC [op: MesaSelector, info:
INT ¬ 0, bits:
INT ¬ 0]
RETURNS [l: Node ¬
NIL] = {
oper: IntCodeDefs.Oper;
IF cachedMesaOper =
NIL
THEN cachedMesaOper ¬ z.NEW[CachedMesaOperRep]
ELSE
WITH cachedMesaOper[op]
SELECT
FROM
old:
REF NodeRep.oper =>
IF old.bits = bits
THEN
WITH old.oper
SELECT
FROM
mesaOld:
REF OperRep.mesa =>
IF mesaOld.info = info THEN RETURN [old];
ENDCASE;
ENDCASE;
oper ¬ z.NEW[OperRep.mesa ¬ [mesa[mesa: op, info: info]]];
l ¬ GenOper[oper, bits];
cachedMesaOper[op] ¬ l;
};
MoreCode:
PUBLIC
PROC [cl: CodeList, n: Node] = {
nl: NodeList ¬ MakeNodeList[n];
IF cl.tail =
NIL
THEN {
IF cl.head # NIL THEN ERROR;
cl.head ¬ nl;
}
ELSE cl.tail.rest ¬ nl;
cl.tail ¬ nl;
};
NewCodeList:
PUBLIC
PROC
RETURNS [cl: CodeList] = {
FOR i:
CARDINAL
IN [0..cachedCodeListCount)
DO
IF cachedCodeList[i] #
NIL
THEN {
cl ¬ cachedCodeList[i];
cachedCodeList[i] ¬ NIL;
cl.head ¬ cl.tail ¬ NIL;
RETURN;
};
ENDLOOP;
cl ¬ z.NEW[CodeListRep ¬ [NIL, NIL]];
};
NextVar:
PUBLIC
UNSAFE
PROC [sei: ISEIndex]
RETURNS [ISEIndex] =
UNCHECKED {
starting at sei returns first variable on ctx-list
DO
SELECT
TRUE
FROM
(sei = ISENull) => RETURN [ISENull];
(seb[sei].idType # Symbols.typeTYPE)
AND ~seb[sei].constant =>
RETURN [sei];
I bet types are already constant
ENDCASE => sei ¬ SymbolOps.NextSe[SymbolOps.own, sei];
ENDLOOP;
};
NilConst:
PUBLIC
UNSAFE PROC [type: CSEIndex]
RETURNS [Node] =
UNCHECKED {
bits: INT ¬ BitsForType[type];
SELECT bits
FROM
<= bitsPerWord => RETURN [MakeConstCard[0, bits]];
ENDCASE => ERROR;
};
NodeAnd:
PUBLIC
PROC [n1, n2: Node]
RETURNS [Node] = {
SELECT BoolTest[n1]
FROM
true => RETURN [n2];
false => RETURN [MimCode.falseNode];
ENDCASE =>
IF IntCodeUtils.IsSimple[n1, reallySimple]
AND IntCodeUtils.IsSimple[n2, reallySimple]
THEN {
Can use a simple boolean operation
n1 ¬ ForceBool[n1];
n2 ¬ ForceBool[n2];
RETURN [ApplyOp[andBoolOp, MakeNodeList2[n1, n2], n1.bits]];
}
ELSE {
else: IntCodeDefs.CaseList = MakeCaseList[NIL, MimCode.falseNode];
then: IntCodeDefs.CaseList
¬ MakeCaseList[MakeNodeList[ForceBool[n1]], ForceBool[n2], else];
RETURN [z.NEW[NodeRep.cond ¬ [bits: bitsPerBool, details: cond[then]]]];
};
};
NodeIf:
PUBLIC
PROC [test, then, else: Node]
RETURNS [Node] = {
SELECT BoolTest[test]
FROM
true => RETURN [then];
false => RETURN [else];
ENDCASE => {
bits: INT ¬ 0;
IF test # NIL THEN test ¬ ForceBool[test];
SELECT
TRUE
FROM
then = NIL => IF else # NIL THEN bits ¬ else.bits;
else = NIL => bits ¬ then.bits;
ENDCASE => {
bits ¬ MAX[then.bits, else.bits];
IF then.bits < bits THEN then ¬ ZeroExtend[then, bits];
IF else.bits < bits THEN else ¬ ZeroExtend[else, bits];
};
{
elseCase: IntCodeDefs.CaseList =
WITH else
SELECT
FROM
cond: IntCodeDefs.CondNode => cond.cases,
ENDCASE => IF else = NIL THEN NIL ELSE MakeCaseList[NIL, else];
thenCase: IntCodeDefs.CaseList = MakeCaseList[MakeNodeList[test], then, elseCase];
RETURN [z.NEW[NodeRep.cond ¬ [bits: bits, details: cond[thenCase]]]];
};
};
};
NodeOr:
PUBLIC
PROC [n1, n2: Node]
RETURNS [Node] = {
SELECT BoolTest[n1]
FROM
true => RETURN [MimCode.trueNode];
false => RETURN [n2];
ENDCASE =>
IF IntCodeUtils.IsSimple[n1, reallySimple]
AND IntCodeUtils.IsSimple[n2, reallySimple]
THEN {
Can use a simple boolean operation
n1 ¬ ForceBool[n1];
n2 ¬ ForceBool[n2];
RETURN [ApplyOp[orBoolOp, MakeNodeList2[n1, n2], n1.bits]];
}
ELSE {
else: IntCodeDefs.CaseList = MakeCaseList[NIL, ForceBool[n2]];
then: IntCodeDefs.CaseList =
MakeCaseList[MakeNodeList[ForceBool[n1]], MimCode.trueNode, else];
RETURN [z.NEW[NodeRep.cond ¬ [bits: bitsPerBool, details: cond[then]]]];
};
};
NodeForType:
PUBLIC
UNSAFE
PROC [type: Type]
RETURNS [Node] =
UNCHECKED {
type ¬ MimP5.Clarify[type];
RETURN [ZeroExtend[MimP5.Exp[SymLiteralOps.TypeRef[type: type, canonical: TRUE]]]];
};
OperandType:
PUBLIC
UNSAFE PROC
[t: Tree.Link]
RETURNS [sei: CSEIndex] =
UNCHECKED {
compute type of tree
type: Symbols.Type ¬ Symbols.CSENull;
WITH e: t
SELECT TreeOps.GetTag[t]
FROM
literal =>
SELECT LiteralOps.Value[e.index].class
FROM
unsigned => type ¬ MimData.idCARDINAL;
signed => type ¬ MimData.idINTEGER;
either => type ¬ MimData.idNAT;
real => type ¬ MimData.idREAL;
ENDCASE => type ¬ MimData.idCARDINAL; -- really? is ERROR better?
symbol => type ¬ seb[e.index].idType;
string => type ¬ MimData.idSTRING;
subtree =>
SELECT
TRUE
FROM
e # Tree.Null => {
tp:
LONG
POINTER
TO Tree.Node = @tb[e.index];
Remember to extract all fields before calling anything that could cause relocation!
SELECT tp.name
FROM
body => {
RRA: This goody comes about due to assigning a procedure body to a variable (or to an argument). This is not a great feature in Mesa.
bti: Symbols.BTIndex = SymbolOps.ToBti[tp.info];
IF bti # Symbols.BTNull
THEN
WITH bt: bb[bti]
SELECT
FROM
Callable => type ¬ bt.ioType;
ENDCASE =>
ERROR;
This just should not happen!
};
signalinit =>
RRA: This goody comes about due to assigning CODE to an error variable. This is not a great feature in Mesa.
type ¬ Symbols.typeANY;
Just a stupid little placeholder
ENDCASE =>
type ¬ SymbolOps.ToType[tp.info];
};
MimCode.xtracting => type ¬ seb[MimCode.xtractsei].idType;
ENDCASE => type ¬ MimCode.caseType;
ENDCASE => ERROR;
RETURN [MimP5.Clarify[type]];
};
PadArgList:
PUBLIC
PROC [args: NodeList]
RETURNS [NodeList] = {
FOR each: NodeList ¬ args, each.rest
WHILE each #
NIL
DO
expr: Node ¬ each.first;
IF expr #
NIL
THEN {
bits: INT ¬ expr.bits;
mod: INT ¬ bits MOD bitsPerWord;
IF mod # 0 THEN each.first ¬ ZeroExtend[expr, bits+(bitsPerWord-mod)];
};
ENDLOOP;
RETURN [args];
};
ProcessSafens:
PUBLIC
UNSAFE PROC [cl: CodeList, t: Tree.Link, ignore:
BOOL ¬
FALSE]
RETURNS [nt: Tree.Link] =
UNCHECKED {
FindSafens: Tree.Map = {
v ¬ t; -- normal case
IF t # Tree.Null
THEN
WITH t
SELECT TreeOps.GetTag[t]
FROM
subtree => {
node: Tree.Index = index;
SELECT tb[node].name
FROM
rowcons, construct =>
tb[node].son[2] ¬ TreeOps.UpdateList[tb[node].son[2], FindSafens];
all =>
tb[node].son[1] ¬ FindSafens[tb[node].son[1]];
union =>
tb[node].son[2] ¬ TreeOps.UpdateList[tb[node].son[2], FindSafens];
cast, pad =>
tb[node].son[1] ¬ FindSafens[tb[node].son[1]];
safen => {
son1: Tree.Link ¬ tb[node].son[1];
SELECT
TRUE
FROM
ignore, MimP5Stuff.SideEffectFree[son1] =>
No temporary needed
v ¬ FindSafens[son1];
ENDCASE =>
Temporary needed here
v ¬ MimP5S.EvalToTemp[cl, son1];
};
ENDCASE;
};
ENDCASE;
};
nt ¬ TreeOps.UpdateList[t, FindSafens];
};
RealExtend:
PUBLIC
PROC [n: Node, to: BitCount ¬ bitsPerWord]
RETURNS [Node] = {
IF n #
NIL
THEN {
from: INT ¬ n.bits;
IF from < to
THEN {
ext: OperNode ¬ lastRealExtend.oper;
IF ext =
NIL
OR from # lastRealExtend.from
OR to # lastRealExtend.to
THEN {
lastRealExtend.to ¬ to;
lastRealExtend.from ¬ from;
ext ¬ lastRealExtend.oper ¬
RawConvertOp[
srcAc: [kind: real, checked: TRUE, precision: n.bits],
dstAc: [kind: real, checked: TRUE, precision: to]];
};
RETURN [ApplyOp[oper: ext, args: MakeNodeList[n], bits: to]];
};
};
RETURN [n];
};
ReferentType:
PUBLIC
UNSAFE
PROC [type: Type]
RETURNS [Type] =
UNCHECKED {
subType: CSEIndex = MimP5.Normalize[type];
WITH t: seb[subType]
SELECT
FROM
ref => RETURN [t.refType];
ENDCASE => RETURN [Symbols.typeANY];
};
Simplify:
PUBLIC
PROC [cl: CodeList, node: Node]
RETURNS [Node] = {
Returns a simple local or global variable, or a constant, for the original node. Any temps needed are declared in the given code list.
WITH node
SELECT
FROM
const: ConstNode => RETURN [const];
var: Var =>
WITH var.location
SELECT
FROM
local: LocalVarLocation => RETURN [var];
global: GlobalVarLocation => RETURN [var];
field: FieldLocation => {
field.base ¬ Simplify[cl, field.base];
RETURN [var];
};
deref: DerefLocation => {
deref.addr ¬ Simplify[cl, deref.addr];
RETURN [var];
};
index: IndexedLocation => {
index.base ¬ Simplify[cl, index.base];
index.index ¬ Simplify[cl, index.index];
RETURN [var];
};
comp: CompositeLocation => {
FOR each: NodeList ¬ comp.parts, each.rest
WHILE each #
NIL
DO
each.first ¬ Simplify[cl, each.first];
ENDLOOP;
RETURN [var];
};
dummy: DummyLocation =>
RETURN [var];
ENDCASE;
ENDCASE => IF node = NIL THEN RETURN [NIL];
IF node.bits = 0
THEN
ERROR;
We can't simplify what we can't make a temporary for!
TRUSTED {RETURN [MakeTemp[cl: cl, bits: node.bits, init: node].var]};
};
SignExtend:
PUBLIC
PROC [n: Node, to: BitCount ¬ bitsPerWord]
RETURNS [Node] = {
IF n #
NIL
THEN {
from: INT ¬ n.bits;
IF from < to
THEN {
ext: OperNode ¬ lastSignExtend.oper;
IF ext =
NIL
OR from # lastSignExtend.from
OR to # lastSignExtend.to
THEN {
lastSignExtend.to ¬ to;
lastSignExtend.from ¬ from;
ext ¬ lastSignExtend.oper ¬
RawConvertOp[
srcAc: [kind: signed, checked: TRUE, precision: n.bits],
dstAc: [kind: signed, checked: TRUE, precision: to]];
};
RETURN [ApplyOp[oper: ext, args: MakeNodeList[n], bits: to]];
};
};
RETURN [n];
};
TakeField:
PUBLIC
PROC [n: Node, start:
INT, bits:
INT]
RETURNS [Node] = {
base: Node ¬ n;
DO
IF start = 0 AND base.bits = bits THEN RETURN [n];
IF MimP5Stuff.IsCard[base]
THEN {
c: CARD ¬ MimP5Stuff.GetCard[base];
IF (start+bits) > bitsPerWord THEN SIGNAL CantHappen;
c ¬ Basics.BITLSHIFT[c, start]; -- left-justify (& clear left bits)
IF bits < bitsPerWord
THEN
c ¬ Basics.BITRSHIFT[c, bitsPerWord-bits]; -- right-justify (& clear right bits)
RETURN [MakeConstCard[c, bits]];
};
WITH base
SELECT
FROM
v: Var => {
IF bits = v.bits AND start = 0 THEN RETURN [v];
WITH v.location
SELECT
FROM
fLoc: FieldLocation => {
start ¬ start + fLoc.start;
base ¬ fLoc.base;
LOOP;
};
cLoc: CompositeLocation => {
Taking a field of a composite location may involve selecting an element or selecting a subrange of the elements.
pos: INT ¬ 0;
accumHead: NodeList ¬ NIL;
accumTail: NodeList ¬ NIL;
cStart: INT ¬ 0;
cBits: INT ¬ 0;
cBase: Var ¬ NIL;
lim: INT ¬ start+bits;
FOR each: NodeList ¬ cLoc.parts, each.rest
WHILE each #
NIL
DO
e: Node ¬ each.first;
IF e #
NIL
THEN {
eBits: INT ¬ e.bits;
IF eBits > 0
THEN {
eLim: INT = pos + e.bits;
SELECT start
FROM
>= pos => {
The accumulation is either starting or in progress
new: NodeList ¬ NIL;
IF lim <= eLim THEN RETURN [TakeField[e, start-pos, bits]];
IF lim >= pos
AND lim < eLim
THEN
Take a field of the last element
e ¬ TakeField[e, 0, eBits ¬ eLim-lim];
new ¬ MakeNodeList[e];
IF accumTail =
NIL
THEN {cStart ¬ start-pos; accumHead ¬ new}
ELSE accumTail.rest ¬ new;
accumTail ¬ new;
cBits ¬ cBits + eBits;
IF cBits >= bits THEN EXIT;
};
ENDCASE;
pos ¬ eLim;
};
};
ENDLOOP;
IF accumHead = NIL THEN ERROR;
cBase ¬ MakeComposite[accumHead, cBits];
IF cStart = 0 AND cBits = bits THEN RETURN [cBase];
start ¬ cStart;
};
dummy: DummyLocation =>
RETURN [MakeDummy[bits]];
ENDCASE;
};
apply: ApplyNode =>
IF start + bits = n.bits
THEN
WITH apply.proc
SELECT
FROM
oper: OperNode =>
WITH oper.oper
SELECT
FROM
cvt:
REF OperRep.convert => {
org: Node = apply.args.first;
orgBits: INT = org.bits;
fromBits: INT = cvt.from.precision;
toBits: INT = cvt.from.precision;
IF bits = fromBits
AND orgBits = fromBits
AND fromBits <= toBits
THEN
There is no real need to take the field to shorten the expression.
RETURN [org];
};
ENDCASE;
ENDCASE;
ENDCASE;
RETURN [z.
NEW[VarRep ¬ [bits: bits, details: var[location:
z.NEW[LocationRep.field ¬ [field[start: start, base: base]]]
]] ]];
ENDLOOP;
};
TakeFieldVar:
PUBLIC
PROC [n: Node, start:
INT, bits:
INT]
RETURNS [Var] = {
RETURN [NARROW[TakeField[n, start, bits]]];
};
TreeLiteralValue:
PUBLIC
UNSAFE
PROC [t: Tree.Link]
RETURNS [ConstArith.Const] =
UNCHECKED {
DO
WITH e: t
SELECT TreeOps.GetTag[t]
FROM
literal => {
lti: Literals.LTIndex = e.index;
SELECT LiteralOps.Value[lti].class
FROM
unsigned, either => RETURN [ConstArith.FromCard[LiteralOps.ValueCard[lti]]];
signed => RETURN [ConstArith.FromInt[LiteralOps.ValueInt[lti]]];
ENDCASE;
};
subtree =>
SELECT tb[e.index].name
FROM
cast => {t ¬ tb[e.index].son[1]; LOOP};
mwconst => {
res: ConstArith.Const ¬ ConstArith.FromInt[0];
shift: ConstArith.Const ¬ ConstArith.Add[ConstArith.FromCard[CARD.LAST], ConstArith.FromCard[1]];
FOR i:
NAT
IN [1..tb[e.index].nSons]
DO
term: ConstArith.Const ¬ TreeLiteralValue[tb[e.index].son[i]];
res ¬ ConstArith.Add[ConstArith.Mul[res, shift], term];
ENDLOOP;
RETURN [res];
};
ENDCASE;
ENDCASE;
ERROR;
ENDLOOP;
};
TypeForTree:
PUBLIC
UNSAFE
PROC [t: Tree.Link]
RETURNS [Type] =
UNCHECKED {
WITH t
SELECT TreeOps.GetTag[t]
FROM
subtree => RETURN [SymbolOps.ToType[tb[index].info]];
symbol => RETURN [index];
ENDCASE => ERROR;
};
VariantTag:
PUBLIC
UNSAFE
PROC
[type: Type, ctx: Symbols.CTXIndex]
RETURNS [
CARD] =
UNCHECKED {
sei: Type ¬ type;
WHILE sei # nullType
DO
WITH se: seb[sei]
SELECT
FROM
id => {
IF se.idCtx = ctx THEN RETURN [SymbolOps.DecodeCard[se.idValue]];
sei ¬ SymbolOps.DecodeType[se.idInfo];
};
ENDCASE => EXIT;
ENDLOOP;
ERROR
};
WordsForBits:
PUBLIC
PROC [b:
INT]
RETURNS [
INT] = {
RETURN [Basics.BITRSHIFT[b+(Target.bitsPerWord-1), Target.logBitsPerWord]];
};
WordsForOperand:
PUBLIC
UNSAFE PROC [t: Tree.Link]
RETURNS [
INT] =
UNCHECKED {
compute number of words for storing value of tree
RETURN [
WITH t
SELECT TreeOps.GetTag[t]
FROM
literal => 1, -- multiwords will be subtrees ??
symbol => WordsForSei[seb[index].idType],
ENDCASE => WordsForBits[BitsForType[OperandType[t]]]];
};
WordsForSei:
PUBLIC
UNSAFE PROC [sei: Type]
RETURNS [
INT] =
UNCHECKED {
IF sei = nullType THEN RETURN [0];
RETURN [(BitsForType[MimP5.Clarify[sei]]+bitsPerWord-1)/bitsPerWord];
};
ZeroExtend:
PUBLIC
PROC
[n: Node, to: BitCount ¬ bitsPerWord, forceLeft:
BOOL ¬
FALSE]
RETURNS [Node] = {
from: INT ¬ n.bits;
SELECT to
FROM
<= from => {};
No extension needed
> bitsPerWord => {
dummy: Node ¬ MakeDummy[bits: to-from];
nodes: NodeList ¬ IF forceLeft OR to < bitsPerWord
THEN MakeNodeList2[dummy, n]
ELSE MakeNodeList2[n, dummy];
RETURN [MakeComposite[nodes, to]];
};
ENDCASE => {
Use unsigned conversion
ext: OperNode;
IF cachedExtendOp =
NIL
THEN
cachedExtendOp ¬ z.NEW[CachedExtendOpRep];
ext ¬ cachedExtendOp[from];
IF ext =
NIL
THEN {
ext ¬ RawConvertOp[
srcAc: [kind: unsigned, checked: FALSE, precision: n.bits],
dstAc: [kind: unsigned, checked: FALSE, precision: to]];
cachedExtendOp[n.bits] ¬ ext;
};
RETURN [ApplyOp[oper: ext, args: MakeNodeList[n], bits: to]];
};
RETURN [n];
};