MimStore.mesa
Copyright Ó 1985, 1986, 1987, 1988, 1989, 1990, 1991 by Xerox Corporation. All rights reserved.
Sweet, May 31, 1986 5:17:06 pm PDT
Satterthwaite, October 10, 1985 2:11:49 pm PDT
Russ Atkinson (RRA) April 12, 1990 12:26:34 pm PDT
Willie-s, September 24, 1991 4:52 pm PDT
DIRECTORY
Alloc USING [Base, Notifier],
Basics USING [BITRSHIFT],
IntCodeDefs USING [ArithClass, ArithPrecision, BlockNode, IndexedLocation, Location, LocationRep, Node, NodeList, NodeRep, nullVariableId, Var, WordConstNode],
IntCodeUtils USING [NodeListTail, WordToCard],
MimCode USING [BitAddress, BitCount, CodeList, curctxlvl, firstMappedAddress, RegisterNotifier, StoreOptions, VLoc, xtracting, xtractNode, xtractsei, z],
MimP5 USING [All, Clarify, Construct, Exp, Normalize, RowCons, VariantConstruct],
MimP5S USING [Category],
MimP5Stuff USING [Vulnerable],
MimP5U USING [AdjustLoc, AlignmentFromType, ApplyOp, ArithClassForType, Assign, AssignRC, BinaryArithOp, BitsForOperand, BitsForType, BoundsCheck, ConvertOpNode, Deref, Extend, FnField, IsZero, MakeBlock, MakeConstCard, MakeNodeList, MakeTemp, MakeVar, MaybeBlock, MesaOpNode, MoreCode, NewCodeList, NextVar, OperandType, ProcessSafens, RecField, RecOrFnProc, Simplify, TakeField, TakeFieldVar, ZeroExtend],
SymbolOps USING [BitsPerElement, Cardinality, CtxLevel, DecodeInt, FirstCtxSe, NextSe, own],
Symbols USING [Alignment, Base, CBTIndex, ContextLevel, CSEIndex, CTXIndex, ctxType, ISEIndex, ISENull, lG, RecordSEIndex, SEIndex, seType, Type, typeANY],
Target: TYPE MachineParms USING [bitsPerAU, bitsPerByte, bitsPerLongWord, bitsPerRef, bitsPerStringBound, bitsPerWord, logBitsPerWord],
Tree USING [Base, Index, Link, NodeName, NodePtr, Null, treeType],
TreeOps USING [GetNode, GetSe, GetTag, NthSon, OpName, ReverseUpdateList, ScanList, UpdateList];
MimStore: PROGRAM
IMPORTS Basics, IntCodeUtils, MimCode, MimP5, MimP5Stuff, MimP5U, SymbolOps, TreeOps
EXPORTS MimP5S = {
OPEN IntCodeDefs, MimCode, Target;
imported definitions
Category: TYPE = MimP5S.Category;
CBTIndex: TYPE = Symbols.CBTIndex;
CTXIndex: TYPE = Symbols.CTXIndex;
ISEIndex: TYPE = Symbols.ISEIndex;
ISENull: ISEIndex = Symbols.ISENull;
RecordSEIndex: TYPE = Symbols.RecordSEIndex;
Type: TYPE = Symbols.Type;
firstMappedBit: CARD = MimCode.firstMappedAddress*Target.bitsPerAU;
firstMappedWord: CARD = firstMappedBit / Target.bitsPerWord;
procedures
Assign: PUBLIC PROC [node: Tree.Index] RETURNS [l: Node] = {
generates code for assignment statement
l ¬ ComAssign[
t1: tb[node].son[1],
t2: tb[node].son[2],
options: [expr: FALSE, init: tb[node].attr1, counted: tb[node].attr2]];
};
AssignExp: PUBLIC PROC [node: Tree.Index] RETURNS [l: Node] = {
generates code for assignment expression
l ¬ ComAssign[
t1: tb[node].son[1],
t2: tb[node].son[2],
options: [expr: TRUE, init: tb[node].attr1, counted: tb[node].attr2]];
RETURN
};
EvalToTemp: PUBLIC PROC [cl: CodeList, t: Tree.Link] RETURNS [Tree.Link] = {
This routine evaluates the expression given by t into a temporary, with any side effects generating code into cl, and returns a link for the temporary. Of course, we try not to use a temporary if the result will not need one.
IF NOT WillEvalToConst[t, TRUE] THEN {
nb: INT = MimP5U.BitsForOperand[t];
type: Symbols.Type = MimP5U.OperandType[t];
tempSei: ISEIndex = MimP5U.MakeTemp[cl, nb, NIL, type].sei;
temp: Tree.Link = [symbol[tempSei]];
tempVar: Var = NARROW[MimP5.Exp[temp]];
MimP5U.MoreCode[cl, ComAssign[temp, t, [init: TRUE]]];
seb[tempSei].immutable ¬ TRUE;
tempVar.flags[constant] ¬ TRUE;
t ¬ temp;
};
RETURN [t];
};
Temporize: PUBLIC PROC
[cl: CodeList, n: Node, type: Type ¬ Symbols.typeANY] RETURNS [Var] = {
nb: INT = n.bits;
tempSei: ISEIndex = MimP5U.MakeTemp[cl, nb].sei;
temp: Tree.Link = [symbol[tempSei]];
tempVar: Var = NARROW[MimP5.Exp[temp]];
IF tempVar.bits # nb THEN n ¬ EnsureLength[n, type, type, tempVar.bits];
MimP5U.MoreCode[cl, MimP5U.Assign[tempVar, n]];
seb[tempSei].immutable ¬ TRUE;
tempVar.flags[constant] ¬ TRUE;
RETURN [tempVar];
};
ComAssign: PUBLIC PROC [t1, t2: Tree.Link, options: StoreOptions] RETURNS [ret: Node] = {
can support counted assignments
fullBits: INT = MimP5U.BitsForOperand[t1];
nbits: INT ¬ fullBits;
dstType: Symbols.SEIndex = MimP5U.OperandType[t1];
srcType: Symbols.SEIndex = MimP5U.OperandType[t2];
padded: BOOL ¬ FALSE;
lx: Node ¬ NIL;
tail: NodeList ¬ NIL;
lv: Var ¬ NIL;
rv: Node ¬ NIL;
simpleTest: BOOL ¬ FALSE;
tryHarder: BOOL ¬ FALSE;
opName: Tree.NodeName;
srcTree: Tree.Link ¬ Tree.Null;
DO
until we get to something interesting
opName ¬ TreeOps.OpName[t2];
SELECT opName FROM
pad => {
IF MimP5U.BitsForOperand[t2] <= bitsPerWord THEN EXIT;
t2 ¬ TreeOps.NthSon[t2, 1];
padded ¬ TRUE;
nbits ¬ MimP5U.BitsForOperand[t2];
};
cast, safen => t2 ¬ TreeOps.NthSon[t2, 1];
ENDCASE => EXIT;
ENDLOOP;
srcTree ¬ t2;
DO
WITH e: srcTree SELECT TreeOps.GetTag[srcTree] FROM
subtree => IF tb[e.index].name = assignx THEN {srcTree ¬ tb[e.index].son[2]; LOOP};
ENDCASE;
EXIT;
ENDLOOP;
IF srcTree # t2 THEN {
This is an assignment of an assignment expression
recurseAssign: PROC [dst: Tree.Link] = {
WITH e: dst SELECT TreeOps.GetTag[dst] FROM
subtree => {
tp: Tree.NodePtr = @tb[e.index];
IF tp.name = assignx THEN {
node: Tree.Index = e.index;
nopt: StoreOptions ¬ options;
son1: Tree.Link = tp.son[1];
nopt.expr ¬ FALSE;
nopt.init ¬ tp.attr1;
nopt.counted ¬ tp.attr2;
recurseAssign[tp.son[2]]; -- don't use tp after this!
MimP5U.MoreCode[cl, ComAssign[son1, srcTree, nopt]];
};
};
ENDCASE;
};
cl: CodeList ¬ MimP5U.NewCodeList[];
srcTree ¬ EvalToTemp[cl, srcTree];
recurseAssign[t2];
ret ¬ MimP5U.MaybeBlock[cl, ComAssign[t1, srcTree, options]];
RETURN;
};
SELECT TRUE FROM
GlobalLocation[t1] AND options.init => {
options.skipZeros ¬ simpleTest ¬ TRUE;
Note: we assume that all global variables are initially zero!
};
SimpleLocation[t1] AND opName = callx => {
In this case we perform no pre-evaluation of the LHS, so it is OK even if the RHS can affect the LHS address.
srcTree ¬ Tree.Null; -- for breakpoints
};
MimP5Stuff.Vulnerable[t1, t2, TRUE] => {
This evaluation needs a temporary to ensure that the RHS is fully evaluated before the LHS. We try to make up temporaries sparingly: only those parts that induce vulnerability should be put into temporaries.
cl: CodeList ¬ MimP5U.NewCodeList[];
inner: PROC [t: Tree.Link] RETURNS [Tree.Link] = {
WITH e: t SELECT TreeOps.GetTag[t] FROM
subtree =>
SELECT tb[e.index].name FROM
list => RETURN [TreeOps.UpdateList[t, inner]];
construct, union, rowcons => {
tb[e.index].son[2] ¬ inner[tb[e.index].son[2]];
RETURN [t];
};
pad, cast, all => {
tb[e.index].son[1] ¬ inner[tb[e.index].son[1]];
RETURN [t];
};
safen => {
tb[e.index].son[1] ¬ inner[tb[e.index].son[1]];
RETURN [t];
};
ENDCASE;
ENDCASE;
IF MimP5Stuff.Vulnerable[t1, t, TRUE] THEN
This is where we need a temporary
t ¬ EvalToTemp[cl, t];
RETURN [t];
};
temp: Tree.Link ¬ inner[t2];
nopt: StoreOptions ¬ options;
nopt.expr ¬ FALSE;
MimP5U.MoreCode[cl, ComAssign[t1, temp, nopt]];
IF options.expr
THEN ret ¬ MimP5U.MaybeBlock[cl, MimP5.Exp[temp]]
ELSE ret ¬ MimP5U.MakeBlock[cl, 0];
RETURN;
};
ENDCASE;
{
SELECT opName FROM
construct => {
IF nbits > bitsPerWord AND AddressableDest[t1] THEN {
ret ¬ MimP5.Construct[t1, TreeOps.GetNode[t2], options];
GO TO outgoing;
};
rv ¬ MimP5.Construct[Tree.Null, TreeOps.GetNode[t2], []];
};
union => {
ret ¬ MimP5.VariantConstruct[t1, t2, options];
GO TO outgoing;
};
rowcons => {
IF nbits > bitsPerWord AND AddressableDest[t1] THEN {
ret ¬ MimP5.RowCons[t1, TreeOps.GetNode[t2], options];
GO TO outgoing;
};
rv ¬ MimP5.RowCons[Tree.Null, TreeOps.GetNode[t2], []];
};
all => {
ret ¬ MimP5.All[t1, TreeOps.GetNode[t2], options];
GO TO outgoing;
};
ENDCASE =>
rv ¬ MimP5.Exp[t2];
WITH e: t1 SELECT TreeOps.GetTag[t1] FROM
symbol => seb[e.index].idDecl ¬ 0;
Pretend this identifier is defined
ENDCASE;
lx ¬ MimP5.Exp[t1];
{
Find the tail of the possibly complex destination.
x: Node ¬ lx;
DO
WITH x SELECT FROM
block: BlockNode => {
tail ¬ IntCodeUtils.NodeListTail[block.nodes];
x ¬ tail.first;
};
var: Var => {lv ¬ var; EXIT};
ENDCASE => ERROR;
If not a block and not a var we can't do anything
ENDLOOP;
};
IF options.skipZeros AND MimP5U.IsZero[rv] THEN {
Provided that we are not avoiding side effects we can eliminate the zero assign
IF simpleTest THEN {
IF options.expr THEN ret ¬ rv ELSE ret ¬ NIL;
Don't forget to return the proper zero
RETURN [ret];
};
};
IF padded THEN {
IF lv # NIL THEN {
bits: INT = lv.bits;
SELECT bits FROM
<= nbits => {};
<= bitsPerWord => lv ¬ MimP5U.TakeFieldVar[lv, bits-nbits, nbits];
ENDCASE => lv ¬ MimP5U.TakeFieldVar[lv, 0, nbits];
};
IF rv # NIL THEN {
bits: INT = rv.bits;
SELECT bits FROM
<= nbits => {};
<= bitsPerWord => rv ¬ MimP5U.TakeField[rv, bits-nbits, nbits];
ENDCASE => rv ¬ MimP5U.TakeField[rv, 0, nbits];
};
};
IF lv # NIL AND rv # NIL THEN {
If the LHS is a different size than the RHS then we adopt a procrustean solution.
lbits: INT = lv.bits;
rbits: INT = rv.bits;
SELECT lbits FROM
< rbits => {
We have to take a field of the value for the destination, but the full length is still available in a temporary.
start: INT = IF rbits <= bitsPerWord THEN rbits-lbits ELSE 0;
IF options.expr THEN {
The full RHS value is available in a temp after we chop it down to fit into the LHS, since this is an assignment expression. This case is relatively rare, so it doesn't have to be beautiful.
cl: CodeList = MimP5U.NewCodeList[];
temp: Var = Temporize[cl, rv, srcType];
rv ¬ EnsureLength[temp, dstType, srcType, lbits];
MimP5U.MoreCode[cl,
IF options.counted
THEN MimP5U.AssignRC[lv, rv, dstType, options.init]
ELSE MimP5U.Assign[lv, rv]];
ret ¬ MimP5U.MaybeBlock[cl, temp];
IF tail # NIL THEN {tail.first ¬ ret; lx.bits ¬ ret.bits; ret ¬ lx};
There was a complex expression as the LHS (sigh)
RETURN [ret];
};
At this point we don't have to retain the value so just take the field.
rv ¬ MimP5U.TakeField[rv, start, lbits];
nbits ¬ lbits;
};
> rbits => {
The destination is larger, so extend the value.
rv ¬ ExtendValue[rv, dstType, srcType, lbits];
nbits ¬ lbits;
};
ENDCASE;
};
SELECT TRUE FROM
options.expr => {
cl: CodeList ¬ MimP5U.NewCodeList[];
res: Node ¬ NIL;
{
In this block we try to determine the right place to get the resulting value from. We try for the simpler of the lhs or rhs, but if rhs is non-constant and there may be side effects in lhs or neither is sufficiently simple, we go to use a temporary.
rCat: Category = GetCategory[rv];
lCat: Category = GetCategory[lv];
IF rCat < local THEN GO TO useRHS;
IF lCat # other THEN
IF rCat < lCat THEN GO TO useRHS ELSE GO TO useLHS;
res ¬ Temporize[cl, rv, srcType];
rv ¬ res;
IF lv.bits # rv.bits THEN
rv ¬ EnsureLength[rv, dstType, srcType, lv.bits];
EXITS
useRHS => res ¬ rv;
useLHS => res ¬ lv;
};
IF options.counted
THEN ret ¬ MimP5U.AssignRC[lv, rv, dstType, options.init]
ELSE ret ¬ MimP5U.Assign[lv, rv];
MimP5U.MoreCode[cl, ret];
ret ¬ MimP5U.MaybeBlock[cl, res];
nbits ¬ ret.bits;
};
options.counted =>
ret ¬ MimP5U.AssignRC[lv, rv, dstType, options.init];
ENDCASE =>
ret ¬ MimP5U.Assign[lv, rv];
IF tail # NIL THEN {
There was a complex expression as the LHS (sigh)
tail.first ¬ ret;
ret ¬ lx;
IF NOT options.expr THEN ret.bits ¬ 0;
};
EXITS outgoing => {};
};
};
ManySafens: PROC [t: Tree.Link, nbits: CARDINAL] RETURNS [BOOL] = {
nFields, nSafens: NAT ¬ 0;
noAll: BOOL ¬ TRUE;
CountSafens: PROC [t: Tree.Link] = {
SELECT TreeOps.OpName[t] FROM
rowcons, construct, union => TreeOps.ScanList[TreeOps.NthSon[t, 2], CountSafens];
all => { noAll ¬ FALSE; CountSafens[TreeOps.NthSon[t, 1]] };
cast, pad => CountSafens[TreeOps.NthSon[t, 1]];
safen => { nSafens ¬ nSafens+1; nFields ¬ nFields+1 };
ENDCASE => nFields ¬ nFields+1;
};
CountSafens[t];
RETURN [IF nbits<16*bitsPerWord
THEN (nSafens >= 2)
ELSE (noAll AND 2*nSafens > nFields)]
};
Extract: PUBLIC PROC [node: Tree.Index] RETURNS [Node] = {
cl: CodeList ¬ MimP5U.NewCodeList[];
[] ¬ ExtractToCl[cl, node];
RETURN [MimP5U.MakeBlock[cl]];
};
ExtractToCl: PROC [cl: CodeList, node: Tree.Index] RETURNS [Node] = {
t1: Tree.Link = tb[node].son[1];
tsei: RecordSEIndex = LOOPHOLE[MimP5U.OperandType[t1]];
t2: Tree.Link = tb[node].son[2];
vType: Type = MimP5U.OperandType[t2];
sn: Node ¬ MimP5.Exp[t2];
IF NOT SimpleLocation[t2] THEN
sn ¬ MimP5U.MakeTemp[cl, sn.bits, sn, vType].var;
ExtractFrom[cl, t1, tsei, sn];
RETURN [sn];
};
ExtractExp: PUBLIC PROC [node: Tree.Index] RETURNS [Node] = {
cl: CodeList ¬ MimP5U.NewCodeList[];
sn: Node = ExtractToCl[cl, node];
RETURN [MimP5U.MaybeBlock[cl, sn]];
};
ExtractFrom: PROC [cl: CodeList, t1: Tree.Link, tsei: RecordSEIndex, sourceNode: Node] = {
saveExtractState: RECORD [xtracting: BOOL, xtractNode: Node, xtractsei: Symbols.ISEIndex] =
[MimCode.xtracting, MimCode.xtractNode, MimCode.xtractsei];
fa: MimP5U.RecOrFnProc = IF seb[tsei].argument THEN MimP5U.FnField ELSE MimP5U.RecField;
startsei: ISEIndex = SymbolOps.FirstCtxSe[SymbolOps.own, seb[tsei].fieldCtx];
sei: ISEIndex ¬ startsei;
isei: ISEIndex ¬ startsei;
node: Tree.Index = TreeOps.GetNode[t1];
totalBits: INT;
SExtract: PROC [node: Tree.Index] = {
t1: Tree.Link = tb[node].son[1];
tsei: RecordSEIndex = LOOPHOLE[MimP5U.OperandType[t1]];
ExtractFrom[cl, t1, tsei, MimP5.Exp[tb[node].son[2]]];
};
ExtractItem: PROC [t: Tree.Link] RETURNS [v: Tree.Link] = {
posn: BitAddress;
size: INT;
v ¬ t;
[posn, size] ¬ fa[sei];
IF t # Tree.Null THEN {
subNode: Tree.Index = TreeOps.GetNode[t];
vl: VLoc ¬ [disp: posn, size: size];
IF fa # MimP5U.FnField AND totalBits <= bitsPerWord THEN
vl ¬ MimP5U.AdjustLoc[vl: vl, rSei: tsei, fSei: sei, tBits: totalBits];
MimCode.xtractNode ¬ MimP5U.TakeField[sourceNode, vl.disp, vl.size];
MimCode.xtractsei ¬ sei;
SELECT tb[subNode].name FROM
assign => MimP5U.MoreCode[cl, Assign[subNode]];
extract => SExtract[subNode];
ENDCASE => ERROR;
};
{
Find the previous sei (start at beginning, run up to just before this one)
ssei: ISEIndex ¬ startsei;
psei: ISEIndex ¬ MimP5U.NextVar[ssei];
rsei: ISEIndex ¬ psei;
UNTIL psei = sei DO
rsei ¬ psei;
psei ¬ MimP5U.NextVar[SymbolOps.NextSe[SymbolOps.own, psei]];
ENDLOOP;
sei ¬ rsei;
};
};
xlist: Tree.Link ¬ tb[node].son[1];
UNTIL (isei ¬ SymbolOps.NextSe[SymbolOps.own, sei]) = ISENull DO
isei ¬ MimP5U.NextVar[isei];
IF isei = ISENull THEN EXIT;
sei ¬ isei;
ENDLOOP;
totalBits ¬ sourceNode.bits;
MimCode.xtracting ¬ TRUE;
tb[node].son[1] ¬ TreeOps.ReverseUpdateList[xlist, ExtractItem];
[MimCode.xtracting, MimCode.xtractNode, MimCode.xtractsei] ¬ saveExtractState;
};
EnsureLength: PROC [rv: Node, dstType, srcType: Type, bits: INT] RETURNS [Node] = {
rbits: INT = rv.bits;
SELECT rbits FROM
> bits => {
We have to take a field of the value for the destination.
start: INT ¬ IF rbits <= bitsPerWord THEN rbits-bits ELSE 0;
rv ¬ MimP5U.TakeField[rv, start, bits];
};
< bits => {
The destination is larger, so extend the value. If arithmetic or address extension, then use the conversion operators.
rv ¬ ExtendValue[rv, dstType, srcType, bits];
};
ENDCASE;
RETURN [rv];
};
GlobalLocation: PROC [t: Tree.Link] RETURNS [BOOL] = {
DO
WITH e: t SELECT TreeOps.GetTag[t] FROM
symbol => {
sei: ISEIndex ¬ e.index;
ctx: CTXIndex ¬ seb[sei].idCtx;
level: Symbols.ContextLevel ¬ SymbolOps.CtxLevel[SymbolOps.own, ctx];
SELECT level FROM
Symbols.lG => RETURN [TRUE];
ENDCASE => RETURN [FALSE];
};
subtree => {
tp: Tree.NodePtr = @tb[e.index];
SELECT tp.name FROM
dollar, cast => {t ¬ tp.son[1]; LOOP};
ENDCASE;
};
ENDCASE;
RETURN [FALSE];
ENDLOOP;
};
SimpleLocation: PROC [t: Tree.Link] RETURNS [BOOL] = {
DO
WITH t SELECT TreeOps.GetTag[t] FROM
symbol => {
sei: ISEIndex ¬ index;
ctx: CTXIndex ¬ seb[sei].idCtx;
level: Symbols.ContextLevel ¬ SymbolOps.CtxLevel[SymbolOps.own, ctx];
SELECT level FROM
Symbols.lG, MimCode.curctxlvl => RETURN [TRUE];
ENDCASE => RETURN [FALSE];
};
subtree => {
tp: Tree.NodePtr = @tb[index];
SELECT tp.name FROM
dot, uparrow, dollar, cast => {t ¬ tp.son[1]; LOOP};
ENDCASE;
};
ENDCASE;
RETURN [FALSE];
ENDLOOP;
};
AddressableDest: PROC [t: Tree.Link] RETURNS [BOOL] = {
Returns TRUE if the given tree names an addressable destination.
offset: CARD ¬ 0;
DO
WITH t SELECT TreeOps.GetTag[t] FROM
symbol => {
sei: ISEIndex = index;
ctx: CTXIndex = seb[sei].idCtx;
level: Symbols.ContextLevel = SymbolOps.CtxLevel[SymbolOps.own, ctx];
IF level < Symbols.lG THEN RETURN [FALSE];
offset ¬ offset + MimP5U.RecField[sei].offset;
};
subtree => {
tp: Tree.NodePtr = @tb[index];
SELECT tp.name FROM
uparrow, reloc => {};
index => {
arrayType: Symbols.CSEIndex = MimP5U.OperandType[tp.son[1]];
WITH a: seb[arrayType] SELECT FROM
array => {
grain: CARD = SymbolOps.BitsPerElement[SymbolOps.own, a.componentType, a.packed];
IF grain < bitsPerWord THEN RETURN [FALSE];
};
ENDCASE => ERROR;
};
dindex => {
arrayDType: Symbols.CSEIndex = MimP5.Normalize[MimP5U.OperandType[tp.son[1]]];
arrayType: Symbols.CSEIndex =
WITH seb[arrayDType] SELECT FROM
arraydesc => MimP5.Clarify[describedType],
ENDCASE => ERROR;
WITH a: seb[arrayType] SELECT FROM
array => {
grain: CARD = SymbolOps.BitsPerElement[SymbolOps.own, a.componentType, a.packed];
IF grain < bitsPerWord THEN RETURN [FALSE];
};
ENDCASE => ERROR;
};
seqindex => {
seqType: Symbols.CSEIndex = MimP5U.OperandType[tp.son[1]];
WITH ss: seb[seqType] SELECT FROM
sequence => {
grain: CARD = SymbolOps.BitsPerElement[SymbolOps.own, ss.componentType, ss.packed];
IF grain < bitsPerWord THEN RETURN [FALSE];
};
ENDCASE => RETURN [FALSE];
};
dot => {
sei: ISEIndex = TreeOps.GetSe[tp.son[2]];
offset ¬ offset + MimP5U.RecField[sei].offset;
};
dollar => {
sei: ISEIndex = TreeOps.GetSe[tp.son[2]];
offset ¬ offset + MimP5U.RecField[sei].offset;
t ¬ tp.son[1];
LOOP;
};
cast => {t ¬ tp.son[1]; LOOP};
ENDCASE => RETURN [FALSE];
};
ENDCASE => RETURN [FALSE];
IF offset MOD bitsPerWord = 0 THEN RETURN [TRUE];
RETURN [FALSE];
ENDLOOP;
};
GetCategory: PUBLIC SAFE PROC [n: Node] RETURNS [Category] = CHECKED {
DO
WITH n SELECT FROM
const: REF NodeRep.const => RETURN [constant];
nv: Var => WITH nv.location SELECT FROM
nvLoc: REF LocationRep.localVar =>
IF nv.flags[constant] THEN RETURN [constLocal] ELSE RETURN [local];
nvGlob: REF LocationRep.globalVar =>
IF nv.flags[constant] THEN RETURN [constGlobal] ELSE RETURN [global];
nvField: REF LocationRep.field => n ¬ nvField.base;
ENDCASE => EXIT;
ENDCASE => EXIT;
ENDLOOP;
RETURN [other];
};
WillEvalToConst: PUBLIC PROC [t: Tree.Link, noLocals: BOOL] RETURNS [BOOL] = {
tt: Tree.Link ¬ t;
DO
WITH e: tt SELECT TreeOps.GetTag[tt] FROM
subtree => {
tp: Tree.NodePtr = @tb[e.index];
start: NAT ¬ 1;
stop: NAT ¬ tp.nSons;
SELECT tp.name FROM
construct, rowcons => start ¬ 2;
all, union, cast, pad, list, lengthen, shorten => {};
mwconst => RETURN [TRUE];
ENDCASE => RETURN [FALSE];
IF start = stop THEN {tt ¬ tp.son[start]; LOOP};
FOR i: NAT IN [start..stop] DO
IF NOT WillEvalToConst[tp.son[i], noLocals] THEN RETURN [FALSE];
ENDLOOP;
RETURN [TRUE];
};
symbol => {
IF seb[e.index].immutable THEN {
IF noLocals THEN {
ctx: CTXIndex ¬ seb[e.index].idCtx;
IF ctxb[ctx].level > Symbols.lG THEN RETURN [FALSE];
IF seb[e.index].idDecl # 2 THEN RETURN [FALSE];
See MimDriver.CollectConstants
};
RETURN [TRUE];
};
RETURN [FALSE];
};
literal => RETURN [TRUE];
string => RETURN [TRUE];
ENDCASE;
ENDLOOP;
};
formerly in Address
operations
Index: PUBLIC PROC [node: Tree.Index] RETURNS [Node] = {
generates code for array indexing
arrayType: Symbols.CSEIndex = MimP5U.OperandType[tb[node].son[1]];
grain: BitCount ¬ 0;
tBits: BitCount ¬ 0;
packed: BOOL;
indexRange: INT;
ind: IndexedLocation;
cl: CodeList ¬ MimP5U.NewCodeList[];
an: Node ¬ MimP5.Exp[MimP5U.ProcessSafens[cl, tb[node].son[1]]];
index: Node = MimP5.Exp[MimP5U.ProcessSafens[cl, tb[node].son[2]]];
WITH a: seb[arrayType] SELECT FROM
array => {
grain ¬ SymbolOps.BitsPerElement[SymbolOps.own, a.componentType, a.packed];
packed ¬ grain < bitsPerWord;
indexRange ¬ SymbolOps.Cardinality[SymbolOps.own, a.indexType];
tBits ¬ indexRange*grain;
WITH index SELECT FROM
wc2: WordConstNode => {};
ENDCASE => GO TO bailOut;
WITH an SELECT FROM
const: WordConstNode => {
Both array and index are constant, so we can have a constant result.
unsignedClass: IntCodeDefs.ArithClass = [unsigned, FALSE, Target.bitsPerLongWord];
wc: Node = MimP5U.MakeConstCard[IntCodeUtils.WordToCard[const.word]];
shift: Node = MimP5U.BinaryArithOp[
sub, unsignedClass,
MimP5U.MakeConstCard[tBits-grain],
MimP5U.BinaryArithOp[
mul, unsignedClass,
MimP5U.MakeConstCard[grain],
index]];
power: Node = MimP5U.BinaryArithOp[pow, unsignedClass,
MimP5U.MakeConstCard[2], shift];
mod: Node = MimP5U.BinaryArithOp[mod, unsignedClass, const, power];
RETURN [MimP5U.TakeField[mod, mod.bits-grain, grain]];
};
ENDCASE;
EXITS bailOut => {};
};
ENDCASE => ERROR;
IF packed AND tBits IN (0..bitsPerWord) AND tBits < an.bits THEN
an ¬ MimP5U.TakeField[an, an.bits-tBits, tBits];
ind ¬ z.NEW[LocationRep.indexed ¬ [indexed[base: an, index: index]]];
RETURN [MimP5U.MaybeBlock[cl,
MimP5U.MakeVar[bits: grain, id: nullVariableId, loc: ind]]];
};
DIndex: PUBLIC PROC [node: Tree.Index] RETURNS [Node] = {
generates code for indexing from an array descriptor
arrayDType: Symbols.CSEIndex = MimP5.Normalize[MimP5U.OperandType[tb[node].son[1]]];
arrayType: Symbols.CSEIndex =
WITH seb[arrayDType] SELECT FROM
arraydesc => MimP5.Clarify[describedType],
ENDCASE => ERROR;
align: Symbols.Alignment ¬ MimP5U.AlignmentFromType[arrayType];
grain: BitCount ¬ 0;
nilck: BOOL = tb[node].attr1;
bndck: BOOL = tb[node].attr3;
cl: CodeList ¬ MimP5U.NewCodeList[];
desc: Node ¬ MimP5.Exp[MimP5U.ProcessSafens[cl, tb[node].son[1]]];
base: Node ¬ NIL;
index: Node ¬ MimP5.Exp[MimP5U.ProcessSafens[cl, tb[node].son[2]]];
WITH a: seb[arrayType] SELECT FROM
array =>
grain ¬ SymbolOps.BitsPerElement[SymbolOps.own, a.componentType, a.packed];
ENDCASE => ERROR;
IF bndck THEN desc ¬ MimP5U.Simplify[cl, desc];
To avoid excessive evaluation of the descriptor, make sure that it is someplace "simple" when we have to perform an extra access to get the bound.
base ¬ MimP5U.TakeField[desc, 0, bitsPerRef];
IF nilck THEN {
Generate a NIL check unless we can show that the described array can't be so large as to get beyond the first mapped bit.
aBits: CARD = MimP5U.BitsForType[arrayType];
IF aBits >= firstMappedBit THEN
base ¬ MimP5U.ApplyOp[
oper: MimP5U.MesaOpNode[nilck],
args: MimP5U.MakeNodeList[base],
bits: bitsPerRef];
};
IF bndck THEN {
bound: Node = MimP5U.TakeField[desc, bitsPerRef, bitsPerWord];
index ¬ MimP5U.BoundsCheck[index, bound];
};
{
ind: Location = z.NEW[LocationRep.indexed ¬ [indexed[
base: MimP5U.Deref[base, 0, align], index: index]]];
RETURN [MimP5U.MaybeBlock[cl,
MimP5U.MakeVar[bits: grain, id: nullVariableId, loc: ind]]];
};
};
WordOffset: PROC [sei: ISEIndex] RETURNS [INT] = {
val: INT = SymbolOps.DecodeInt[seb[sei].idValue];
RETURN [Basics.BITRSHIFT[val, Target.logBitsPerWord]];
};
SeqIndex: PUBLIC PROC [node: Tree.Index] RETURNS [Node] = {
t1: Tree.Link ¬ tb[node].son[1];
seqType: Symbols.CSEIndex = MimP5U.OperandType[t1];
isString: BOOL ¬ FALSE;
grain: BitCount;
bndck: BOOL = tb[node].attr3;
index, elements, tag: Node;
ind: Location;
cl: CodeList ¬ MimP5U.NewCodeList[];
tb[node].son[1] ¬ t1 ¬ MimP5U.ProcessSafens[cl, t1];
WITH ss: seb[seqType] SELECT FROM
array => {
isString ¬ TRUE;
grain ¬ Target.bitsPerByte;
};
sequence => {
grain ¬ SymbolOps.BitsPerElement[SymbolOps.own, ss.componentType, ss.packed];
IF bndck THEN {
We can (probably) use the bounds check to avoid the NIL check
(see MimExpr.DotOrUparrow)
tt: Tree.Link ¬ t1;
wordOffset: CARD = WordOffset[ss.tagSei];
DO
SELECT TreeOps.OpName[tt] FROM
dollar => {tt ¬ TreeOps.NthSon[tt, 1]; LOOP};
dot, uparrow =>
IF wordOffset < firstMappedWord THEN
tb[TreeOps.GetNode[tt]].attr1 ¬ FALSE;
ENDCASE;
EXIT;
ENDLOOP;
};
};
ENDCASE => ERROR;
elements ¬ MimP5.Exp[t1];
IF isString
THEN {
tag ¬ MimP5U.TakeField[elements, -bitsPerStringBound, bitsPerStringBound];
}
ELSE {
The symbol table entry for the sequence part points to the tag (if any). If there is no tag (i.e., a COMPUTED sequence), it still points ahead of the sequence part. If one adds the size of this node to its location, one gets a node pointing to the beginning of the sequence part.
tag ¬ elements;
elements ¬ MimP5U.TakeField[tag, tag.bits, 0];
};
index ¬ MimP5.Exp[tb[node].son[2]];
IF bndck THEN {
This case is taken when we do bounds checking. If the sequence base is not simple enough we have to evaluate it into a temporary to keep it from changing while we check the bounds and then index the sequence.
addr: Node ¬ NIL;
offset: INT ¬ 0;
index ¬ MimP5U.Simplify[cl, index];
Simplify the index expression so we get rid of any potential side-effects before trying to evaluate the sequence.
WITH tag SELECT FROM
eVar: Var => WITH eVar.location SELECT FROM
field: REF LocationRep.field => WITH field.base SELECT FROM
fVar: Var => WITH fVar.location SELECT FROM
deref: REF LocationRep.deref => {offset ¬ field.start; addr ¬ deref.addr};
ENDCASE;
ENDCASE;
deref: REF LocationRep.deref => addr ¬ deref.addr;
ENDCASE;
ENDCASE;
IF addr # NIL THEN {
The base of the sequence address should be evaluated once, rather than twice, provided that it makes some sense to do so. If we succeed here, then we don't have to further simplify, because we have only evaluated the elements and the bounds once!
IF GetCategory[addr] <= local THEN GO TO takeBoundsCheck;
For now we only trust local variables to not change over the bounds check operation. Perhaps even this is too trusting. Global variables can change due to multi-process code. Local variables should only change
addr ¬ Temporize[cl, addr];
Force the address into a temporary, since we will need it twice.
tag ¬ MimP5U.Deref[addr, tag.bits, MimP5U.AlignmentFromType[seqType]];
IF offset # 0 THEN
tag ¬ MimP5U.TakeField[tag, offset, tag.bits];
elements ¬ MimP5U.TakeField[tag, tag.bits, 0];
The sequence elemtns are assumed to start right after the sequence length
GO TO takeBoundsCheck;
};
At this point we don't have an especially simple sequence based on an address, and we have to do a bounds check, so we have to simplify the tag (and elements) expressions to make the extra evaluation have no side effects.
tag ¬ MimP5U.Simplify[cl, tag];
elements ¬ MimP5U.TakeField[tag, tag.bits, 0];
GO TO takeBoundsCheck;
EXITS takeBoundsCheck =>
index ¬ MimP5U.BoundsCheck[index, tag];
};
ind ¬ z.NEW[LocationRep.indexed ¬ [indexed[base: elements, index: index]]];
RETURN [MimP5U.MaybeBlock[cl,
MimP5U.MakeVar[bits: grain, id: nullVariableId, loc: ind]]];
};
ExtendValue: PUBLIC PROC [node: Node, dstType, srcType: Symbols.Type, bits: INT]
RETURNS [Node] = {
Extends the given value according to the assumed source and destination types. If they are not arithmetic, then assume the given # of bits.
nBits: INT = node.bits;
srcAc: ArithClass ¬ MimP5U.ArithClassForType[srcType];
IF bits > Target.bitsPerWord*2 THEN RETURN [MimP5U.ZeroExtend[node, bits]];
IF srcAc.kind # lastExtension AND bits <= IntCodeDefs.ArithPrecision.LAST
THEN {
dstAc: ArithClass ¬ MimP5U.ArithClassForType[dstType];
IF dstAc.precision # bits THEN dstAc.precision ¬ bits;
IF dstAc.kind = lastExtension THEN dstAc.kind ¬ srcAc.kind;
If someone is playing fast and loose with LOOPHOLE or UNSPECIFIED we try to preserve the class of the source (because we can't think of anything more reasonable to do).
SELECT INT[srcAc.precision] FROM
< nBits => srcAc.precision ¬ nBits;
> nBits => {
If we are extending a field that can't have the sign bit on, force it to be unsigned
srcAc.precision ¬ nBits;
IF srcAc.kind = signed THEN srcAc.kind ¬ unsigned;
IF dstAc.kind = signed THEN dstAc.kind ¬ unsigned;
};
ENDCASE;
IF srcAc # dstAc THEN
node ¬ MimP5U.ApplyOp[
MimP5U.ConvertOpNode[from: srcAc, to: dstAc],
MimP5U.MakeNodeList[node],
bits];
}
ELSE
In the non-arithmetic case we extend without looking at the destination
IF nBits < bits THEN node ¬ MimP5U.Extend[node, bits, srcType];
RETURN [node];
};
bases & notifier
tb: Tree.Base ¬ NIL;  -- tree base (local copy)
seb: Symbols.Base ¬ NIL;  -- semantic entry base (local copy)
ctxb: Symbols.Base ¬ NIL; -- context entry base (local copy)
StoreNotify: PUBLIC Alloc.Notifier = {
called by allocator whenever table area is repacked
seb ¬ base[Symbols.seType];
ctxb ¬ base[Symbols.ctxType];
tb ¬ base[Tree.treeType];
};
MimCode.RegisterNotifier[StoreNotify];
}.