[_CDCSL_93-16_]<1>Cedar>release>MimosaOnly>MimCons.mesa

MimCons.mesa

Sweet, May 30, 1986 3:50:06 pm PDT

Satterthwaite, March 27, 1986 9:15:18 am PST

Russ Atkinson (RRA) May 13, 1991 11:19 pm PDT

Willie-s, September 24, 1991 4:43 pm PDT

DIRECTORY

Alloc USING [Base, Notifier],

Basics USING [BITLSHIFT, LowHalf],

IntCodeDefs USING [ArithClass, ConstNode, Count, Location, LocationRep, Node, NodeList, NodeRep, Var],

IntCodeStuff USING [GenDummy],

LiteralOps USING [IsShort, ValueBits],

Literals USING [LTIndex],

MimCode USING [BitAddress, BitCount, CodeList, ConsDestination, nC0, RegisterNotifier, StoreOptions, VLoc],

MimData USING [worstAlignment],

MimP5 USING [Clarify, CountedAllocate, Exp, ZoneOp],

MimP5S USING [Temporize],

MimP5Stuff USING [IsCard, IsSimpleVar, MakeConsBlock],

MimP5U USING [Address, AdjustLoc, AlignmentFromTree, ApplyOp, Assign, AssignRC, BinaryArithOp, BitsForOperand, BitsForType, Deref, Extend, FnField, IsZero, MakeArgList2, MakeBlock, MakeConstCard, MakeConstInt, MakeNodeList, MakeTemp, MesaOpNode, MoreCode, NewCodeList, NextVar, OperandType, ProcessSafens, RecField, RecOrFnProc, Simplify, TakeField, TakeFieldVar, TypeForTree, WordsForSei, ZeroExtend],

SymbolOps USING [BitsPerElement, Cardinality, DecodeCard, FirstCtxSe, NextSe, own, RecordRoot, ReferentType, VariantField],

Symbols USING [Alignment, ArraySEIndex, Base, ContextLevel, CSEIndex, CTXIndex, ISEIndex, ISENull, ISEPointer, lG, lZ, RecordSEIndex, SEIndex, seType, Type, typeANY],

Target: TYPE MachineParms USING [bitsPerAU, bitsPerChar, bitsPerLongWord, bitsPerRef, bitsPerWord],

Tree USING [Base, Index, Info, Link, NodeName, NodePtr, Null, Scan, treeType],

TreeOps USING [GetNode, GetSe, GetTag, NthSon, OpName, ScanList];

MimCons: PROGRAM

IMPORTS Basics, IntCodeStuff, LiteralOps, MimCode, MimData, MimP5, MimP5S, MimP5Stuff, MimP5U, SymbolOps, TreeOps

EXPORTS MimP5 = {

OPEN MimCode, IntCodeDefs;

Options

allConstructorTrigger: NAT ¬ 4;

Any ALL constructor needing this many full words gets done as a primitive constructor, otherwise it gets done by separate assignments.

useExtraSafens: BOOL ¬ TRUE;

When source & destination appear to overlap, try to be extra safe (AR 1036)

target definitions

bitsPerChar: NAT = Target.bitsPerChar;

bitsPerLongWord: NAT = Target.bitsPerLongWord;

bitsPerPtr: NAT = Target.bitsPerRef;

bitsPerRef: NAT = Target.bitsPerRef;

bitsPerAU: NAT = Target.bitsPerAU;

bitsPerWord: NAT = Target.bitsPerWord;

unitsPerWord: NAT = Target.bitsPerWord / Target.bitsPerAU;

imported definitions

ArraySEIndex: TYPE = Symbols.ArraySEIndex;

ContextLevel: TYPE = Symbols.ContextLevel;

CSEIndex: TYPE = Symbols.CSEIndex;

CTXIndex: TYPE = Symbols.CTXIndex;

ISEIndex: TYPE = Symbols.ISEIndex;

ISENull: ISEIndex = Symbols.ISENull;

lZ: ContextLevel = Symbols.lZ;

lG: ContextLevel = Symbols.lG;

RecordSEIndex: TYPE = Symbols.RecordSEIndex;

SEIndex: TYPE = Symbols.SEIndex;

typeANY: CSEIndex = Symbols.typeANY; -- don't-care type for ConsAssign

unsignedClass: IntCodeDefs.ArithClass ¬ [unsigned, FALSE, bitsPerLongWord];

conversion hacks

TreeType: PROC [node: Tree.Index] RETURNS [Symbols.Type] = INLINE {

RETURN [LOOPHOLE[tb[node].info]];

};

IgnoreSafen: PROC [t: Tree.Link] RETURNS [BOOL] = INLINE {

RETURN [t = Tree.Null OR TreeOps.GetTag[t] = symbol];

};

state data and common code for construction

cd: PUBLIC ConsDestination;

SetConsDest: PROC [t: Tree.Link, cl: CodeList] = {

align: Symbols.Alignment ¬ MimP5U.AlignmentFromTree[t];

n: Node ¬ MimP5.Exp[t];

bits: INT ¬ n.bits;

nn: Node ¬ n;

tv: Var ¬ NIL;

derefOK: BOOL ¬ TRUE;

cd.cl ¬ cl;

WITH nn SELECT FROM

v: Var => {

For long constructors we may want to have a temporary, provided that it is worth while to take the address of the goody in question (should be out of the local frame, or multiply dereferenced).

WITH v.location SELECT FROM

field: REF LocationRep.field => {nn ¬ field.base; LOOP};

indexed: REF LocationRep.indexed => {

Only the simplest indexing can avoid using a temp

IF NOT MimP5Stuff.IsCard[indexed.index] THEN GO TO useTemp;

nn ¬ indexed.base;

LOOP;

};

deref: REF LocationRep.deref => {

Is there anything to do about alignment?

IF NOT derefOK THEN GO TO useTemp;

nn ¬ deref.addr;

derefOK ¬ FALSE;

LOOP;

};

global: REF LocationRep.globalVar =>

IF NOT derefOK THEN GO TO useTemp;

ENDCASE;

cd.destNode ¬ n;

RETURN;

EXITS useTemp => {};

};

ENDCASE;

tv ¬ MimP5S.Temporize[cl: cl, n: MimP5U.Address[n]];

cd.destNode ¬ MimP5U.Deref[tv, n.bits, align];

RETURN;

ENDLOOP;

};

AssureSize: PROC [n: Node, size: IntCodeDefs.Count] RETURNS [Node] = {

nBits: INT ¬ n.bits;

SELECT size FROM

> nBits => RETURN [MimP5U.ZeroExtend[n: n, to: size]];

< nBits => {

start: INT ¬ IF nBits > bitsPerWord THEN 0 ELSE nBits-size;

RETURN [MimP5U.TakeField[n, start, size]];

};

ENDCASE => RETURN [n];

};

ConsAssign: PROC [type: CSEIndex, offset: VLoc, n: Node] = {

field: Var ¬ MimP5U.TakeFieldVar[cd.destNode, offset.disp, offset.size];

node: Node ¬ NIL;

IF cd.options.skipZeros AND MimP5U.IsZero[n] THEN RETURN;

n ¬ AssureSize[n, offset.size];

IF cd.options.counted

THEN

The variable needs to have its rcMap set

node ¬ MimP5U.AssignRC[lhs: field, rhs: n, type: type, init: cd.options.init]

ELSE

No funny business with the assign

node ¬ MimP5U.Assign[lhs: field, rhs: n];

IF node # NIL THEN MimP5U.MoreCode[cd.cl, node];

};

main drivers

MainConstruct: PROC
[maint: Tree.Link, rSei: CSEIndex, fa: MimP5U.RecOrFnProc,
total: VLoc, fieldSei: ISEIndex ¬ ISENull] = {

workhorse subroutine for construction in memory

AssignField: PROC [root: Tree.Link] = {

offset: VLoc ¬ [lastStart, 0];

rep: BitAddress;

res: BitCount;

[rep, res] ¬ fa[fieldSei];

IF res # 0 THEN {

fieldType: CSEIndex = MimP5.Clarify[seb[fieldSei].idType];

rootName: Tree.NodeName;

lim: INT;

offset.disp ¬ tOffset.disp + rep;

offset.size ¬ res;

IF adjustOffset THEN

offset ¬ MimP5U.AdjustLoc[vl: offset, rSei: rcSei, fSei: fieldSei, tBits: totalBits];

IF offset.disp >= limit THEN {

This is a funny case (associated with sequences?)

res ¬ 0; -- useful for breakpoints

GO TO doneWithField;

};

until we get to something interesting

rootName ¬ TreeOps.OpName[root];

SELECT rootName FROM

pad => {

son: Tree.Link = TreeOps.NthSon[root, 1];

sonBits: INT = MimP5U.BitsForOperand[son];

IF sonBits < bitsPerWord THEN EXIT;

root ¬ son;

offset.size ¬ sonBits;

};

cast => root ¬ TreeOps.NthSon[root, 1];

ENDCASE => EXIT;

ENDLOOP;

IF offset.disp < minDisp THEN minDisp ¬ offset.disp;

lim ¬ offset.disp+offset.size;

IF lim > maxDisp THEN maxDisp ¬ lim;

SELECT rootName FROM

construct => MainConstruct[
TreeOps.NthSon[root, 2], MimP5U.OperandType[root],
MimP5U.RecField, offset, ISENull];

union => UnionConstruct[TreeOps.GetNode[root], rcSei, tOffset];

rowcons => Row[TreeOps.GetNode[root], offset];

all => [] ¬ AllConstruct[TreeOps.GetNode[root], offset];

ENDCASE => {

expr: Node ¬ IF root = Tree.Null
THEN IntCodeStuff.GenDummy[offset.size]
ELSE MimP5.Exp[root];

ConsAssign[fieldType, offset, expr];

};

EXITS doneWithField => {};

};

lastStart ¬ offset.disp;

fieldSei ¬ MimP5U.NextVar[SymbolOps.NextSe[SymbolOps.own, fieldSei]];

};

tOffset: VLoc ¬ total;

totalBits: INT = total.size;

lastStart: INT ¬ total.disp;

rcSei: RecordSEIndex ¬ ToRecordSE[rSei];

recBits: INT ¬ MIN[MimP5U.BitsForType[rcSei], totalBits];

skipZeros: BOOL ¬ cd.options.skipZeros;

limit: BitAddress ¬ total.disp+totalBits;

minDisp: BitAddress ¬ limit;

maxDisp: BitAddress ¬ total.disp;

wholeThing: BOOL ¬ fieldSei = ISENull;

adjustOffset: BOOL ¬ fa # MimP5U.FnField
AND totalBits <= bitsPerWord
AND ModInWord[total.disp] = 0;

IF wholeThing THEN {

IF recBits < totalBits AND totalBits <= bitsPerWord THEN {

The whole record is inside of a field that is less than a word, so we have to right-justify, padding on the left with zeros.

delta: INT ¬ totalBits-recBits;

ConsAssign[typeANY, [disp: total.disp, size: delta], MimCode.nC0];

minDisp ¬ tOffset.disp;

tOffset.disp ¬ tOffset.disp + delta;

maxDisp ¬ tOffset.disp;

tOffset.size ¬ recBits;

adjustOffset ¬ FALSE;

};

rcSei ¬ SymbolOps.RecordRoot[SymbolOps.own, rcSei];

fieldSei ¬ MimP5U.NextVar[SymbolOps.FirstCtxSe[SymbolOps.own, seb[rcSei].fieldCtx]];

};

TreeOps.ScanList[maint, AssignField];

IF wholeThing AND NOT skipZeros THEN {

Clear out padding on the left

WHILE minDisp > total.disp DO

delta: INT = minDisp - total.disp;

mod: NAT ¬ ModInWord[minDisp];

IF mod = 0 THEN mod ¬ bitsPerWord;

IF delta < mod THEN mod ¬ delta;

minDisp ¬ minDisp - mod;

ConsAssign[typeANY, [disp: minDisp, size: mod], MimCode.nC0];

ENDLOOP;

Clear out padding on the right

WHILE maxDisp < limit DO

delta: INT = limit - maxDisp;

mod: NAT = ModInWord[maxDisp];

rem: NAT ¬ bitsPerWord - mod;

IF delta < rem THEN rem ¬ delta;

ConsAssign[typeANY, [disp: maxDisp, size: rem], MimCode.nC0];

maxDisp ¬ maxDisp + rem;

ENDLOOP;

};

IdValue: PROC [ise: ISEIndex] RETURNS [MimCode.BitAddress] = {

Temporary for conversion between old-style & new-style defs

RETURN [SymbolOps.DecodeCard[seb[ise].idValue]];

};

Row: PROC [node: Tree.Index, total: VLoc] = {

handles ARRAY construction

skipZeros: BOOL ¬ cd.options.skipZeros;

AssignElement: PROC [t: Tree.Link] = {

opName: Tree.NodeName ¬ none;

nextLoc: VLoc;

root: Tree.Link = t;

nextLoc.disp ¬ offset.disp + offset.size;

nextLoc.size ¬ grain;

IF t # Tree.Null THEN {

until we get to something interesting

opName ¬ TreeOps.OpName[t];

SELECT opName FROM

pad => {

son: Tree.Link = TreeOps.NthSon[t, 1];

sonBits: INT = MimP5U.BitsForOperand[son];

IF sonBits < bitsPerWord THEN EXIT;

t ¬ son;

offset.size ¬ sonBits;

};

cast => t ¬ TreeOps.NthSon[t, 1];

ENDCASE => EXIT;

ENDLOOP;

SELECT opName FROM

rowcons => Row[TreeOps.GetNode[t], offset];

construct => MainConstruct[
TreeOps.NthSon[t, 2], MimP5U.OperandType[t],
MimP5U.RecField, offset, ISENull];

all => [] ¬ AllConstruct[TreeOps.GetNode[t], offset];

ENDCASE => ConsAssign[cSei, offset, MimP5.Exp[t]];

};

offset ¬ nextLoc;

};

aSei: ArraySEIndex = ToArraySE[TreeType[node]];

cSei: CSEIndex = MimP5.Clarify[seb[aSei].componentType];

totalBits: BitCount = total.size;

totalLim: BitCount = total.disp+totalBits;

grain: BitCount = SymbolOps.BitsPerElement[
SymbolOps.own, seb[aSei].componentType, seb[aSei].packed];

offset: VLoc ¬ [total.disp, grain];

arrayElems: CARD ¬ SymbolOps.Cardinality[SymbolOps.own, seb[aSei].indexType];

arrayBits: INT ¬ arrayElems*grain;

IF totalBits <= bitsPerWord AND totalBits > arrayBits THEN {

We have leading fill bits to take care of

offset.size ¬ totalBits - arrayBits;

ConsAssign[typeANY, offset, MimCode.nC0];

offset.disp ¬ offset.disp + offset.size;

offset.size ¬ grain;

};

TreeOps.ScanList[tb[node].son[2], AssignElement];

IF totalBits > bitsPerWord AND totalBits > arrayBits THEN {

We have trailing fill bits to take care of here

This does happen, consider the case:

A: PACKED ARRAY [1..26] OF CHAR ← ['A, 'B, 'C, ..., 'Z];

offset.size ¬ totalBits - arrayBits;

offset.disp ¬ totalLim - offset.size;

ConsAssign[typeANY, offset, MimCode.nC0];

};

UnionConstruct: PROC [node: Tree.Index, rootSei: RecordSEIndex, total: VLoc] = {

construct a union part, total is offset of beginning of record

tOffset: VLoc = total;

offset: VLoc ¬ total;

fieldSei: ISEIndex;

vCtx: CTXIndex;

uSei: CSEIndex = MimP5.Clarify[TreeType[node]];

rcSei: RecordSEIndex;

tSei: ISEIndex;

tagged: BOOL;

tagValue: CARD;

tBits: CARDINAL = tOffset.size;

WITH u: seb[uSei] SELECT FROM

union => {

tagged ¬ u.controlled;

IF tagged THEN {

tagAddr: BitAddress = IdValue[u.tagSei];

tagSize: BitCount = LOOPHOLE[seb[u.tagSei].idInfo];

offset.disp ¬ offset.disp + tagAddr;

offset.size ¬ tagSize;

IF tBits <= bitsPerWord THEN {

huh: BOOL ¬ TRUE;

offset ← MimP5U.AdjustLoc[vl: offset, rSei: rootSei, fSei: u.tagSei, tBits: tBits];

};

ENDCASE => ERROR;

tSei ¬ TreeOps.GetSe[tb[node].son[1]];

tagValue ¬ SymbolOps.DecodeCard[seb[tSei].idValue];

rcSei ¬ ToRecordSE[tSei];

vCtx ¬ seb[rcSei].fieldCtx;

fieldSei ¬ MimP5U.NextVar[SymbolOps.FirstCtxSe[SymbolOps.own, vCtx]];

IF tagged

THEN {

IF fieldSei # ISENull AND seb[fieldSei].idCtx # vCtx THEN {

a dummy fill field

fillSize: CARD = SymbolOps.DecodeCard[seb[fieldSei].idInfo];

tagValue ¬ Basics.BITLSHIFT[tagValue, fillSize];

offset.size ¬ offset.size + fillSize;

fieldSei ¬ MimP5U.NextVar[SymbolOps.NextSe[SymbolOps.own, fieldSei]];

};

ConsAssign[typeANY, offset, MimP5U.MakeConstCard[tagValue]];

}

ELSE IF fieldSei # ISENull AND seb[fieldSei].idCtx # vCtx THEN {

no tag, but a fill field anyway

fillSize: [0..bitsPerWord) = SymbolOps.DecodeCard[seb[fieldSei].idInfo];

fillAddr: BitAddress = IdValue[fieldSei]; -- can't be full word

offset.disp ¬ offset.disp + fillAddr;

offset.size ¬ fillSize;

IF tBits <= bitsPerWord THEN

offset ¬ MimP5U.AdjustLoc[vl: offset, rSei: rootSei, fSei: fieldSei, tBits: tBits];

ConsAssign[typeANY, offset, MimCode.nC0];

fieldSei ¬ MimP5U.NextVar[SymbolOps.NextSe[SymbolOps.own, fieldSei]];

};

IF fieldSei # ISENull THEN

MainConstruct[tb[node].son[2], rootSei, MimP5U.RecField, total, fieldSei];

};

IsTreeOfZeros: PROC [t: Tree.Link] RETURNS [BOOL] = {

tt: Tree.Link ¬ t;

IF tt = Tree.Null THEN RETURN [TRUE];

WITH e: tt SELECT TreeOps.GetTag[tt] FROM

literal => {

lti: Literals.LTIndex = e.index;

IF LiteralOps.IsShort[lti] AND LiteralOps.ValueBits[lti] = 0 THEN GO TO zero;

GO TO nonzero; -- eventually do better here?

};

subtree => {

tp: Tree.NodePtr = @tb[e.index];

start: NAT ¬ 1;

stop: NAT ¬ tp.nSons;

SELECT tp.name FROM

construct, rowcons, all, union, cast, pad, list, lengthen, shorten, mwconst => {};

nil => GO TO zero;

ENDCASE => GO TO nonzero;

IF start = stop THEN {tt ¬ tp.son[start]; LOOP};

FOR i: NAT IN [start..stop] DO

IF NOT IsTreeOfZeros[tp.son[i]] THEN GO TO nonzero;

ENDLOOP;

GO TO zero;

};

ENDCASE;

GO TO nonzero;

ENDLOOP;

EXITS

nonzero => RETURN [FALSE];

zero => RETURN [TRUE];

};

AllConstruct: PROC [node: Tree.Index, total: VLoc] = {

aSei: ArraySEIndex = ToArraySE[TreeType[node]];

offset: VLoc ¬ total;

totalBits: BitCount = total.size;

grain: BitCount = SymbolOps.BitsPerElement[
SymbolOps.own, seb[aSei].componentType, seb[aSei].packed];

fillBits: CARDINAL ¬ 0;

fillStart: CARD ¬ 0;

eCount: CARD ¬ SymbolOps.Cardinality[SymbolOps.own, seb[aSei].indexType];

aBits: BitCount ¬ totalBits;

packed: BOOL ¬ grain < bitsPerWord;

skipZeros: BOOL ¬ cd.options.skipZeros;

son1: Tree.Link = tb[node].son[1];

val: Node ¬ MimCode.nC0;

IF skipZeros AND IsTreeOfZeros[son1] THEN RETURN;

IF son1 # Tree.Null THEN val ¬ MimP5.Exp[son1];

val ¬ AssureSize[val, grain];

IF MimP5U.IsZero[val] THEN {

IF skipZeros THEN RETURN;

IF cd.options.init AND cd.options.counted THEN RETURN;

IF totalBits <= bitsPerLongWord THEN {

ConsAssign[aSei, total, MimCode.nC0];

RETURN;

};

IF packed AND eCount # 0 THEN {

This is a packed array. Most of this code is here to try to make up word-oriented values.

remBits: NAT ¬ 0;

factor: CARD ¬ 1;

g: [0..bitsPerWord] = grain;

perWord: NAT = MIN[eCount, bitsPerWord/g];

aBits ¬ eCount*grain;

fillBits ¬ totalBits - aBits;

FOR i: NAT IN [1..perWord) DO

factor ¬ 1 + Basics.BITLSHIFT[factor, grain];

ENDLOOP;

val ¬ MimP5U.BinaryArithOp[mul, unsignedClass,
MimP5U.MakeConstCard[factor], AssureSize[val, bitsPerWord]];

eCount ¬ aBits / bitsPerWord;

remBits ¬ aBits MOD bitsPerWord;

aBits ¬ eCount*bitsPerWord;

SELECT TRUE FROM

totalBits <= bitsPerWord => {ConsAssign[aSei, total, val]; RETURN};

remBits = 0 AND eCount >= allConstructorTrigger => {};

MimP5Stuff.IsCard[val], MimP5Stuff.IsSimpleVar[val] => {};

ENDCASE => val ¬ MimP5S.Temporize[cl: cd.cl, n: val];

Sigh, must make a temporary for the value

First, do all of the words with the ALL constructor

SELECT eCount FROM

< allConstructorTrigger => {

disp: INT ¬ total.disp;

FOR i: NAT IN [0..NAT[eCount]) DO

ConsAssign[aSei, [disp, bitsPerWord], val];

disp ¬ disp + bitsPerWord;

ENDLOOP;

};

ENDCASE =>

ConsAssign[aSei, [total.disp, aBits], MimP5U.ApplyOp[
oper: MimP5U.MesaOpNode[all],
args: MimP5U.MakeArgList2[val, MimP5U.MakeConstCard[eCount]],
bits: aBits]];

total.disp ¬ total.disp + aBits;

total.size ¬ totalBits - aBits;

IF remBits # 0 THEN {

There are remaining elements in the array

val ¬ AssureSize[val, remBits];

ConsAssign[aSei, [total.disp, remBits], val];

total.disp ¬ total.disp + remBits;

total.size ¬ total.size - remBits;

};

IF total.size > 0 THEN

There are remaining zero bits to assign (a partial word)

ConsAssign[aSei, total, MimP5U.MakeConstCard[0, total.size]];

RETURN;

};

SELECT eCount FROM

0 => {};

1 => {

This simply does not need an ALL

ConsAssign[aSei, offset, val];

};

ENDCASE => {

IF eCount < allConstructorTrigger AND val.bits <= bitsPerWord

THEN {

disp: INT ¬ total.disp;

bits: INT ¬ val.bits;

csei: CSEIndex = MimP5.Clarify[seb[aSei].componentType];

SELECT TRUE FROM

MimP5Stuff.IsCard[val], MimP5Stuff.IsSimpleVar[val] => {};

ENDCASE => val ¬ MimP5S.Temporize[cl: cd.cl, n: val];

Sigh, must make a temporary for the value

FOR i: NAT IN [0..NAT[eCount]) DO

ConsAssign[csei, [disp, bits], val];

disp ¬ disp + bitsPerWord;

ENDLOOP;

}

ELSE {

rhs: Node ¬ MimP5U.ApplyOp[
oper: MimP5U.MesaOpNode[all],
args: MimP5U.MakeArgList2[val, MimP5U.MakeConstCard[eCount]],
bits: aBits];

ConsAssign[aSei, offset, rhs];

};

IF fillBits # 0 AND NOT skipZeros THEN {

offset.disp ¬ total.disp + fillStart;

offset.size ¬ fillBits;

ConsAssign[typeANY, offset, MimCode.nC0];

};

public entries

All: PUBLIC PROC
[t: Tree.Link, node: Tree.Index, options: StoreOptions] RETURNS [l: Node] = {

generate code for constructor expression

aSei: ArraySEIndex = ToArraySE[TreeType[node]];

cl: CodeList ¬ MimP5U.NewCodeList[];

aBits: BitCount ¬ MimP5U.BitsForType[aSei];

saveCd: ConsDestination = cd;

assumeTemp: BOOL ¬ FALSE;

IF t = Tree.Null THEN {

var: Var;

sei: ISEIndex;

[var: var, sei: sei] ¬ MimP5U.MakeTemp[cl: cl, bits: aBits];

t ¬ [symbol[sei]];

options ¬ [expr: TRUE];

assumeTemp ¬ TRUE;

};

cd ¬ [options: options, ignoreSafen: IgnoreSafen[t]];

+ many defaults

tb[node].son[1] ¬ MimP5U.ProcessSafens[cl, tb[node].son[1], cd.ignoreSafen];

SetConsDest[t, cl];

{

dest: Node = cd.destNode;

dstBits: INT ¬ dest.bits;

AllConstruct[node, [disp: 0, size: dstBits]];

IF options.expr THEN MimP5U.MoreCode[cl, dest] ELSE dstBits ¬ 0;

l ¬ MimP5Stuff.MakeConsBlock[cl, dest, dstBits, assumeTemp];

};

cd ¬ saveCd;

};

Construct: PUBLIC PROC
[t: Tree.Link, node: Tree.Index, options: StoreOptions] RETURNS [l: Node] = {

generate code for constructor expression

tsei: RecordSEIndex = ToRecordSE[TreeType[node]];

nbits: BitCount ¬ MimP5U.BitsForType[tsei];

saveCd: ConsDestination = cd;

son2: Tree.Link ¬ tb[node].son[2];

fa: MimP5U.RecOrFnProc
= IF seb[tsei].argument THEN MimP5U.FnField ELSE MimP5U.RecField;

cl: CodeList ¬ MimP5U.NewCodeList[];

assumeTemp: BOOL ¬ FALSE;

IF useExtraSafens AND t # Tree.Null AND nbits > bitsPerWord AND NOT options.init

THEN ExtraSafens[cl, t, son2];

IF t = Tree.Null THEN {

var: Var;

sei: ISEIndex;

[var: var, sei: sei] ¬ MimP5U.MakeTemp[cl: cl, bits: nbits, type: tsei];

t ¬ [symbol[sei]];

options ¬ [expr: TRUE];

assumeTemp ¬ TRUE;

};

cd ¬ [options: options, ignoreSafen: IgnoreSafen[t]]; -- + many defaults

son2 ¬ tb[node].son[2] ¬ MimP5U.ProcessSafens[cl, son2, cd.ignoreSafen];

SetConsDest[t, cl];

{

dest: Node = cd.destNode;

destBits: INT ¬ dest.bits;

total: VLoc ¬ [disp: 0, size: destBits];

MainConstruct[maint: son2, rSei: tsei, fa: fa, total: total, fieldSei: ISENull];

IF options.expr THEN MimP5U.MoreCode[cl, dest] ELSE destBits ¬ 0;

l ¬ MimP5Stuff.MakeConsBlock[cl, dest, destBits, assumeTemp];

};

cd ¬ saveCd;

};

ListCons: PUBLIC PROC [node: Tree.Index] RETURNS [Node] = {

pSei: CSEIndex = MimP5.Clarify[TreeType[node]];

rSei: CSEIndex = MimP5.Clarify[SymbolOps.ReferentType[SymbolOps.own, pSei]];

long: BOOL = tb[node].attr2;

counted: BOOL = tb[node].attr3;

pWords: CARD = MimP5U.WordsForSei[pSei];

pBits: CARD = pWords*bitsPerWord;

zoneTree: Tree.Link = tb[node].son[1];

catchTree: Tree.Link ¬ Tree.Null;

zoneNode: Node = IF zoneTree = Tree.Null THEN NIL ELSE MimP5.Exp[zoneTree];

recWords: INT = MimP5U.WordsForSei[rSei]; -- include rest ptr

recBits: INT = bitsPerWord*recWords;

elemWords: INT = recWords-pWords; -- does not include rest ptr

elemBits: INT = bitsPerWord*elemWords;

cl: CodeList ¬ MimP5U.NewCodeList[];

headTemp: Var ¬ NIL;

tailTemp: Var ¬ NIL;

tailRest: Var ¬ NIL;

tailFirst: Var ¬ NIL;

EachElem: Tree.Scan = {

sizeNode: Node ¬ MimP5U.MakeConstInt[recWords*unitsPerWord];

allocNode: Node ¬ IF counted

THEN MimP5.CountedAllocate[
zone: zoneNode, type: rSei, catch: catchTree, size: sizeNode]

ELSE MimP5.ZoneOp[zone: zoneNode, which: alloc, args: MimP5U.MakeNodeList[sizeNode], catch: catchTree];

IF headTemp = NIL

THEN {

first element

headTemp ¬ MimP5S.Temporize[cl: cl, n: allocNode];

tailTemp ¬ MimP5U.MakeTemp[cl: cl, bits: pBits, init: headTemp].var;

tailRest ¬ MimP5U.TakeFieldVar[
MimP5U.Deref[tailTemp, recBits, MimData.worstAlignment],
elemBits, pBits];

Note, assumes that the rest field starts at the end of the first field

}

ELSE {

rest of the elements

ptrAssn: Node ¬ IF counted

THEN MimP5U.AssignRC[lhs: tailRest, rhs: allocNode, type: pSei, init: TRUE]

ELSE MimP5U.Assign[lhs: tailRest, rhs: allocNode];

MimP5U.MoreCode[cl, ptrAssn];

MimP5U.MoreCode[cl, MimP5U.Assign[lhs: tailTemp, rhs: tailRest]];

};

IF t # Tree.Null THEN {

There is initialization (assume it include the rest ptr)

saveCd: ConsDestination = cd;

IF tailFirst = NIL THEN

tailFirst ¬ MimP5U.TakeFieldVar[
MimP5U.Deref[tailTemp, recBits, MimData.worstAlignment],
0, elemBits];

Note, assumes that the first field starts at offset 0

cd ¬ [options: [init: TRUE, counted: counted], ignoreSafen: FALSE]; -- + defaults

cd.cl ¬ cl;

cd.destNode ¬ tailFirst;

MainConstruct[maint: t, rSei: rSei, fa: MimP5U.RecField, total: [0, recBits]];

cd ¬ saveCd;

};

TreeOps.ScanList[tb[node].son[2], EachElem];

IF headTemp = NIL

THEN MimP5U.MoreCode[cl, MimP5U.MakeConstInt[0, pBits]]

ELSE MimP5U.MoreCode[cl, headTemp];

RETURN [MimP5U.MakeBlock[cl, pBits]];

};

RowCons: PUBLIC PROC
[t: Tree.Link, node: Tree.Index, options: StoreOptions] RETURNS [l: Node] = {

array (expression) construction

aSei: ArraySEIndex = ToArraySE[TreeType[node]];

aBits: BitCount ¬ MimP5U.BitsForType[aSei];

saveCd: ConsDestination = cd;

grain: BitCount = SymbolOps.BitsPerElement[
SymbolOps.own, seb[aSei].componentType, seb[aSei].packed];

list: Tree.Link ¬ tb[node].son[2];

cl: CodeList ¬ MimP5U.NewCodeList[];

assumeTemp: BOOL ¬ FALSE;

IF useExtraSafens AND t # Tree.Null AND aBits > bitsPerWord AND NOT options.init THEN

ExtraSafens[cl, t, list];

IF t = Tree.Null THEN {

var: Var;

sei: ISEIndex;

[var: var, sei: sei] ¬ MimP5U.MakeTemp[cl: cl, bits: aBits];

t ¬ [symbol[sei]];

options ¬ [expr: TRUE];

assumeTemp ¬ TRUE;

};

cd ¬ [options: options, ignoreSafen: IgnoreSafen[t]];

+ many defaults

tb[node].son[1] ¬ MimP5U.ProcessSafens[cl, tb[node].son[1], cd.ignoreSafen];

SetConsDest[t, cl];

{

dest: Node = cd.destNode;

destBits: INT ¬ cd.destNode.bits;

Row[node, [disp: 0, size: destBits]];

IF options.expr THEN MimP5U.MoreCode[cl, dest] ELSE destBits ¬ 0;

l ¬ MimP5Stuff.MakeConsBlock[cl, dest, destBits, assumeTemp];

};

cd ¬ saveCd;

};

VariantConstruct: PUBLIC PROC
[t1: Tree.Link, t2: Tree.Link, options: StoreOptions] RETURNS [Node] = {

variant record (expression) construction

cl: CodeList ¬ MimP5U.NewCodeList[];

saveCd: ConsDestination = cd;

bits: INT ¬ 0;

t1 ¬ TreeOps.NthSon[t1, 1];

cd ¬ [options: options, ignoreSafen: TreeOps.GetTag[t1] = symbol]; -- + many defaults

SetConsDest[t1, cl];

t2 ¬ MimP5U.ProcessSafens[cl, t2, cd.ignoreSafen];

{

recSei: RecordSEIndex = ToRecordSE[MimP5U.OperandType[t1]];

rootSei: RecordSEIndex = SymbolOps.RecordRoot[SymbolOps.own, recSei];

dest: Node = cd.destNode;

destBits: INT = cd.destNode.bits;

rBits: INT = MimP5U.BitsForType[recSei];

offset: VLoc ¬ [disp: 0, size: destBits];

IF destBits <= bitsPerWord AND rBits < destBits THEN

offset ¬ [disp: destBits-rBits, size: rBits];

UnionConstruct[TreeOps.GetNode[t2], rootSei, offset];

IF options.expr THEN {MimP5U.MoreCode[cl, dest]; bits ¬ destBits};

};

cd ¬ saveCd;

RETURN [MimP5U.MakeBlock[cl, bits]];

};

New: PUBLIC PROC [node: Tree.Index] RETURNS [Node] = {

saveCd: ConsDestination = cd;

long: BOOL = tb[node].attr2;

counted: BOOL = tb[node].attr3;

pLength: CARD = MimP5U.WordsForSei[TreeType[node]];

pBits: CARD = pLength*bitsPerWord;

zoneTree: Tree.Link = tb[node].son[1];

typeTree: Tree.Link = tb[node].son[2];

initTree: Tree.Link ¬ tb[node].son[3];

overType: SEIndex = MimP5U.TypeForTree[typeTree];

type: CSEIndex = MimP5.Clarify[overType];

catchTree: Tree.Link = IF tb[node].nSons = 4 THEN tb[node].son[4] ELSE Tree.Null;

tag: ISEIndex ¬ ISENull;

computedType: BOOL = (TreeOps.OpName[typeTree] = apply);

baseUnits: INT ¬ MimP5U.WordsForSei[type] * unitsPerWord;

sizeNode: Node ¬ MimP5U.MakeConstInt[baseUnits];

allocNode: Node ¬ NIL;

cl: CodeList ¬ MimP5U.NewCodeList[];

zoneNode: Node = IF zoneTree = Tree.Null THEN NIL ELSE MimP5.Exp[zoneTree];

nElemsType: Symbols.Type;

nElemsNode: Node ¬ NIL;

initTree ¬ MimP5U.ProcessSafens[cl, initTree];

RRA: The idea is to process the safen nodes in the tree to make up necessary temp values. This is necessary because if we get a fault after allocating the variable but have not fully initialized it the interpretation of the RC map may be funny. I am still not convinced that this step is sufficient!

IF computedType THEN {

Have to make a node for the size computation, since the size is not constant.

elemUnits: Node ¬ NIL;

subNode: Tree.Index = TreeOps.GetNode[typeTree];

vSei: ISEIndex = SymbolOps.VariantField[SymbolOps.own, type];

bitsPerItem: INT;

constElems: BOOL ¬ FALSE;

nElemsType ¬ MimP5U.OperandType[tb[subNode].son[2]];

nElemsNode ¬ MimP5U.Simplify[cl, MimP5.Exp[tb[subNode].son[2]]];

WITH nElemsNode SELECT FROM

const: ConstNode => constElems ¬ TRUE;

ENDCASE;

IF vSei # ISENull

THEN {

vType: CSEIndex = MimP5.Clarify[seb[vSei].idType];

WITH v: seb[vType] SELECT FROM

sequence => {

tag ¬ IF v.controlled THEN v.tagSei ELSE ISENull;

bitsPerItem ¬ SymbolOps.BitsPerElement[
SymbolOps.own, v.componentType, v.packed];

};

ENDCASE => ERROR;

}

ELSE {

must be StringBody (??), fudge it

tag ¬ SymbolOps.NextSe[SymbolOps.own,
SymbolOps.FirstCtxSe[SymbolOps.own, seb[ToRecordSE[type]].fieldCtx]];

bitsPerItem ¬ bitsPerChar;

};

IF bitsPerItem >= bitsPerWord

THEN {

Hot dog! We can calculate the number of units directly.

unitsPerElem: INT ¬ (bitsPerItem+bitsPerAU-1)/bitsPerAU;

elemUnits ¬ MimP5U.BinaryArithOp[mul, unsignedClass, MimP5U.MakeConstInt[unitsPerElem], nElemsNode];

}

ELSE {

Foo! First we calculate the number of words, then the number of units.

elemsPerWord: NAT ¬ bitsPerWord/bitsPerItem;

elemWords: Node ¬ MimP5U.BinaryArithOp[div, unsignedClass,

MimP5U.BinaryArithOp[add, unsignedClass, nElemsNode, MimP5U.MakeConstInt[elemsPerWord-1]],

MimP5U.MakeConstInt[elemsPerWord]];

elemUnits ¬ MimP5U.BinaryArithOp[mul, unsignedClass, MimP5U.MakeConstInt[unitsPerWord], elemWords];

};

IF NOT constElems THEN

we will need this value again

elemUnits ¬ MimP5S.Temporize[cl: cl, n: elemUnits];

sizeNode ¬ MimP5U.BinaryArithOp[add, unsignedClass, sizeNode, elemUnits];

};

IF counted

THEN allocNode ¬ MimP5.CountedAllocate[
zone: zoneNode, type: overType, catch: catchTree, size: sizeNode]

ELSE allocNode ¬ MimP5.ZoneOp[
zone: zoneNode, which: alloc,
args: MimP5U.MakeNodeList[sizeNode], catch: catchTree];

IF nElemsNode = NIL AND initTree = Tree.Null

THEN {

no initialization, so just return the results of the alloc node

MimP5U.MoreCode[cl, allocNode];

}

ELSE {

some init is required

tempPtr: Var = MimP5S.Temporize[cl: cl, n: allocNode];

tempRec: Var = MimP5U.Deref[tempPtr, 0, MimData.worstAlignment];

nLoc: VLoc ¬ [disp: 0, size: baseUnits*bitsPerAU];

IF nElemsNode # NIL AND tag # ISENull THEN {

Have to init the # of elements in the sequence

offset: BitAddress;

bits: INT;

[offset: offset, size: bits] ¬ MimP5U.RecField[tag];

SELECT nElemsNode.bits FROM

< bits =>

nElemsNode ¬ MimP5U.Extend[nElemsNode, bits, nElemsType];

> bits =>

nElemsNode ¬ MimP5U.TakeField[nElemsNode, nElemsNode.bits-bits, bits];

ENDCASE;

MimP5U.MoreCode[cl, MimP5U.Assign[

lhs: MimP5U.TakeFieldVar[tempRec, offset, bits],

rhs: nElemsNode]];

IF offset < nLoc.size THEN nLoc.size ¬ offset;

This relies on having the tag being the last location in the constructor that can be initialized. All sequence elements are initialized to zeros by the allocator (for counted allocations) or are allowed to be uninitialized (for uncounted allocations).

};

IF initTree # Tree.Null THEN {

Have to perform the assignment of the constructor. Note that we do this without making up a node for it.

res: Node ¬ NIL;

cd ¬ [options: [init: TRUE, counted: counted, skipZeros: counted],
ignoreSafen: FALSE]; -- + defaults

cd.cl ¬ cl;

cd.destNode ¬ tempRec;

SELECT TreeOps.OpName[initTree] FROM

construct =>

MainConstruct[
maint: TreeOps.NthSon[initTree, 2],
rSei: MimP5U.OperandType[initTree],
fa: MimP5U.RecField,
total: nLoc];

rowcons => Row[TreeOps.GetNode[initTree], nLoc];

all => [] ¬ AllConstruct[TreeOps.GetNode[initTree], nLoc];

ENDCASE => ConsAssign[type, nLoc, MimP5.Exp[initTree]];

MimP5U.MoreCode[cl, tempPtr];

res ¬ MimP5Stuff.MakeConsBlock[cl, cd.destNode, pBits, TRUE];

cd ¬ saveCd;

RETURN [res];

};

MimP5U.MoreCode[cl, tempPtr];

};

RETURN [MimP5U.MakeBlock[cl, pBits]];

};

ToRecordSE: PROC [sei: SEIndex] RETURNS [RecordSEIndex] = {

sei ¬ MimP5.Clarify[sei];

WITH cse: seb[sei] SELECT FROM

cons => WITH cse SELECT FROM

record => RETURN [LOOPHOLE[sei, RecordSEIndex]];

ENDCASE;

ERROR;

};

ToArraySE: PROC [sei: SEIndex] RETURNS [ArraySEIndex] = {

sei ¬ MimP5.Clarify[sei];

WITH cse: seb[sei] SELECT FROM

cons => WITH cse SELECT FROM

array => RETURN [LOOPHOLE[sei, Symbols.ArraySEIndex]];

ENDCASE;

ERROR;

};

ModInWord: PROC [i: INT] RETURNS [ [0..bitsPerWord) ] = INLINE {

IF bitsPerWord # NAT[BITS[INT]]

THEN RETURN [Basics.LowHalf[LOOPHOLE[i, CARD]] MOD bitsPerWord]

ELSE RETURN [LOOPHOLE[i, CARD] MOD bitsPerWord];

};

ExtraSafens: PROC [cl: CodeList, dst: Tree.Link, src: Tree.Link] = {

WITH s: src SELECT TreeOps.GetTag[src] FROM

subtree => {

spt: Tree.NodePtr = @tb[s.index];

SELECT spt.name FROM

construct, rowcons, union => ExtraSafens[cl, dst, spt.son[2]];

list =>

FOR i: NAT IN [1..spt.nSons] DO

son: Tree.Link = tb[s.index].son[i];

WITH ss: son SELECT TreeOps.GetTag[son] FROM

subtree => SELECT tb[ss.index].name FROM

construct, rowcons, union => {

ExtraSafens[cl, dst, tb[ss.index].son[2]];

LOOP;

};

ENDCASE;

IF Conflicts[dst, son] THEN {

This son needs to be put into a temporary for safety's sake

type: Symbols.Type = MimP5U.OperandType[son];

bits: BitCount ¬ MimP5U.BitsForType[type];

init: Node = MimP5.Exp[son];

sei: ISEIndex = MimP5U.MakeTemp[cl: cl, bits: bits, init: init, type: type].sei;

tb[s.index].son[i] ¬ [symbol[sei]];

};

ENDLOOP;

ENDCASE;

};

ENDCASE;

};

Conflicts: PROC [dst: Tree.Link, src: Tree.Link] RETURNS [BOOL] = {

WITH s: src SELECT TreeOps.GetTag[src] FROM

subtree => {

spt: Tree.NodePtr = @tb[s.index];

SELECT spt.name FROM

nil, void, clit, llit, mwconst, atom, typecode, stringinit, textlit, signalinit, procinit, thread, none, self, gcrt => RETURN [FALSE];

ENDCASE;

IF spt.nSons = 1 THEN {src ¬ spt.son[1]; LOOP};

FOR i: NAT IN [1..spt.nSons] DO

IF Conflicts[dst, spt.son[i]] THEN RETURN [TRUE];

ENDLOOP;

};

symbol => {

sep: Symbols.ISEPointer = @seb[s.index];

IF sep.immutable OR sep.constant THEN RETURN [FALSE];

EXIT;

};

ENDCASE;

RETURN [FALSE];

ENDLOOP;

IF dst = src THEN RETURN [TRUE];

WITH d: dst SELECT TreeOps.GetTag[dst] FROM

subtree => {

dpt: Tree.NodePtr = @tb[d.index];

SELECT dpt.name FROM

cast, dot, uparrow, index, seqindex, reloc, arraydesc, lengthen, shorten, openx => {

dst ¬ dpt.son[1];

LOOP;

};

dollar => {

dst ¬ dpt.son[2];

LOOP;

};

ENDCASE;

};

ENDCASE;

RETURN [FALSE];

ENDLOOP;

};

bases & notifier

tb: Tree.Base ¬ NIL; -- tree base (local copy)

seb: Symbols.Base ¬ NIL; -- semantic entry base (local copy)

ConstructorNotify: Alloc.Notifier = {

called by allocator whenever table area is repacked

seb ¬ base[Symbols.seType];

tb ¬ base[Tree.treeType];

};

MimCode.RegisterNotifier[ConstructorNotify];