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

Pass4Ops.mesa

Satterthwaite, June 25, 1986 9:46:15 am PDT

Russ Atkinson (RRA) October 11, 1989 6:46:41 pm PDT

DIRECTORY

Alloc USING [Notifier],

ConstArith USING [Add, Compare, Const, Div, DivByZero, FromCard, FromInt, Mod, Mul, Overflow, Sub, ToCard, ToInt],

Literals USING [Base, LitDescriptor, LTIndex, ltType],

LiteralOps USING [DescriptorValue, FindCard, FindInt, Value, ValueBits, ValueCard, ValueInt],

MimosaLog USING [ErrorTree],

MimP4 USING [OperandType, RelOp, RepForType, Repr, tFALSE, TreeBounds, tTRUE],

SymbolOps USING [EncodeCard],

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

TreeOps USING [FreeNode, GetNode, GetTag, ScanList, UpdateList];

Pass4Ops: PROGRAM

IMPORTS ConstArith, LiteralOps, MimosaLog, MimP4, SymbolOps, TreeOps

EXPORTS MimP4 = {

OPEN TreeOps;

RelOp: TYPE = MimP4.RelOp;

Repr: TYPE = MimP4.Repr;

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

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

OpsNotify: PUBLIC Alloc.Notifier = {

called by allocator whenever table area is repacked

tb ¬ base[Tree.treeType];

ltb ¬ base[Literals.ltType];

};

literals

TreeLiteral: PUBLIC PROC [t: Tree.Link, allowLong: BOOL ¬ FALSE] RETURNS [BOOL] = {

WITH t SELECT GetTag[t] FROM

literal => RETURN [TRUE];

subtree =>

SELECT tb[index].name FROM

cast => {t ¬ tb[index].son[1]; LOOP};

mwconst =>

IF allowLong THEN

SELECT MimP4.RepForType[MimP4.OperandType[t]] FROM

signed, unsigned => RETURN [TRUE];

ENDCASE;

RETURN [FALSE];

ENDLOOP;

};

TreeLiteralConst: PUBLIC PROC [t: Tree.Link] RETURNS [ConstArith.Const] = {

WITH e: t SELECT GetTag[t] FROM

literal => {

lti: Literals.LTIndex = e.index;

SELECT LiteralOps.Value[lti].class FROM

unsigned, either => RETURN [ConstArith.FromCard[LiteralOps.ValueCard[lti]]];

signed => RETURN [ConstArith.FromInt[LiteralOps.ValueInt[lti]]];

ENDCASE;

};

subtree => {

node: Tree.Index = e.index;

SELECT tb[node].name FROM

cast => {

Must be careful here just in case some goon has LOOPHOLE'd a negative number into a CARD or a big CARD into an INT. That could pose problems. For now we punt to the other two routines.

SELECT MimP4.RepForType[MimP4.OperandType[t]] FROM

signed => {

li: INT ¬ TreeLiteralInt[t];

RETURN [ConstArith.FromInt[li]];

};

ENDCASE => {

lc: CARD ¬ TreeLiteralCard[t];

RETURN [ConstArith.FromCard[lc]];

};

mwconst => {

res: ConstArith.Const ¬ ConstArith.FromInt[0];

shift: ConstArith.Const ¬ ConstArith.Add[ConstArith.FromCard[CARD.LAST], ConstArith.FromCard[1]];

FOR i: NAT IN [1..tb[e.index].nSons] DO

term: ConstArith.Const ¬ TreeLiteralConst[tb[e.index].son[i]];

res ¬ ConstArith.Add[ConstArith.Mul[res, shift], term];

ENDLOOP;

RETURN [res];

};

ENDCASE;

};

ENDCASE;

ERROR;

ENDLOOP;

};

TreeLiteralCard: PUBLIC PROC [t: Tree.Link] RETURNS [CARD] = {

loophole: BOOL ¬ FALSE;

WITH e: t SELECT GetTag[t] FROM

literal => {

lti: Literals.LTIndex = e.index;

IF loophole THEN RETURN [LiteralOps.ValueBits[lti]];

SELECT LiteralOps.Value[lti].class FROM

unsigned, either => RETURN [LiteralOps.ValueCard[lti]];

signed => RETURN [LiteralOps.ValueInt[lti]];

ENDCASE;

};

subtree => {

node: Tree.Index = e.index;

SELECT tb[node].name FROM

cast => {t ¬ tb[node].son[1]; loophole ¬ TRUE; LOOP};

ENDCASE;

};

ENDCASE;

ERROR;

ENDLOOP;

};

TreeLiteralInt: PUBLIC PROC [t: Tree.Link] RETURNS [INT] = {

loophole: BOOL ¬ FALSE;

WITH e: t SELECT GetTag[t] FROM

literal => {

lti: Literals.LTIndex = e.index;

IF loophole THEN RETURN [LOOPHOLE[LiteralOps.ValueBits[lti], INT]];

SELECT LiteralOps.Value[lti].class FROM

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

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

ENDCASE;

};

subtree => {

node: Tree.Index = e.index;

SELECT tb[node].name FROM

cast => {t ¬ tb[node].son[1]; loophole ¬ TRUE; LOOP};

ENDCASE;

};

ENDCASE;

ERROR;

ENDLOOP;

};

MakeTreeLiteralCard: PUBLIC PROC [val: CARD] RETURNS [Tree.Link] = {

RETURN [[literal[LiteralOps.FindCard[val]]]];

};

MakeTreeLiteralInt: PUBLIC PROC [val: INT] RETURNS [Tree.Link] = {

RETURN [[literal[LiteralOps.FindInt[val]]]];

};

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

WITH t SELECT GetTag[t] FROM

literal => RETURN [TRUE];

subtree =>

SELECT tb[index].name FROM

mwconst => RETURN [TRUE];

cast => {t ¬ tb[index].son[1]; LOOP};

ENDCASE;

RETURN [FALSE];

ENDLOOP;

};

TreeLiteralDesc: PUBLIC PROC [t: Tree.Link] RETURNS [Literals.LitDescriptor] = {

WITH t SELECT GetTag[t] FROM

literal => RETURN [LiteralOps.DescriptorValue[index]];

subtree => {

node: Tree.Index = index;

SELECT tb[node].name FROM

cast => {t ¬ tb[node].son[1]; LOOP};

ENDCASE;

};

ENDCASE;

ERROR;

ENDLOOP;

};

LiteralRep: PUBLIC PROC [t: Tree.Link, rep: Repr] RETURNS [Repr] = {

SELECT rep FROM

none, other, real, either, signed, unsigned, addr => {};

ENDCASE =>

IF StructuredLiteral[t] THEN rep ¬ other;

RETURN [rep];

};

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

RETURN [TreeLiteralCard[t] # 0];

};

ShortToLong: PUBLIC PROC [node: Tree.Index, rep: Repr] RETURNS [val: Tree.Link] = {

assumes that the literal is already long internally

RETURN [tb[node].son[1]];

};

LongToShort: PUBLIC PROC [node: Tree.Index, rep: Repr] RETURNS [val: Tree.Link] = {

assumes that the literal is already long internally

RETURN [tb[node].son[1]];

};

ZeroP: PUBLIC PROC [t: Tree.Link] RETURNS [zero: BOOL] = {

IF ~StructuredLiteral[t]

THEN zero ¬ FALSE

ELSE {

desc: Literals.LitDescriptor = TreeLiteralDesc[t];

FOR i: CARDINAL IN [0..desc.words) DO

IF ltb[desc.offset][i] # SymbolOps.EncodeCard[0] THEN RETURN [FALSE];

ENDLOOP;

RETURN [TRUE];

};

dispatch

Mode: TYPE = {signed, unsigned, real, addr, other};

ModeMap: PACKED ARRAY Repr OF Mode = [

signed, -- none (0)

signed, -- signed (1)

unsigned, -- unsigned (2)

signed, -- either (3)

real, -- real (4)

real, -- ...

addr, -- addr (8)

addr, -- ...

other, -- other (16)

other, -- ...

other -- all (31)

];

IntOp: TYPE = Tree.NodeName [intOO .. intCC];

Test: ARRAY Mode OF PROC [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOL] = [

TestEither, TestEither, TestEither, TestEither, TestOther

];

UnaryOp: ARRAY Mode OF PROC [node: Tree.Index] RETURNS [Tree.Link] = [

UnarySigned, UnaryUnsigned, OpError, OpError, OpError

];

BinaryOp: ARRAY Mode OF PROC [node: Tree.Index] RETURNS [Tree.Link] = [

BinarySigned, BinaryUnsigned, OpError, BinaryUnsigned, OpError

];

FoldExpr: PUBLIC PROC [node: Tree.Index, rep: Repr] RETURNS [val: Tree.Link] = {

SELECT tb[node].name FROM

plus, minus, times, div, mod => val ¬ BinaryOp[ModeMap[rep]][node];

abs, uminus => val ¬ UnaryOp[ModeMap[rep]][node];

relE, relN, relL, relGE, relG, relLE => {

val ¬ IF RelTest [l: tb[node].son[1], r: tb[node].son[2], op: tb[node].name, rep: rep]

THEN MimP4.tTRUE

ELSE MimP4.tFALSE;

FreeNode[node];

};

in, notin => {

val ¬ IF IntervalTest [l: tb[node].son[1], r: tb[node].son[2], rep: rep]
= (tb[node].name = in)

THEN MimP4.tTRUE

ELSE MimP4.tFALSE;

FreeNode[node];

};

min, max => {

VoidItem: Tree.Map = {RETURN [IF t = val THEN Tree.Null ELSE t]};

started: BOOL ¬ FALSE;

Item: Tree.Scan = {

SELECT TRUE FROM

~started => {started ¬ TRUE; val ¬ t};

RelTest[t, val, test, rep] => val ¬ t;

ENDCASE;

};

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

test: RelOp = IF tb[node].name = min THEN relL ELSE relG;

ScanList[list, Item];

tb[node].son[1] ¬ UpdateList[list, VoidItem];

FreeNode[node];

};

ENDCASE => ERROR

};

RelTest: PUBLIC PROC [l, r: Tree.Link, op: RelOp, rep: Repr] RETURNS [BOOL] = {

OpMap: ARRAY RelOp OF RECORD [map: RelOp, sense: BOOL] = [

[relE, TRUE], [relE, FALSE], [relL, TRUE], [relL, FALSE], [relG, TRUE], [relG, FALSE]];

RETURN [Test[ModeMap[rep]][l, r, OpMap[op].map] = OpMap[op].sense];

};

IntervalTest: PROC [l, r: Tree.Link, rep: Repr] RETURNS [BOOL] = {

InTest: ARRAY IntOp OF RECORD [lb, ub: RelOp] = [

[relG, relL], [relG, relLE], [relGE, relL], [relGE, relLE]];

subNode: Tree.Index = GetNode[r];

op: IntOp = tb[subNode].name;

RETURN [

RelTest[l, tb[subNode].son[1], InTest[op].lb, rep]

AND

RelTest[l, tb[subNode].son[2], InTest[op].ub, rep] ]

};

operations

TestEither: PROC [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOL] = {

v1: ConstArith.Const = TreeLiteralConst[t1];

v2: ConstArith.Const = TreeLiteralConst[t2];

SELECT ConstArith.Compare[v1, v2] FROM

less => RETURN [op = relL];

greater => RETURN [op = relG];

ENDCASE => RETURN [op = relE];

};

UnarySigned: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {

ENABLE ConstArith.Overflow => GO TO Overflow;

lb, ub: ConstArith.Const;

[lb, ub] ¬ MimP4.TreeBounds[ [subtree[node]], signed ];

IF lb # ub THEN GO TO Overflow;

t ¬ MakeTreeLiteralInt[ConstArith.ToInt[lb]];

FreeNode[node];

EXITS

Overflow => {

tb[node].attr3 ¬ TRUE;

t ¬ [subtree[node]];

MimosaLog.ErrorTree[overflow, t];

}

};

BinarySigned: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {

ENABLE ConstArith.Overflow, ConstArith.DivByZero => GO TO Overflow;

v: ConstArith.Const;

v1: ConstArith.Const = TreeLiteralConst[tb[node].son[1]];

v2: ConstArith.Const = TreeLiteralConst[tb[node].son[2]];

SELECT tb[node].name FROM

plus => v ¬ ConstArith.Add[v1, v2];

minus => v ¬ ConstArith.Sub[v1, v2];

times => v ¬ ConstArith.Mul[v1, v2];

div => v ¬ ConstArith.Div[v1, v2];

mod => v ¬ ConstArith.Mod[v1, v2];

ENDCASE => ERROR;

t ¬ MakeTreeLiteralInt[ConstArith.ToInt[v]];

FreeNode[node];

EXITS

Overflow => {

tb[node].attr3 ¬ TRUE;

t ¬ [subtree[node]];

MimosaLog.ErrorTree[overflow, t];

}

};

UnaryUnsigned: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {

ENABLE ConstArith.Overflow => GO TO Overflow;

v1: CARD ¬ TreeLiteralCard[tb[node].son[1]];

SELECT tb[node].name FROM

uminus => v1 ¬ 0-v1;

abs => NULL;

ENDCASE => ERROR;

t ¬ MakeTreeLiteralCard[v1];

FreeNode[node];

EXITS

Overflow => {

tb[node].attr3 ¬ FALSE;

t ¬ [subtree[node]];

MimosaLog.ErrorTree[overflow, t]}

};

BinaryUnsigned: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {

ENABLE ConstArith.Overflow, ConstArith.DivByZero => GO TO Overflow;

v: ConstArith.Const;

v1: ConstArith.Const = TreeLiteralConst[tb[node].son[1]];

v2: ConstArith.Const = TreeLiteralConst[tb[node].son[2]];

SELECT tb[node].name FROM

plus =>

v ¬ ConstArith.Add[v1, v2];

minus =>

v ¬ ConstArith.Sub[v1, v2];

times =>

v ¬ ConstArith.Mul[v1, v2];

div =>

v ¬ ConstArith.Div[v1, v2];

mod =>

v ¬ ConstArith.Mod[v1, v2];

ENDCASE => ERROR;

t ¬ MakeTreeLiteralCard[ConstArith.ToCard[v]];

FreeNode[node];

EXITS

Overflow => {

tb[node].attr3 ¬ FALSE;

t ¬ [subtree[node]];

MimosaLog.ErrorTree[overflow, t]}

};

TestOther: PROC [t1, t2: Tree.Link, op: RelOp] RETURNS [BOOL] = {

RETURN [SELECT op FROM

relE => TreeLiteralDesc[t1] = TreeLiteralDesc[t2],

relN => TreeLiteralDesc[t1] # TreeLiteralDesc[t2],

ENDCASE => ERROR]

};

OpError: PROC [node: Tree.Index] RETURNS [t: Tree.Link] = {ERROR};