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

MimExpr.mesa

Sweet, June 1, 1986 9:08:26 pm PDT

Satterthwaite, December 5, 1985 10:03:21 am PST

Russ Atkinson (RRA) May 17, 1991 11:55 am PDT

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

DIRECTORY

Alloc USING [Base, Notifier],

Basics USING [LowHalf],

IntCodeDefs USING [ArithClass, ArithSelector, ByteSequence, CaseList, CaseListRep, ConstNode, DerefLocation, Label, LocalVarLocation, Location, LocationRep, Node, NodeList, NodeRep, OperRep, Var],

IntCodeUtils USING [Fetch, IdTab, NewIdTab, SideEffectFree, SimplyEqual, Store],

LiteralOps USING [StringValue, Value, ValueBits, ValueCard, ValueInt, ValueReal],

Literals USING [Base, LTIndex, ltType, STIndex, stType],

MimCode USING [BitAddress, BitCount, caseCV, caseType, CodeList, firstMappedAddress, RegisterNotifier, StoreOptions, trueNode, VLoc, xtracting, xtractNode, z],

MimData USING [wordAlignment, worstAlignment],

MimosaLog USING [ErrorTree, WarningSei],

MimP5 USING [All, BindStmtExp, CaseStmtExp, Construct, Exp, FlowExp, GetCanonicalType, ListCons, MakeString, New, ProcDescForBti, RowCons, SignalForSei, StatementTree, VarForLink, visibleContext],

MimP5S USING [AssignExp, Call, Create, DIndex, ExtractExp, ForkExp, Index, Join, ProcCheck, SeqIndex, SigErr, SplitArith, Start, StringInit, Subst, SysErrExp, Temporize],

MimP5Stuff USING [ShiftLeft, SimplifyParts],

MimP5U USING [Address, AdjustLoc, AlignmentFromTree, AlignmentFromType, AllocLabel, ApplyOp, ArithClassForTree, ArithClassForType, ArithOpForTree, Assign, BinaryArithOp, BitsForType, BoolTest, BoundsCheck, CedarOpNode, CompareOp, Declare, Deref, EqualTest, Extend, FnField, ForceBool, FullWordBits, InsertLabel, MakeArgList, MakeArgList2, MakeCaseList, MakeComposite, MakeConstCard, MakeConstInt, MakeDummy, MakeGoTo, MakeNodeList, MakeNodeList2, MakeTemp, MakeVar, MaybeBlock, MesaOpNode, MoreCode, NewCodeList, NodeAnd, NodeForType, NodeIf, NodeOr, OperandType, ProcessSafens, RecField, ReferentType, TakeField, TypeForTree, VariantTag, ZeroExtend],

SymbolOps USING [CtxLevel, DecodeBti, DecodeCard, DecodeLink, EqTypes, FindExtension, own, RCType, ToType, TransferTypes, TypeForm, TypeLink, TypeRoot, UnderType, VariantField, XferMode],

Symbols USING [Alignment, Base, bodyType, BTIndex, CBTIndex, CBTNull, ContextLevel, CSEIndex, CTXIndex, ISEIndex, ISENull, lG, lZ, nullName, RecordSEIndex, seType, Type],

Table USING [IndexRep],

Target: TYPE MachineParms USING [AlignmentIndex, Alignments, bitsPerAU, bitsPerByte, bitsPerLongWord, bitsPerProgram, bitsPerRef, bitsPerSignal, bitsPerWord],

TargetConversions USING [BitsWritten, PutCard, NewWriter, Writer, WriterContents],

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

TreeOps USING [GetNode, GetSe, GetTag, ListLength, ScanList],

Types USING [Equivalent, OpaqueValue];

MimExpr: PROGRAM

IMPORTS Basics, IntCodeUtils, LiteralOps, MimCode, MimData, MimosaLog, MimP5, MimP5S, MimP5Stuff, MimP5U, SymbolOps, TargetConversions, TreeOps, Types

EXPORTS MimP5 = {

OPEN IntCodeDefs, MimCode, Target;

bitsPerPtr: NAT = Target.bitsPerRef;

bitsPerWord: NAT = Target.bitsPerWord;

bytesPerWord: NAT = bitsPerWord/Target.bitsPerByte;

firstMappedBit: CARD = MimCode.firstMappedAddress*Target.bitsPerAU;

wordPadDeref: BOOL = TRUE;

This means that pointers are always word-aligned.

minReferentAlignment: Symbols.Alignment ¬ MimData.wordAlignment;

minReferentBits: NAT ¬ bitsPerWord;

hackForPad: BOOL ¬ TRUE;

Permit "long" result of short pads.

conversion hacks

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

RETURN [SymbolOps.ToType[tb[node].info]];

};

imported definitions

ExprOptions: MimCode.StoreOptions = [expr: TRUE, init: TRUE];

BTIndex: TYPE = Symbols.BTIndex;

CBTIndex: TYPE = Symbols.CBTIndex;

CBTNull: CBTIndex = Symbols.CBTNull;

ContextLevel: TYPE = Symbols.ContextLevel;

CSEIndex: TYPE = Symbols.CSEIndex;

CTXIndex: TYPE = Symbols.CTXIndex;

ISEIndex: TYPE = Symbols.ISEIndex;

ISENull: ISEIndex = Symbols.ISENull;

lG: ContextLevel = Symbols.lG;

LTIndex: TYPE = Literals.LTIndex;

lZ: ContextLevel = Symbols.lZ;

RecordSEIndex: TYPE = Symbols.RecordSEIndex;

Type: TYPE = Symbols.Type;

debugging hack

TreeIndexSeen: SIGNAL = CODE;

debugTreeIndex: Tree.Link ¬ Tree.Null;

NotYetImplemented: SIGNAL = CODE;

procedures

ExpList: PUBLIC PROC [t: Tree.Link, wordPad: BOOL] RETURNS [head, tail: NodeList ¬ NIL] = {

OneExp: Tree.Scan = {

nl: NodeList;

n: Node ¬ MimP5.Exp[t];

IF wordPad THEN {

nb: INT = n.bits;

mod: NAT = Basics.LowHalf[nb] MOD bitsPerWord;

IF mod # 0 THEN

We need to pad out the expression

n ¬ MimP5U.Extend[n, nb+(bitsPerWord-mod), MimP5U.OperandType[t]];

};

nl ¬ MimP5U.MakeNodeList[n];

IF tail = NIL THEN head ¬ nl ELSE tail.rest ¬ nl;

tail ¬ nl;

};

TreeOps.ScanList[t, OneExp];

};

Exp: PUBLIC PROC [t: Tree.Link] RETURNS [l: IntCodeDefs.Node] = {

generates code for an expression

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

literal =>

RETURN [MakeConst[e.index]];

string =>

RETURN [MimP5.MakeString[t]];

symbol => {

sei: ISEIndex = e.index;

IF ~seb[sei].constant

THEN {

IF seb[sei].idDecl = 1 THEN MimosaLog.WarningSei[uninitialized, sei];

This variable is almost certainly uninitialized

l ¬ VarForSei[e.index];

}

ELSE

SELECT SymbolOps.XferMode[SymbolOps.own, seb[sei].idType] FROM

proc => {

IF seb[sei].extended THEN {

This must be MACHINE CODE or some other stuff.

link: Tree.Link ¬ SymbolOps.FindExtension[SymbolOps.own, sei].tree;

WITH sub: link SELECT TreeOps.GetTag[link] FROM

subtree => RETURN [MachineCodeBytes[tb[sub.index].son[1]]];

ENDCASE => ERROR;

};

RETURN [MimP5.ProcDescForBti[SymbolOps.DecodeBti[seb[sei].idInfo]]];

};

signal, error => {

The only constant signals & errors are those in our frame!

l ¬ MimP5.SignalForSei[sei];

};

program => {

use the address of our own global frame

l ¬ MimP5U.MesaOpNode[globalFrame, 0, Target.bitsPerProgram]

};

ENDCASE => ERROR;

};

subtree => {

node: Tree.Index ¬ e.index;

IF tb[node].free THEN ERROR;

recentExp ¬ t;

IF e = Tree.Null THEN {

Implicit operand

l ¬ IF MimCode.xtracting THEN MimCode.xtractNode ELSE MimCode.caseCV;

IF l = NIL THEN ERROR;

RETURN;

};

IF t = debugTreeIndex THEN SIGNAL TreeIndexSeen;

SELECT tb[node].name FROM

casex => l ¬ MimP5.CaseStmtExp[node, TRUE];

bindx => l ¬ MimP5.BindStmtExp[node, TRUE];

assignx => l ¬ MimP5S.AssignExp[node];

extractx => l ¬ MimP5S.ExtractExp[node];

plus => l ¬ BinaryOp[node, add];

minus => l ¬ BinaryOp[node, sub];

div => l ¬ BinaryOp[node, div];

mod => l ¬ BinaryOp[node, mod];

times => l ¬ BinaryOp[node, mul];

power => l ¬ BinaryOp[node, pow];

dot, uparrow => l ¬ DotOrUparrow[node];

reloc => {

generates code for "baseptr[relptr]"

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

bits: INT ¬ MimP5U.BitsForType[TreeType[node]];

align: Symbols.Alignment = MAX[

MimP5U.AlignmentFromTree[son2, TRUE],

minReferentAlignment];

base: Node = Exp[tb[node].son[1]];

relptr: Node ¬ Exp[son2];

sum: Node;

IF tb[node].attr1 THEN {

reloc of an array descriptor

relptr ¬ MimP5U.TakeField[relptr, 0, bitsPerWord];

};

sum ¬ MimP5U.ApplyOp[
oper: MimP5U.ArithOpForTree[node, add],
args: MimP5U.MakeNodeList2[base, relptr],
bits: bitsPerPtr];

IF wordPadDeref AND bits < bitsPerWord THEN

IF ORD[align] >= ORD[MimData.wordAlignment] THEN

bits ¬ bitsPerWord;

l ¬ MimP5U.Deref[n: sum, bits: bits, align: align];

};

dollar => l ¬ Dollar[node];

addr => {

generates code for "@"

op1: Node = Exp[tb[node].son[1]];

l ¬ MimP5U.Address[op1];

};

index => l ¬ MimP5S.Index[node];

dindex => l ¬ MimP5S.DIndex[node];

construct => l ¬ MimP5.Construct[Tree.Null, node, ExprOptions];

arraydesc => {

subNode: Tree.Index = TreeOps.GetNode[tb[node].son[1]];

base: Node = Exp[tb[subNode].son[1]];

lenLink: Tree.Link = tb[subNode].son[2];

length: Node ¬ IF lenLink = Tree.Null
THEN MimP5U.MakeConstInt[0]
ELSE MimP5U.Extend[Exp[lenLink], bitsPerWord, MimP5U.OperandType[lenLink]];

bits: INT = base.bits + length.bits;

l ¬ MimP5U.MakeComposite[MimP5U.MakeNodeList2[base, length], bits];

};

length => {

generates code to extract length from array descriptor

ad: Node = Exp[tb[node].son[1]];

l ¬ MimP5U.TakeField[ad, bitsPerWord, bitsPerWord];

};

base => {

generates code to extract base from array descriptor

ad: Node = Exp[tb[node].son[1]];

l ¬ MimP5U.TakeField[ad, 0, bitsPerWord];

};

body => {

bti: CBTIndex = LOOPHOLE[tb[node].info];

l ¬ MimP5.ProcDescForBti[bti];

};

rowcons => l ¬ MimP5.RowCons[Tree.Null, node, ExprOptions];

stringinit => l ¬ MimP5S.StringInit[node];

pad => {

padType: Type = TreeType[node];

dstBits: BitCount = MimP5U.BitsForType[padType];

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

sonType: Type = MimP5U.OperandType[son];

sonBits: INT = MimP5U.BitsForType[sonType];

val: Node ¬ Exp[son];

valBits: INT ¬ val.bits;

IF valBits = bitsPerWord AND dstBits <= bitsPerWord AND sonBits < dstBits THEN

IF hackForPad THEN {

val ¬ MimP5Stuff.ShiftLeft[val, dstBits-sonBits, bitsPerWord];

RETURN [val];

};

IF sonBits < valBits AND sonBits < bitsPerWord THEN {

val ¬ MimP5U.TakeField[val, valBits-sonBits, sonBits];

valBits ¬ sonBits;

};

SELECT valBits FROM

dstBits => {};

< dstBits => {

Force the padding to be on the right always

dummy: Node = MimP5U.MakeDummy[dstBits-valBits];

parts: NodeList ¬ MimP5U.MakeNodeList2[val, dummy];

parts ¬ MimP5Stuff.SimplifyParts[parts];

IF parts.rest = NIL

THEN val ¬ parts.first

ELSE val ¬ MimP5U.MakeComposite[parts, dstBits];

};

ENDCASE => ERROR;

This case should have been chop, not pad!

RETURN [val];

};

ord, val =>

l ¬ Exp[tb[node].son[1]];

cast, loophole => {

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

ut: CSEIndex = Clarify[MimP5U.OperandType[t]];

ub: NAT = MimP5U.BitsForType[ut];

ac: ArithClass = MimP5U.ArithClassForType[ut];

l ¬ Exp[son];

WITH u: seb[ut] SELECT FROM

subrange => IF NOT u.biased AND u.origin < 0 THEN {

lb: NAT = l.bits;

IF ub < lb THEN

Don't trust the sign bit resulting from casting

l ¬ MimP5U.TakeField[l, lb-ub, ub];

GO TO castDone;

};

ENDCASE;

SELECT ac.kind FROM

address, real => {

RRA: If someone should be so cruel as to LOOPHOLE a literal or some other small value into an address or a real number we don't want it extended using address extension or real extension, since those may be meaningless.

IF l.bits < ub THEN l ¬ MimP5U.ZeroExtend[l, ub];

};

ENDCASE;

EXITS castDone => {};

};

safen => {

cl: CodeList ¬ MimP5U.NewCodeList[];

nt: Tree.Link ¬ MimP5U.ProcessSafens[cl, [subtree[node]]];

l ¬ MimP5U.MaybeBlock[cl, Exp[nt]];

};

seqindex => l ¬ MimP5S.SeqIndex[node];

item => l ¬ Exp[tb[node].son[2]];

callx, portcallx => l ¬ MimP5S.Call[node];

substx => {

resultType: Symbols.Type = SymbolOps.TransferTypes[SymbolOps.own, MimP5U.OperandType[tb[node].son[1]]].typeOut;

l ¬ MimP5S.Subst[node, resultType];

};

signalx => l ¬ MimP5S.SigErr[node: node, error: FALSE, stmt: FALSE];

errorx => l ¬ MimP5S.SigErr[node: node, error: TRUE, stmt: FALSE];

syserrorx => l ¬ MimP5S.SysErrExp[node];

startx => l ¬ MimP5S.Start[node];

new => l ¬ MimP5.New[node];

listcons => l ¬ MimP5.ListCons[node];

create => l ¬ MimP5S.Create[node];

mwconst =>

SELECT tb[node].nSons FROM

0 => ERROR;

Did this ever happen?

1 => l ¬ Exp[tb[node].son[1]];

Does this still happen?

ENDCASE => {

This is a way of combining constants.

list: NodeList ¬ NIL;

bits: INT ¬ 0;

FOR i: NAT DECREASING IN [1..tb[node].nSons] DO

part: Node = Exp[tb[node].son[i]];

IF part # NIL THEN {

list ¬ MimP5U.MakeNodeList[part, list];

bits ¬ bits + part.bits;

};

ENDLOOP;

l ¬ MimP5U.MakeComposite[list, bits];

};

fork => l ¬ MimP5S.ForkExp[node];

joinx => l ¬ MimP5S.Join[node];

narrow => l ¬ NarrowExp[node];

check => l ¬ MimP5U.BoundsCheck[Exp[tb[node].son[1]], Exp[tb[node].son[2]]];

proccheck => l ¬ MimP5S.ProcCheck[node];

chop => {

val: Node ¬ Exp[tb[node].son[1]];

srcBits: BitCount = val.bits;

dstBits: BitCount = MimP5U.BitsForType[TreeType[node]];

SELECT srcBits FROM

dstBits => {};

< dstBits => ERROR;

This case should have been pad, not chop!

ENDCASE =>

val ¬ MimP5U.TakeField[val, 0, dstBits];

RETURN [val];

};

all => l ¬ MimP5.All[Tree.Null, node, ExprOptions];

nil => {

type: Type = MimP5U.OperandType[t];

n: BitCount = MimP5U.BitsForType[type];

IF n <= Target.bitsPerLongWord

THEN l ¬ MimP5U.MakeConstCard[0, n]

ELSE {

head: NodeList ¬ NIL;

tail: NodeList ¬ NIL;

rem: INT ¬ n;

WHILE rem > 0 DO

bits: INT ¬ MIN[n, Target.bitsPerLongWord];

nl: NodeList ¬ MimP5U.MakeNodeList[MimP5U.MakeConstCard[0, bits]];

IF tail = NIL THEN head ¬ nl ELSE tail.rest ¬ nl;

tail ¬ nl;

rem ¬ rem - bits;

ENDLOOP;

l ¬ MimP5U.MakeComposite[head, n];

};

gcrt => l ¬ MimP5.GetCanonicalType[node];

ENDCASE => l ¬ MimP5.FlowExp[node];

};

ENDCASE;

};

VarForSei: PUBLIC PROC [sei: ISEIndex] RETURNS [l: Var] = {

ut: CSEIndex ¬ Clarify[seb[sei].idType];

bits: INT ¬ MimP5U.BitsForType[ut];

IF seb[sei].linkSpace

THEN {

This comes to us from an interface or some other link

bits ¬ MimP5U.FullWordBits[bits];

l ¬ MimP5.VarForLink[SymbolOps.DecodeLink[seb[sei].idValue], bits];

Don't use the cache for this, since we may need to have different paths to the same link if we are using the global link, which is different for each procedure. Using the cache for these can result in aliasing which will cause the wrong location to be patched into a deep structure.

l.flags[constant] ¬ TRUE;

}

ELSE {

loc: Location;

ctx: CTXIndex ¬ seb[sei].idCtx;

id: INT;

level: ContextLevel ¬ SymbolOps.CtxLevel[SymbolOps.own, ctx];

index: Table.IndexRep ¬ LOOPHOLE[sei];

index.tag ¬ 0;

id ¬ LOOPHOLE[index];

WITH IntCodeUtils.Fetch[idTab, id] SELECT FROM

v: Var => RETURN [v];

ENDCASE;

IF NOT seb[sei].constant THEN

A variable may have an overiding width

bits ¬ MimP5U.FullWordBits[SymbolOps.DecodeCard[seb[sei].idInfo]];

SELECT level FROM

lZ =>

ERROR;

lG =>

loc ¬ z.NEW[LocationRep.globalVar ¬ [globalVar[id: 0]]];

ENDCASE => {

parent: IntCodeDefs.Label ¬ NIL;

IF MimP5.visibleContext # NIL THEN

There is a parent available

parent ¬ MimP5.visibleContext[level];

loc ¬ z.NEW[LocationRep.localVar ¬ [localVar[id: 0, parent: parent]]];

};

l ¬ MimP5U.MakeVar[bits: bits, id: id, loc: loc];

l.flags[named] ¬ seb[sei].hash # Symbols.nullName;

IF seb[sei].idDecl = 2 THEN l.flags[constant] ¬ TRUE;

[] ¬ IntCodeUtils.Store[idTab, id, l];

It is OK to cache these, since all localVar & globalVar locations are rewritten as necessary.

};

BinaryOp: PROC [node: Tree.Index, op: ArithSelector] RETURNS [Node] = {

generate code for +, -, *, /, etc.

exp: Node ¬ NIL;

ac: ArithClass ¬ MimP5U.ArithClassForTree[node];

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

op1: Node ¬ Exp[son1];

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

op2: Node ¬ Exp[son2];

bits: NAT ¬ MAX[NAT[ac.precision], NAT[op1.bits], NAT[op2.bits]];

Eventually need to do better about the width of the arithmentic

IF bits MOD bitsPerWord # 0 THEN bits ¬ bits + (bitsPerWord-(bits MOD bitsPerWord));

ac.precision ¬ bits;

IF bits > op1.bits THEN

This value needs extension

op1 ¬ MimP5U.Extend[op1, bits, MimP5U.OperandType[son1]];

IF bits > op2.bits THEN

This value needs extension

op2 ¬ MimP5U.Extend[op2, bits, MimP5U.OperandType[son2]];

exp ¬ MimP5U.BinaryArithOp[op, ac, op1, op2];

SELECT op FROM

add, sub => IF bits <= BITS[CARD] THEN {

const: CARD ¬ 0;

[op1, const] ¬ MimP5S.SplitArith[exp];

Try to rearrange additions/subtractions to combine constants at compile-time

SELECT TRUE FROM

op1 = NIL => exp ¬ MimP5U.MakeConstCard[const];

const = 0 => exp ¬ op1;

ENDCASE => {

An addition or subtraction is necessary

int: INT ¬ LOOPHOLE[const];

op ¬ add;

IF int < 0 THEN {int ¬ -int; op ¬ sub};

op2 ¬ MimP5U.MakeConstInt[int];

exp ¬ MimP5U.BinaryArithOp[op, ac, op1, op2];

};

ENDCASE;

RETURN [exp];

};

DotOrUparrow: PROC [mainnode: Tree.Index] RETURNS [l: Node] = {

generate code for "exp.field"

t1: Tree.Link = tb[mainnode].son[1];

tt: Type = TreeType[mainnode];

ac: ArithClass ¬ MimP5U.ArithClassForType[tt];

bitsForType: CARD = MimP5U.BitsForType[tt];

align: Symbols.Alignment ¬ MAX[

MimP5U.AlignmentFromTree[t1, TRUE],

minReferentAlignment];

ptr: Node ¬ Exp[t1];

bits: CARD ¬ bitsForType;

end: CARD ¬ bitsForType;

derefVar: Var ¬ MimP5U.Deref[n: ptr, bits: 0, align: align];

derefLoc: DerefLocation ¬ NARROW[derefVar.location];

IF tb[mainnode].name = uparrow

THEN {

bits ¬ end ¬ MimP5U.BitsForType[TreeType[mainnode]];

IF wordPadDeref AND bits > 0 AND bits < bitsPerWord THEN

IF ORD[align] >= ORD[MimData.wordAlignment] THEN

bits ¬ bitsPerWord;

l ¬ derefVar;

}

ELSE {

sei: ISEIndex = TreeOps.GetSe[tb[mainnode].son[2]];

psei: CSEIndex = Normalize[MimP5U.OperandType[t1]];

WITH se: seb[psei] SELECT FROM

ref => {

rsei: CSEIndex = Normalize[se.refType];

rbits: INT = MimP5U.BitsForType[rsei];

offset: BitAddress ¬ 0;

field: VLoc ¬ [disp: 0, size: Target.bitsPerWord];

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

offset ¬ offset + LeftPadding[rsei, bitsPerWord, rbits];

end ¬ offset+bits;

field ¬ [disp: offset, size: bits];

l ¬ MimP5U.TakeField[derefVar, offset, bits];

};

ENDCASE => ERROR;

};

l.bits ¬ bits;

IF tb[mainnode].attr1 THEN {

nil checking, see if hardware will do it

nilCheck: BOOL ¬ end > firstMappedBit;

IF nilCheck THEN

derefLoc.addr ¬ MimP5U.ApplyOp[

oper: MimP5U.MesaOpNode[nilck],

args: MimP5U.MakeNodeList[ptr],

bits: bitsPerPtr];

};

IF ac.kind = lastExtension AND bits > bitsForType AND bitsForType # 0 THEN {

Take a field to make sure to get only the right bits

start: INT = IF bitsForType <= bitsPerWord THEN bits-bitsForType ELSE 0;

l ¬ MimP5U.TakeField[l, start, bitsForType];

};

LeftPadding: PROC
[type: Type, vBits: BitCount, bits: BitCount] RETURNS [BitAddress] = {

IF bits < vBits AND vBits IN [1..bitsPerWord] AND bits # 0 THEN {

uType: CSEIndex = Normalize[type];

seqId: ISEIndex = SymbolOps.VariantField[SymbolOps.own, uType];

IF seqId # ISENull THEN {

seqSei: CSEIndex = Normalize[seb[seqId].idType];

WITH sse: seb[seqSei] SELECT FROM

sequence => RETURN [0];

A sequence can be arbitrary size, and is NOT right-justified

ENDCASE;

};

RETURN [vBits-bits];

};

RETURN [0];

};

SmartDeref: PROC [exp: Node, type: Type, align: Symbols.Alignment] RETURNS [Node] = {

bits: INT = MimP5U.BitsForType[type];

dBits: INT = MAX[minReferentBits, bits];

deref: Node ¬ MimP5U.Deref[exp, dBits, align];

IF bits IN [1..bitsPerWord) THEN {

off: INT ¬ LeftPadding[type, bitsPerWord, bits];

deref ¬ MimP5U.TakeField[deref, off, bits];

};

RETURN [deref];

};

SmartField: PROC [exp: Node, type: Type, off: BitAddress] RETURNS [Node] = {

bits: INT ¬ MimP5U.BitsForType[type];

off ¬ off + LeftPadding[type, MAX[bitsPerWord, exp.bits], bits];

RETURN [MimP5U.TakeField[exp, off, bits]];

};

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

generates code for "exp$field"

ac: ArithClass ¬ MimP5U.ArithClassForTree[node];

bitsForType: INT = MimP5U.BitsForType[TreeType[node]];

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

rsei: CSEIndex = MimP5U.OperandType[son1];

WITH seb[rsei] SELECT FROM

record => {

rcsei: RecordSEIndex = LOOPHOLE[rsei];

bitsForRec: INT ¬ MimP5U.BitsForType[rcsei];

sei: ISEIndex = TreeOps.GetSe[tb[node].son[2]];

rec: Node ¬ Exp[son1];

functionCall: BOOL = seb[rcsei].argument;

offset: BitAddress;

size: INT;

vl: VLoc;

varBits: INT ¬ rec.bits;

IF bitsForRec # 0 AND bitsForRec < bitsPerWord AND bitsForRec < varBits THEN {

The record is right-justified within the variable

(bitsForRec = 0 happens for COMPUTED sequences)

rec ¬ MimP5U.TakeField[rec, varBits-bitsForRec, bitsForRec];

varBits ¬ rec.bits;

};

IF functionCall

THEN [offset, size] ¬ MimP5U.FnField[sei]

ELSE [offset, size] ¬ MimP5U.RecField[sei];

vl ¬ [disp: offset, size: size];

IF varBits < bitsPerWord THEN {

This variable is smaller than a word, so adjust the location

vl ¬ MimP5U.AdjustLoc[vl: vl, rSei: rcsei, fSei: sei, tBits: varBits];

};

IF ac.kind = lastExtension AND vl.size > bitsForType THEN {

Narrow the field to make sure to get only the right bits

IF vl.size <= bitsPerWord THEN {

delta: INT ¬ vl.size - bitsForType;

vl.disp ¬ vl.disp + delta;

};

vl.size ¬ bitsForType;

};

IF vl.size < rec.bits THEN rec ¬ MimP5U.TakeField[rec, vl.disp, vl.size];

RETURN [rec];

};

ENDCASE => SIGNAL Bogus;

sei not for a record? How come?

RETURN [NIL];

};

Bogus: SIGNAL = CODE;

MachineCodeBytes: PROC [link: Tree.Link] RETURNS [Node ¬ NIL] = {

collectBytes: Tree.Scan = {

IF t # Tree.Null THEN

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

string => {

str: LONG STRING ¬ LiteralOps.StringValue[e.index];

FOR i: NAT IN [0..str.length) DO

TargetConversions.PutCard[writer, str[i].ORD, bitsPerByte];

ENDLOOP;

};

literal => {

byte: CARD ¬ LiteralOps.ValueBits[e.index];

TargetConversions.PutCard[writer, byte, bitsPerByte];

};

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

list => TreeOps.ScanList[t, collectBytes];

pad, cast, lengthen, shorten => {t ¬ tb[e.index].son[1]; LOOP};

ENDCASE => ERROR;

EXIT;

ENDLOOP;

};

writer: TargetConversions.Writer ¬ TargetConversions.NewWriter[];

collectBytes[link];

IF TargetConversions.BitsWritten[writer] = 0 THEN MimosaLog.ErrorTree[looksUgly, link];

RETURN [z.NEW[NodeRep.machineCode ¬ [details: machineCode[TargetConversions.WriterContents[writer]]]]];

};

MakeConst: PROC [lti: LTIndex] RETURNS [Node] = {

WITH ll: ltb[lti] SELECT FROM

short =>

SELECT LiteralOps.Value[lti].class FROM

unsigned => RETURN [MimP5U.MakeConstCard[LiteralOps.ValueCard[lti]]];

signed, either => RETURN [MimP5U.MakeConstInt[LiteralOps.ValueInt[lti]]];

real => {

RRA: This case is here to support an archaic representation for REAL literals. If we ever recompile the world this case should vanish!

int: INT = LOOPHOLE[LiteralOps.ValueReal[lti]];

RETURN [MimP5U.MakeConstInt[int]];

};

ENDCASE => RETURN [MimP5U.MakeConstCard[LiteralOps.ValueBits[lti]]];

long => {

bits: INT ¬ ll.bits;

writer: TargetConversions.Writer ¬ TargetConversions.NewWriter[];

align: NAT ¬ Target.Alignments[Target.AlignmentIndex.LAST];

FOR i: Target.AlignmentIndex IN Target.AlignmentIndex DO

IF Target.Alignments[i] >= bits THEN {align ¬ Target.Alignments[i]; EXIT};

ENDLOOP;

FOR i: CARDINAL IN [0..ll.max) DO

TargetConversions.PutCard[writer, SymbolOps.DecodeCard[ll.value[i]], 32];

ENDLOOP;

RETURN [z.NEW[NodeRep.const.bytes ¬ [
bits,
const[bytes[align, TargetConversions.WriterContents[writer]]]]]];

};

ENDCASE => ERROR;

};

stuff formerly in MimSelect

procedures

CaseStmtExp: PUBLIC PROC [root: Tree.Index, isExp: BOOL] RETURNS [Node] = {

generate code for CASE statment and expression

saveCaseType: Symbols.Type = MimCode.caseType;

saveCaseCV: Node = MimCode.caseCV;

saveExtracting: BOOL = MimCode.xtracting;

cvr: Node;

maxBits: INT ¬ 0;

minBits: INT ¬ INT.LAST;

cl: CodeList ¬ MimP5U.NewCodeList[];

armHead, armTail: CaseList ¬ NIL;

t3: Tree.Link ¬ tb[root].son[3];

caseVal: Tree.Link ¬ tb[root].son[1];

caseVarType: Type = MimP5U.OperandType[caseVal];

PruneTests: PROC [tests: NodeList] RETURNS [NodeList] = {

Performs a destructive pruning of all FALSE tests, terminating on a TRUE test, including all indeterminate tests.

head: NodeList ¬ NIL;

tail: NodeList ¬ NIL;

WHILE tests # NIL DO

next: NodeList ¬ tests.rest;

SELECT MimP5U.BoolTest[tests.first] FROM

false => {tests ¬ next; LOOP};

true => {next ¬ NIL; keepScanning ¬ FALSE};

ENDCASE;

tail ¬ IF tail = NIL THEN head ¬ tests ELSE tail.rest ¬ tests;

tail.rest ¬ NIL;

tests ¬ next;

ENDLOOP;

RETURN [head];

};

CaseArm: Tree.Scan = {

IF keepScanning THEN {

node: Tree.Index ¬ TreeOps.GetNode[t];

SELECT tb[node].name FROM

item => {

t is an item

tests: NodeList ¬ PruneTests[ExpList[tb[node].son[1], FALSE].head];

IF tests # NIL THEN {

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

body: Node ¬ IF isExp THEN MimP5.Exp[t2] ELSE MimP5.StatementTree[t2];

IF MimP5U.BoolTest[tests.first] = true THEN tests ¬ NIL;

IF tests = NIL AND armTail = NIL

THEN onlyBody ¬ body

ELSE {

arm: CaseList ¬ z.NEW[CaseListRep ¬ [tests: tests, body: body, rest: NIL]];

IF isExp AND body # NIL THEN {

nbits: INT ¬ body.bits;

SELECT TRUE FROM

armTail = NIL => maxBits ¬ minBits ¬ nbits;

nbits > maxBits => maxBits ¬ nbits;

nbits < minBits => minBits ¬ nbits;

ENDCASE;

};

IF armTail = NIL THEN armHead ¬ arm ELSE armTail.rest ¬ arm;

armTail ¬ arm;

};

caseswitch => ERROR;

Needs to be implemented?

ENDCASE => ERROR;

};

keepScanning: BOOL ¬ TRUE;

onlyBody: Node ¬ NIL;

MimCode.caseType ¬ caseVarType;

MimCode.xtracting ¬ FALSE;

cvr ¬ MimP5.Exp[caseVal];

{

WITH cvr SELECT FROM

const: ConstNode => MimCode.caseCV ¬ cvr;

var: Var =>

IF var.flags[constant] THEN MimCode.caseCV ¬ var ELSE GO TO needTemp;

ENDCASE => GO TO needTemp;

EXITS needTemp => {

cvTemp: Var ¬ MimP5S.Temporize[cl, cvr, caseVarType];

MimCode.caseCV ¬ cvTemp;

};

TreeOps.ScanList[tb[root].son[2], CaseArm];

IF keepScanning AND t3 # Tree.Null THEN {

ec: Node ¬ IF isExp THEN MimP5.Exp[t3] ELSE MimP5.StatementTree[t3];

SELECT TRUE FROM

armTail = NIL => {

There were no tests!

onlyBody ¬ ec;

GO TO onlyEndcase;

};

isExp AND ec # NIL => {

nbits: INT ¬ ec.bits;

SELECT nbits FROM

> maxBits => maxBits ¬ nbits;

< minBits => minBits ¬ nbits;

ENDCASE;

};

ENDCASE;

armTail ¬ armTail.rest ¬ z.NEW[CaseListRep ¬ [tests: NIL, body: ec, rest: NIL]];

EXITS onlyEndcase => {};

};

MimCode.caseCV ¬ saveCaseCV;

MimCode.caseType ¬ saveCaseType;

MimCode.xtracting ¬ saveExtracting;

IF armHead = NIL THEN {

There were no cases at all!

RETURN [MimP5U.MaybeBlock[cl, onlyBody]];

};

RETURN [MimP5U.MaybeBlock[cl, MakeBalancedCond[armHead, maxBits, minBits]]];

};

BindStmtExp: PUBLIC PROC [root: Tree.Index, isExp: BOOL] RETURNS [Node] = {

discrimination with copying

cl: CodeList = MimP5U.NewCodeList[];

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

sourceType: Type ¬ MimP5U.OperandType[son1];

unboundVar: Var = MimP5S.Temporize[cl: cl, n: MimP5.Exp[son1]];

tagExp: Node ¬ NIL;

deref: Node ¬ unboundVar;

endLabel: Label ¬ NIL;

caseListTree: Tree.Link = tb[root].son[2];

endCaseTree: Tree.Link = tb[root].son[3];

indirect: BOOL = tb[root].attr1;

typeDiscrim: BOOL = tb[root].attr2;

align: Symbols.Alignment = IF typeDiscrim
THEN MimData.worstAlignment
ELSE MimP5U.AlignmentFromType[sourceType, indirect];

nCases: INT = TreeOps.ListLength[caseListTree];

maxBits: INT ¬ 0;

minBits: INT ¬ 0;

caseListHead: IntCodeDefs.CaseList ¬ NIL;

caseListTail: IntCodeDefs.CaseList ¬ NIL;

casesActive: BOOL ¬ TRUE;

AddCase: PROC [test: Node, body: Tree.Link, var: Var] = {

node: Node ¬ IF isExp THEN MimP5.Exp[body] ELSE MimP5.StatementTree[body];

list: NodeList = IF test = NIL THEN NIL ELSE MimP5U.MakeNodeList[test];

newCase: IntCodeDefs.CaseList ¬ NIL;

nbits: INT ¬ 0;

IF var # NIL THEN {

We need to declare a newCase variable to be the bound variable

cl: CodeList = MimP5U.NewCodeList[];

temp: Node ¬ unboundVar;

IF temp # NIL AND temp.bits # var.bits THEN {

IF temp.bits < var.bits THEN ERROR;

We currently don't believe that this can happen

IF temp.bits < bitsPerWord THEN ERROR;

We currently don't believe that this can happen

IF var.bits < bitsPerWord THEN ERROR;

We currently don't believe that this can happen

temp ¬ MimP5U.TakeField[temp, 0, var.bits];

};

MimP5U.Declare[cl, var, temp];

node ¬ MimP5U.MaybeBlock[cl, node];

};

newCase ¬ MimP5U.MakeCaseList[list, node];

IF isExp AND node # NIL THEN {

nbits ¬ node.bits;

SELECT TRUE FROM

caseListTail = NIL => maxBits ¬ minBits ¬ nbits;

nbits > maxBits => maxBits ¬ nbits;

nbits < minBits => minBits ¬ nbits;

ENDCASE;

};

IF test = NIL AND endLabel # NIL THEN {

We have to get here from the initial NIL test

n: Node ¬ z.NEW [NodeRep.label ¬ [bits: nbits, details: label[endLabel]]];

endLabel.node ¬ node;

newCase.body ¬ n;

};

IF caseListTail # NIL THEN caseListTail.rest ¬ newCase ELSE caseListHead ¬ newCase;

caseListTail ¬ newCase;

IF list = NIL THEN casesActive ¬ FALSE;

};

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

IF NOT casesActive THEN RETURN;

WITH x: t SELECT TreeOps.GetTag[t] FROM

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

ditem => {

bodyTree: Tree.Link ¬ tb[x.index].son[2];

declTree: Tree.Link ¬ tb[x.index].son[1];

WITH y: declTree SELECT TreeOps.GetTag[declTree] FROM

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

decl => {

id: Tree.Link ¬ tb[y.index].son[1];

targetType: Type ¬ MimP5U.TypeForTree[tb[y.index].son[2]];

IF indirect THEN targetType ¬ MimP5U.ReferentType[targetType];

AddCase[

test: TypePredicate[sourceType, targetType, deref, tagExp],

body: bodyTree,

var: NARROW[MimP5.Exp[id]]];

};

ENDCASE => GO TO oops;

};

ENDCASE => GO TO oops;

EXITS oops => ERROR;

};

IF indirect

THEN {

Need to describe the indirection

MimP5U.MoreCode[cl, NilTest[unboundVar, endLabel ¬ MimP5U.AllocLabel[]]];

sourceType ¬ MimP5U.ReferentType[sourceType];

deref ¬ SmartDeref[unboundVar, sourceType, align];

IF typeDiscrim THEN {

We get the type into a good place here

tagExp ¬ MimP5U.ApplyOp[
oper: MimP5U.CedarOpNode[referentType],
args: MimP5U.MakeNodeList[unboundVar],
bits: bitsPerWord];

IF nCases > 1 THEN

We could use a temporary to avoid multiple type extractions

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

};

}

ELSE {

Clean up the description for right-justified subword records

deref ¬ SmartField[deref, sourceType, 0];

};

TreeOps.ScanList[caseListTree, EachCase];

IF casesActive THEN AddCase[NIL, endCaseTree, NIL];

RETURN [MimP5U.MaybeBlock[cl, MakeBalancedCond[caseListHead, maxBits, minBits]]];

};

NilTest: PROC [exp: Node, label: Label] RETURNS [Node] = {

nilTest: Node ¬ MimP5U.EqualTest[exp, MimP5U.MakeConstCard[0, exp.bits]];

RETURN [MimP5U.NodeIf[nilTest, MimP5U.MakeGoTo[label], NIL]];

};

MakeBalancedCond: PROC
[armHead: IntCodeDefs.CaseList, maxBits, minBits: INT] RETURNS [Node] = {

cl: CodeList ¬ NIL;

result: Node ¬ NIL;

IF maxBits > minBits THEN

The arms need to have equal bits, and some don't!

FOR each: IntCodeDefs.CaseList ¬ armHead, each.rest WHILE each # NIL DO

body: Node ¬ each.body;

IF body # NIL AND body.bits # maxBits THEN

We need to pad this arm

each.body ¬ MimP5U.ZeroExtend[body, maxBits];

FOR eachTest: NodeList ¬ each.tests, eachTest.rest WHILE eachTest # NIL DO

test: Node = eachTest.first;

IF test # NIL AND test.bits # 1 THEN eachTest.first ¬ MimP5U.ForceBool[test];

ENDLOOP;

FOR each: IntCodeDefs.CaseList ¬ armHead, each.rest WHILE each # NIL DO

tests: NodeList ¬ each.tests;

WHILE tests # NIL DO

testCmp: Node ¬ tests.first;

test: Node ¬ NIL;

IF NOT IntCodeUtils.SideEffectFree[testCmp, FALSE] THEN EXIT;

test ¬ GetCompareTarget[testCmp];

IF CacheWorthy[test] THEN {

Scan the rest of the tests for more occurences of the test

armList: IntCodeDefs.CaseList ¬ each;

testList: NodeList ¬ tests;

testBits: INT = test.bits;

var: Var ¬ NIL;

otherCmp: Node ¬ NIL;

other: Node ¬ NIL;

testList ¬ testList.rest;

IF testList = NIL THEN {

armList ¬ armList.rest;

IF armList = NIL THEN EXIT;

testList ¬ armList.tests;

IF testList = NIL THEN EXIT;

};

otherCmp ¬ testList.first;

IF NOT IntCodeUtils.SideEffectFree[otherCmp, FALSE] THEN EXIT;

other ¬ GetCompareTarget[otherCmp];

IF other # NIL AND IntCodeUtils.SimplyEqual[test, other] THEN {

We should substitute a newly created variable

IF cl = NIL THEN cl ¬ MimP5U.NewCodeList[];

IF var = NIL THEN {

We need to make a new temporary an initialize it

tempSei: ISEIndex = MimP5U.MakeTemp[cl, testBits].sei;

temp: Tree.Link = [symbol[tempSei]];

var ¬ NARROW[MimP5.Exp[temp]];

var.flags[constant] ¬ TRUE;

other ¬ MimP5U.Assign[var, test];

IF tests = armHead.tests

THEN {

Put the assignment up front where it can be easily seen; this should improve the generated code somewhat.

MimP5U.MoreCode[cl, other];

other ¬ var;

}

ELSE {

Put the assignment in the test itself

other.bits ¬ testBits;

};

SetCompareTarget[testCmp, other];

};

SetCompareTarget[otherCmp, var];

};

ENDLOOP;

EXIT;

};

tests ¬ tests.rest;

ENDLOOP;

result ¬ z.NEW[NodeRep.cond ¬ [bits: maxBits, details: cond[armHead]]];

IF cl # NIL THEN result ¬ MimP5U.MaybeBlock[cl, result];

RETURN [result];

};

GetCompareTarget: PROC [n: Node, left: BOOL ¬ TRUE] RETURNS [Node] = {

WITH n SELECT FROM

app: REF NodeRep.apply =>

WITH app.proc SELECT FROM

opNode: REF NodeRep.oper =>

WITH opNode.oper SELECT FROM

cmp: REF IntCodeDefs.OperRep =>

IF left THEN RETURN [app.args.first] ELSE RETURN [app.args.rest.first];

ENDCASE;

RETURN [NIL];

};

SetCompareTarget: PROC [n: Node, new: Node, left: BOOL ¬ TRUE] = {

WITH n SELECT FROM

app: REF NodeRep.apply =>

WITH app.proc SELECT FROM

opNode: REF NodeRep.oper =>

WITH opNode.oper SELECT FROM

cmp: REF IntCodeDefs.OperRep => {

IF left THEN app.args.first ¬ new ELSE app.args.rest.first ¬ new;

RETURN;

};

ENDCASE;

};

CacheWorthy: PROC [n: Node] RETURNS [BOOL] = {

IF n # NIL AND n.bits = bitsPerWord THEN

WITH n SELECT FROM

c: REF NodeRep.const =>

IF c.kind = refLiteral THEN RETURN [TRUE];

v: Var => WITH v.location SELECT FROM

local: REF LocationRep.localVar => {};

ENDCASE => RETURN [TRUE];

RETURN [FALSE];

};

NarrowExp: PUBLIC PROC [tree: Tree.Index] RETURNS [result: Node ¬ NIL] = {

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

exp: Node ¬ MimP5.Exp[son1];

indirect: BOOL = tb[tree].attr1;

opType: Type = MimP5U.OperandType[son1];

counted: BOOL = indirect AND (SymbolOps.RCType[SymbolOps.own, opType] = simple);

sourceType: Type ¬ IF indirect THEN MimP5U.ReferentType[opType] ELSE opType;

uSource: CSEIndex ¬ Clarify[sourceType];

endLabel: Label ¬ NIL;

deref: Node ¬ exp;

son2: Tree.Link = tb[tree].son[2];

treeType: Type =

IF son2 # Tree.Null

THEN MimP5U.TypeForTree[son2]

ELSE LOOPHOLE[tb[tree].info, Type];

targetType: Type =

IF indirect

THEN MimP5U.ReferentType[treeType]

ELSE treeType;

uTarget: CSEIndex = Clarify[targetType];

cl: CodeList = MimP5U.NewCodeList[];

SELECT TRUE FROM

counted AND SymbolOps.TypeForm[SymbolOps.own, uSource] = any => {

This goodie uses REF ANY discrimination.

root: Type = SymbolOps.TypeRoot[SymbolOps.own, targetType];

typeNode: Node = MimP5U.NodeForType[root];

uSource ¬ Clarify[sourceType ¬ root];

We now have a new source type

result ¬ MimP5U.ApplyOp[

oper: MimP5U.CedarOpNode[narrow],

args: MimP5U.MakeNodeList2[exp, typeNode],

bits: bitsPerRef];

IF uSource = uTarget THEN RETURN [MimP5U.MaybeBlock[cl, result]];

We do not need to discriminate beyond this level

exp ¬ MimP5S.Temporize[cl: cl, n: result];

We will need to discriminate further, so make a temporary to hold the result of the narrow check.

MimP5U.MoreCode[cl, NilTest[exp, endLabel ¬ MimP5U.AllocLabel[]]];

deref ¬ SmartDeref[exp, uSource, MimData.worstAlignment];

};

indirect => {

The discrimination uses a REF or POINTER to a specific type.

align: Symbols.Alignment = SELECT TRUE FROM

counted => MimData.worstAlignment,

wordPadDeref => minReferentAlignment,

ENDCASE => MimP5U.AlignmentFromType[sourceType, FALSE];

IF NOT IsLocalVar[exp] THEN exp ¬ MimP5S.Temporize[cl: cl, n: exp];

MimP5U.MoreCode[cl, NilTest[exp, endLabel ¬ MimP5U.AllocLabel[]]];

deref ¬ SmartDeref[exp, uSource, align];

};

ENDCASE => {

IF NOT IsLocalVar[exp] THEN exp ¬ MimP5S.Temporize[cl: cl, n: exp];

deref ¬ SmartField[exp, uSource, 0];

};

SELECT TRUE FROM

SymbolOps.TypeForm[SymbolOps.own, uTarget] = record
AND SymbolOps.TypeForm[SymbolOps.own, uSource] = record => {

typeTest: Node ¬ TagPredicate[deref, sourceType, targetType];

oops: Node ¬ MimP5U.ApplyOp[

oper: MimP5U.MesaOpNode[error],

args: MimP5U.MakeArgList[

MimP5U.MesaOpNode[op: narrowFault, bits: Target.bitsPerSignal]],

bits: exp.bits];

IF endLabel = NIL

THEN {

result ¬ MimP5U.MaybeBlock[cl, MimP5U.NodeIf[typeTest, exp, oops]];

}

ELSE {

MimP5U.MoreCode[cl,
MimP5U.NodeIf[typeTest, MimP5U.MakeGoTo[endLabel], NIL]];

oops.bits ¬ 0;

MimP5U.MoreCode[cl, oops];

MimP5U.InsertLabel[cl, endLabel];

result ¬ MimP5U.MaybeBlock[cl, exp];

};

ENDCASE => ERROR;

I don't know how we got here, but it is not good!

};

TypeRel: PUBLIC PROC [tree: Tree.Index] RETURNS [test: Node ¬ NIL] = {

for ISTYPE[exp, type]

sourceType: Type ¬ MimP5U.OperandType[tb[tree].son[1]];

exp: Node ¬ MimP5.Exp[tb[tree].son[1]];

deref: Node ¬ exp;

derefBits: INT ¬ deref.bits;

derefOff: INT ¬ 0;

indirect: BOOL = tb[tree].attr1;

refAny: BOOL = tb[tree].attr2; -- RRA: what is this really?

uSource: CSEIndex ¬ Clarify[sourceType];

targetType: Type ¬

IF tb[tree].son[2] # Tree.Null

THEN MimP5U.TypeForTree[tb[tree].son[2]]

ELSE LOOPHOLE[tb[tree].info, Type];

uTarget: CSEIndex ¬ Clarify[targetType];

counted: BOOL = indirect AND (SymbolOps.RCType[SymbolOps.own, uSource] = simple);

For REF ANY discrimination

align: Symbols.Alignment ¬ IF counted
THEN MimData.worstAlignment
ELSE MimP5U.AlignmentFromType[sourceType];

typeExp: Node ¬ NIL;

cl: CodeList ¬ NIL;

IF NOT IsLocalVar[exp] THEN {

We may have to look twice at this thing. Make sure that it is easy to use.

cl ¬ MimP5U.NewCodeList[];

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

};

IF indirect

THEN {

The discrimination uses a REF or POINTER to a type.

sourceType ¬ MimP5U.ReferentType[sourceType];

uSource ¬ Clarify[sourceType];

targetType ¬ MimP5U.ReferentType[targetType];

uTarget ¬ Clarify[targetType];

derefBits ¬ MimP5U.BitsForType[uTarget];

deref ¬ SmartDeref[exp, uSource, align];

}

ELSE {

deref ¬ SmartField[exp, sourceType, 0];

};

IF counted AND SymbolOps.TypeForm[SymbolOps.own, uSource] = any THEN {

There is REF ANY discrimination, so make up something to use in discriminating the type

typeExp ¬ MimP5U.ApplyOp[
oper: MimP5U.CedarOpNode[referentType],
args: MimP5U.MakeNodeList[exp],
bits: bitsPerWord];

};

test ¬ TypePredicate[sourceType, targetType, deref, typeExp];

IF test = NIL THEN RETURN [MimCode.trueNode];

IF indirect OR refAny THEN

NIL agrees with any type

test ¬ MimP5U.NodeOr[IsNil[exp], test];

IF cl # NIL THEN test ¬ MimP5U.MaybeBlock[cl, test];

};

GetCanonicalType: PUBLIC PROC [tree: Tree.Index] RETURNS [l: Node] = {

oper: Node;

IF tb[tree].attr2

THEN oper ¬ MimP5U.CedarOpNode[referentType]

ELSE {

type: CSEIndex ¬ MimP5U.OperandType[tb[tree].son[1]];

SELECT SymbolOps.XferMode[SymbolOps.own, type] FROM

proc => oper ¬ NIL; -- MimP5U.CedarOpNode[procType];

signal, error => oper ¬ NIL; -- MimP5U.CedarOpNode[signalType];

ENDCASE};

l ¬ MimP5U.ApplyOp[oper: oper,
args: MimP5U.MakeArgList[MimP5.Exp[tb[tree].son[1]]], bits: bitsPerWord];

};

Utilities

TypePredicate: PROC [source: Type, dest: Type, var: Node, typeExp: Node ¬ NIL]
RETURNS [node: Node ¬ NIL] = {

TypePredicate tests the given variable for being of a particular type. The source is the type of the thing being discriminated (indirection has been removed). The dest is the type that we are testing against (indirection has been removed). The var is the variable that holds the thing that we are discriminating (if discriminating a REF or POINTER then the var has already had Deref applied). The typeExp, if not NIL, is the variable that hold the referent type for REF dscrimination.

referentTest: Node ¬ NIL;

IF typeExp # NIL THEN {

REF ANY discrimination

root: Type = SymbolOps.TypeRoot[SymbolOps.own, dest];

IF SymbolOps.TypeForm[SymbolOps.own, root] = any

THEN

If discriminating to plain old REF the type test is vacuously TRUE

RETURN [NIL]

ELSE {

typeNode: Node ¬ MimP5U.NodeForType[root];

referentTest ¬ MimP5U.EqualTest[typeNode, typeExp];

IF SymbolOps.EqTypes[SymbolOps.own, root, dest] THEN RETURN [referentTest];

source ¬ root;

After the referent type discrimination the source type is presumed to be the root of the destination type.

};

node ¬ TagPredicate[var, source, dest];

IF referentTest # NIL THEN node ¬ MimP5U.NodeAnd[referentTest, node];

};

TagPredicate: PROC [var: Node, type, target: Type] RETURNS [Node] = {

TagPredicate returns the node structure necessary to discriminate the given variable (var) from its assumed type (type) down to the target type (target). Multiple levels of discrimination are supported.

uTarget: CSEIndex = Clarify[target];

link: Type = SymbolOps.TypeLink[SymbolOps.own, target];

This is the next variant type containing the target type

uLink: CSEIndex = Clarify[link];

This is the next variant type containing the target type

uType: CSEIndex ¬ Clarify[type];

This is the under type assumed for the variable

uTypeBits: BitCount ¬ MimP5U.BitsForType[uType];

overTestNode: Node ¬ NIL;

testNode: Node ¬ NIL;

uu: CSEIndex;

IF EquivTypes[uType, uTarget] THEN {

This case is dumb, but permitted

RETURN [MimCode.trueNode];

};

IF NOT SymbolOps.EqTypes[SymbolOps.own, uLink, uType] THEN {

We are not yet discriminated enough

IF NOT SymbolOps.EqTypes[SymbolOps.own,
SymbolOps.TypeRoot[SymbolOps.own, uLink],
SymbolOps.TypeRoot[SymbolOps.own, uType]] THEN ERROR;

In this case we will never converge (should NEVER happen)

overTestNode ¬ TagPredicate[var, type, link];

type ¬ link;

uType ¬ uLink;

};

At this point we have sufficiently discriminated such that one more test will do it.

uu ¬ Clarify[seb[SymbolOps.VariantField[SymbolOps.own, uType]].idType];

WITH u: seb[uu] SELECT FROM

union => {

offset: BitAddress;

bits: INT;

tagSei: ISEIndex = u.tagSei;

tagVal: CARD = MimP5U.VariantTag[target, u.caseCtx];

[offset, bits] ¬ MimP5U.RecField[tagSei];

testNode ¬ MimP5U.EqualTest[

MimP5U.TakeField[var, offset, bits],

MimP5U.MakeConstCard[tagVal]];

IF overTestNode # NIL THEN testNode ¬ MimP5U.NodeAnd[overTestNode, testNode];

RETURN [testNode];

};

ENDCASE => ERROR;

};

EquivTypes: PROC [type1, type2: CSEIndex] RETURNS [BOOL] = {

RETURN [Types.Equivalent[[SymbolOps.own, type1], [SymbolOps.own, type2]]];

};

IsNil: PROC [exp: Node] RETURNS [Node] = {

RETURN [MimP5U.ApplyOp[

oper: MimP5U.CompareOp[eq, [address, FALSE, exp.bits]],

args: MimP5U.MakeArgList2[exp, MimP5U.MakeConstCard[0, exp.bits]],

bits: 1]];

};

IsLocalVar: PROC [node: Node] RETURNS [BOOL] = {

WITH node SELECT FROM

v: Var => WITH v.location SELECT FROM

loc: LocalVarLocation => RETURN [TRUE];

ENDCASE;

RETURN [FALSE];

};

Clarify: PUBLIC PROC [type: Type] RETURNS [CSEIndex] = {

Removes layers of definition and opaque from the given type.

sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];

WITH t: seb[sei] SELECT FROM

opaque => {

nSei: CSEIndex ¬
Types.OpaqueValue[ [SymbolOps.own, sei], SymbolOps.own].sei;

IF nSei # sei THEN {type ¬ nSei; LOOP};

};

ENDCASE;

RETURN [sei];

ENDLOOP;

};

Normalize: PUBLIC PROC [type: Type] RETURNS [CSEIndex] = {

Removes layers of definition, subrange, and opaque from the given type.

sei: CSEIndex = SymbolOps.UnderType[SymbolOps.own, type];

WITH t: seb[sei] SELECT FROM

opaque => {

nSei: CSEIndex ¬
Types.OpaqueValue[ [SymbolOps.own, sei], SymbolOps.own].sei;

IF nSei # sei THEN {type ¬ nSei; LOOP};

};

subrange => {

type ¬ t.rangeType;

LOOP;

};

ENDCASE;

RETURN [sei];

ENDLOOP;

};

bases & notifier

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

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

bb: Symbols.Base ¬ NIL; -- body entry base (local copy)

ltb: Literals.Base ¬ NIL; -- literal base (local copy)

stb: Literals.Base ¬ NIL; -- string base (local copy)

ExpressionNotify: Alloc.Notifier = {

called by allocator whenever table area is repacked

seb ¬ base[Symbols.seType];

bb ¬ base[Symbols.bodyType];

tb ¬ base[Tree.treeType];

ltb ¬ base[Literals.ltType];

stb ¬ base[Literals.stType];

idTab ¬ IntCodeUtils.NewIdTab[];

};

idTab: IntCodeUtils.IdTab ¬ NIL;

recentExp: PUBLIC Tree.Link; -- for debugging

MimCode.RegisterNotifier[ExpressionNotify];