-- file Pass3P.mesa
-- last modified by Satterthwaite, July 27, 1983 2:24 pm
DIRECTORY
Alloc: TYPE USING [Notifier, AddNotify, DropNotify, Top, Words],
ComData: TYPE USING [
defBodyLimit, interface, nBodies, nInnerBodies, table, textIndex, zone],
CompilerUtil: TYPE USING [],
Log: TYPE USING [Error, ErrorSei],
Symbols: TYPE USING [
Base, BodyInfo, BodyRecord, ContextLevel, SERecord,
ISEIndex, CSEIndex, RecordSEIndex, CTXIndex, BTIndex, CBTIndex,
nullName, ISENull, CSENull, RecordSENull, CTXNull, BTNull,
lL, lZ, RootBti, typeTYPE, seType, ctxType, mdType, bodyType],
SymbolOps: TYPE USING [
ArgCtx, CopyArgSe, CopyXferType, CtxEntries, DelinkBti, FindExtension,
FirstCtxSe, LinkBti, MakeNonCtxSe, MakeSeChain, NewCtx, NextLevel,
NextSe, ParentBti, SetSeLink, SearchContext, TransferTypes,
StaticNestError],
Tree: TYPE USING [Base, Index, Link, Map, Scan, Null, NullIndex, treeType],
TreeOps: TYPE USING [
CopyTree, FreeNode, FreeTree, GetNode, ListTail, MakeList,
MarkShared, NthSon, OpName, PopTree, PushList, PushNode, PushTree,
ScanList, ScanSons, SetAttr, SetInfo, Shared, UpdateList, UpdateLeaves];
Pass3P: PROGRAM
IMPORTS
Alloc, Log, SymbolOps, TreeOps,
dataPtr: ComData
EXPORTS CompilerUtil = {
OPEN TreeOps, SymbolOps, Symbols;
tb: Tree.Base; -- tree base address (local copy)
seb: Symbols.Base; -- se table base address (local copy)
ctxb: Symbols.Base; -- context table base address (local copy)
mdb: Symbols.Base; -- module table base address (local copy)
bb: Symbols.Base; -- body table base address (local copy)
PostNotify: Alloc.Notifier = {
-- called by allocator whenever table area is repacked
tb ← base[Tree.treeType];
seb ← base[seType]; ctxb ← base[ctxType]; mdb ← base[mdType];
bb ← base[bodyType]};
-- driver
P3Postlude: PUBLIC PROC [expand: BOOL] = {
(dataPtr.table).AddNotify[PostNotify];
IF expand THEN {LinkImportedBodies[]; ExpandInlines[RootBti]};
(dataPtr.table).DropNotify[PostNotify]};
-- included body copying
LinkImportedBodies: PROC = {
next: BTIndex;
btLimit: BTIndex = (dataPtr.table).Top[bodyType];
FOR bti: BTIndex ← LOOPHOLE[dataPtr.defBodyLimit], next UNTIL bti = btLimit DO
WITH body: bb[bti] SELECT FROM
Callable => {
IF body.inline THEN {body.link ← bb[RootBti].link; bb[RootBti].link ← [sibling, bti]};
next ← bti + (SELECT body.nesting FROM
Inner => BodyRecord.Callable.Inner.SIZE,
Catch => BodyRecord.Callable.Catch.SIZE,
ENDCASE => BodyRecord.Callable.Outer.SIZE)};
ENDCASE => next ← bti + BodyRecord.Other.SIZE;
ENDLOOP};
-- inline expansion
-- state information
currentMaster: CBTIndex;
masterBody: Tree.Index;
copyCtx: CTXIndex;
copying: BOOL;
substSafe: BOOL;
currentEnclosing: BTIndex;
bodyNesting: CARDINAL;
aStack: AList; -- current association list
AItem: TYPE = RECORD [id: ISEIndex, name: BOOL, val: Tree.Link];
ANode: TYPE = RECORD [
next: AList,
ctx: CTXIndex,
nItems: CARDINAL,
map: SEQUENCE maxItems: CARDINAL OF AItem];
AList: TYPE = LONG POINTER TO ANode;
-- overall control
ExpandInlines: PROC [rootBti: BTIndex] = {
bti: BTIndex ← rootBti;
aStack ← NIL; sharingMap ← NIL;
UNTIL bti = BTNull DO
ExpandInlines[bb[bti].firstSon];
WITH body: bb[bti] SELECT FROM
Callable => IF body.inline THEN ExpandCalls[LOOPHOLE[bti, CBTIndex]];
ENDCASE;
bti ← IF bb[bti].link.which=parent THEN BTNull ELSE bb[bti].link.index;
ENDLOOP};
ExpandCalls: PROC [bti: CBTIndex] = {
saveIndex: CARDINAL = dataPtr.textIndex;
sei: ISEIndex = bb[bti].id;
current, subNode: Tree.Index;
dataPtr.textIndex ← bb[bti].sourceIndex;
WITH body: bb[bti].info SELECT FROM
Internal => {
currentMaster ← bti;
IF seb[sei].mark4 THEN {
t: Tree.Link = FindExtension[sei].tree;
ComputeArgCounts[bb[bti].ioType, t];
masterBody ← GetNode[t]}
ELSE masterBody ← body.bodyTree;
copying ← TRUE;
UNTIL (current ← body.thread) = Tree.NullIndex DO
discard: BOOL;
-- process the thread (son[1])
subNode ← GetNode[tb[current].son[1]];
discard ← tb[subNode].attr1;
tb[current].son[1] ← tb[subNode].son[1];
currentEnclosing ← tb[subNode].info;
body.thread ← GetNode[tb[subNode].son[2]];
tb[subNode].son[1] ← tb[subNode].son[2] ← Tree.Null;
FreeNode[subNode];
tb[current].shared ← FALSE;
IF body.thread = Tree.NullIndex
AND (~dataPtr.interface OR bb[bti].level > lL) THEN copying ← FALSE;
SELECT TRUE FROM
discard => DiscardCall[current];
~RecursiveSubst[bti, currentEnclosing] => ExpandCall[current]
ENDCASE => Log.ErrorSei[recursiveInline, bb[bti].id];
ENDLOOP};
ENDCASE => ERROR;
dataPtr.textIndex ← saveIndex};
DiscardCall: PROC [node: Tree.Index] = INLINE { -- orphan subtree
[] ← DiscardTree[[subtree[node]]]};
ExpandCall: PROC [node: Tree.Index] = {
typeIn, typeOut: RecordSEIndex;
masterCtx: CTXIndex = bb[currentMaster].localCtx;
formalCtx: CTXIndex;
seChain, saveChain: ISEIndex;
nAssigns, nVars: CARDINAL;
extendedScope: BOOL;
newBti: BTIndex;
t: Tree.Link;
IF tb[node].name = call THEN dataPtr.textIndex ← tb[node].info;
bodyNesting ← 0;
IF copying OR masterCtx = CTXNull THEN copyCtx ← CTXNull
ELSE {
saveChain ← ctxb[masterCtx].seList; ctxb[masterCtx].seList ← ISENull;
ctxb[masterCtx].level ← bb[currentEnclosing].level;
copyCtx ← masterCtx};
[typeIn, typeOut] ← TransferTypes[bb[currentMaster].ioType];
substSafe ← tb[node].attr3 AND bb[currentMaster].hints.nameSafe;
nAssigns ← SELECT TRUE FROM
(typeIn = RecordSENull) => 0,
tb[node].attr1 => ExtractArgs[typeIn, seb[typeIn].fieldCtx, node],
ENDCASE => MapArgs[seb[typeIn].fieldCtx, node];
tb[node].son[2] ← FreeTree[tb[node].son[2]];
IF RequiredFields[typeOut] THEN {
formalCtx ← seb[typeOut].fieldCtx;
IF copyCtx = CTXNull THEN copyCtx ← NewCtx[bb[currentEnclosing].level];
seChain ← MakeSeChain[copyCtx, CtxVars[formalCtx], TRUE];
AppendSeChain[copyCtx, seChain];
MapIds[formalCtx, seChain, 0]};
IF tb[masterBody].son[1] # Tree.Null THEN
PushTree[ExpandOpens[tb[masterBody].son[1]]];
IF masterCtx # CTXNull THEN
IF ~copying THEN AppendSeChain[copyCtx, saveChain]
ELSE IF (nVars ← CtxVars[masterCtx]) # 0 THEN {
IF copyCtx = CTXNull THEN copyCtx ← NewCtx[bb[currentEnclosing].level];
seChain ← MakeSeChain[copyCtx, nVars, FALSE];
MapIds[masterCtx, seChain, 0];
AppendSeChain[copyCtx, seChain]};
-- expand the body
IF copyCtx # CTXNull THEN newBti ← MakeEnclosingBody[BTNull, copyCtx];
t ← ExpandDecls[tb[masterBody].son[2]];
PushTree[ExpandTree[tb[masterBody].son[3]]];
IF copyCtx = CTXNull THEN extendedScope ← FALSE
ELSE {
extendedScope ← nAssigns # 0 OR tb[masterBody].son[1] # Tree.Null
OR tb[masterBody].son[4] # Tree.Null;
PushTree[t]; PushNode[block, -2];
SetInfo[newBti]; SetAttr[3, extendedScope];
SetAttr[1, tb[masterBody].attr1]; SetAttr[2, tb[masterBody].attr2];
WITH body: bb[newBti].info SELECT FROM
Internal => {body.bodyTree ← GetNode[t←PopTree[]]; PushTree[t]};
ENDCASE => ERROR};
IF tb[masterBody].son[1] # Tree.Null THEN {
PushNode[open, 2]; SetInfo[dataPtr.textIndex]};
IF tb[masterBody].son[4] # Tree.Null THEN {
PushTree[ExpandTree[tb[masterBody].son[4]]];
PushNode[lock, 2]; SetInfo[dataPtr.textIndex]};
IF masterCtx # CTXNull AND copying AND nVars # 0 THEN UnmapIds[explicit];
IF copyCtx # CTXNull THEN currentEnclosing ← ParentBti[currentEnclosing];
IF ~copying THEN PruneBody[masterBody];
-- complete the setup
IF tb[node].nSons > 2 THEN {
PushTree[tb[node].son[3]]; tb[node].son[3] ← Tree.Null;
PushNode[enable, -2]; SetInfo[dataPtr.textIndex]; SetAttr[3, TRUE]};
IF RequiredFields[typeOut] THEN UnmapIds[implicit];
IF typeIn # RecordSENull THEN UnmapIds[implicit];
tb[node].son[2] ← MakeList[nAssigns+1];
IF copyCtx # CTXNull AND nAssigns # 0 THEN UpdateBodyNesting[tb[node].son[2], newBti];
tb[node].name ← IF tb[node].name = callx THEN substx ELSE subst;
tb[node].attr1 ← tb[masterBody].attr1; tb[node].attr2 ← tb[masterBody].attr2;
tb[node].attr3 ← extendedScope;
ResetSharing[]};
RecursiveSubst: PROC [bti, parent: BTIndex] RETURNS [BOOL] = {
UNTIL parent = BTNull DO
IF bti = parent THEN RETURN [TRUE];
parent ← ParentBti[parent];
ENDLOOP;
RETURN [FALSE]};
PruneBody: PROC [node: Tree.Index] = {
OPEN tb[node];
son[1] ← son[2] ← son[3] ← son[4] ← Tree.Null; name ← procinit};
-- argument list testing/processing
NameSafe: PROC [t: Tree.Link] RETURNS [safe: BOOL] = {
RETURN [~bb[currentMaster].hints.argUpdated AND
(substSafe OR
(WITH t SELECT FROM
symbol => seb[index].immutable,
literal => TRUE,
ENDCASE =>
SELECT OpName[t] FROM
IN [relE..relLE], IN [plus..mod] =>
NameSafe[NthSon[t, 1]] AND NameSafe[NthSon[t, 2]],
not, uminus, abs, pred, succ => NameSafe[NthSon[t, 1]],
loophole, cast, check, lengthen, shorten, float => NameSafe[NthSon[t, 1]],
clit, llit, mwconst, nil, atom => TRUE,
cdot => NameSafe[NthSon[t, 2]],
ENDCASE => FALSE))]};
VarRefs: PROC [sei: ISEIndex] RETURNS [CARDINAL] = INLINE {
RETURN [seb[sei].idInfo]};
CheapEval: PROC [t: Tree.Link, top: BOOL←TRUE] RETURNS [BOOL] = {
RETURN [WITH t SELECT FROM
subtree =>
SELECT OpName[t] FROM
clit, llit, mwconst, nil, atom => TRUE,
loophole, cast, openx => CheapEval[NthSon[t, 1], top],
addr, uparrow, dot, dollar => CheapEval[NthSon[t, 1], top],
IN [index .. reloc] =>
CheapEval[NthSon[t, 1], FALSE] AND CheapEval[NthSon[t, 2], FALSE],
IN [or .. mod] =>
top AND CheapEval[NthSon[t, 1], FALSE]
AND CheapEval[NthSon[t, 2], FALSE],
not, uminus, abs, pred, succ, lengthen, shorten =>
top AND CheapEval[NthSon[t, 1], FALSE],
cdot => CheapEval[NthSon[t, 2], top],
ENDCASE => FALSE,
ENDCASE => TRUE]};
MapByName: PROC [sei: ISEIndex, t: Tree.Link] RETURNS [BOOL] = {
n: CARDINAL = VarRefs[sei];
RETURN [NameSafe[t] AND (n <= 2 OR CheapEval[t])]};
CountVars: PROC [ctx: CTXIndex, t: Tree.Link] RETURNS [n: CARDINAL ← 0] = {
sei: ISEIndex ← FirstCtxSe[ctx];
CountVar: Tree.Scan = {
IF sei # ISENull THEN {IF ~MapByName[sei, t] THEN n ← n+1; sei ← NextSe[sei]}};
ScanList[t, CountVar]; RETURN};
RequiredFields: PROC [rSei: RecordSEIndex] RETURNS [BOOL] = {
FOR sei: ISEIndex ← FirstCtxSe[FieldCtx[rSei]], NextSe[sei] UNTIL sei = ISENull DO
IF seb[sei].hash = nullName THEN RETURN [FALSE];
IF seb[sei].idInfo # 0 THEN RETURN [TRUE];
ENDLOOP;
RETURN [FALSE]};
-- tree manipulation
DiscardTree: Tree.Map = {
IF t # Tree.Null THEN
WITH t SELECT FROM
subtree => {
node: Tree.Index ← index;
SELECT tb[node].name FROM
call, callx =>
IF OpName[tb[node].son[1]] = thread THEN {
-- mark for later discard (see DiscardCall)
subNode: Tree.Index = GetNode[tb[node].son[1]];
tb[subNode].attr1 ← TRUE}
ELSE {
[] ← UpdateLeaves[t, DiscardTree]; FreeNode[node]};
ENDCASE =>
IF ~tb[node].shared THEN {
[] ← UpdateLeaves[t, DiscardTree]; FreeNode[node]}};
ENDCASE;
RETURN [Tree.Null]};
ExpandTree: Tree.Map = {
WITH t SELECT FROM
symbol => v ← ExpandSei[index];
subtree => {
sNode: Tree.Index = index;
IF tb[sNode].shared THEN
v ← SELECT tb[sNode].name FROM
call, callx => ExpandThreadedCall[sNode],
ENDCASE => ExpandShared[sNode]
ELSE
SELECT tb[sNode].name FROM
body => v ← ExpandBody[sNode];
block => v ← ExpandBlock[sNode, tb[sNode].attr3];
catch => v ← ExpandCatch[sNode];
ditem => v ← ExpandBlock[sNode, FALSE];
do => v ← ExpandDo[sNode];
open, bind, bindx => v ← ExpandBinding[sNode];
subst, substx => v ← ExpandSubst[sNode];
lock => v ← ExpandLock[sNode];
thread => v ← ExpandThread[sNode];
ENDCASE => {
v ← IF copying
THEN CopyTree[[baseP:@tb, link:t], ExpandTree]
ELSE UpdateLeaves[t, ExpandTree];
WITH v SELECT FROM
subtree => {
dNode: Tree.Index = index;
SELECT tb[dNode].name FROM
return => IF bodyNesting = 0 THEN UpdateReturn[dNode];
xerror => IF bodyNesting = 0 THEN tb[dNode].attr3 ← TRUE;
ENDCASE => NULL};
ENDCASE => NULL}};
ENDCASE => v ← t;
RETURN};
RewriteNode: PROC [node: Tree.Index, nSons: CARDINAL] RETURNS [Tree.Link] = {
FOR i: CARDINAL DECREASING IN [1 .. nSons] DO tb[node].son[i] ← PopTree[] ENDLOOP;
RETURN [[subtree[index: node]]]};
CopyNode: PROC [node: Tree.Index, nSons: CARDINAL] RETURNS [Tree.Link] = {
PushNode[tb[node].name, nSons]; SetInfo[tb[node].info];
SetAttr[1, tb[node].attr1]; SetAttr[2, tb[node].attr2]; SetAttr[3, tb[node].attr3];
RETURN [PopTree[]]};
ExpandBlock: PROC [node: Tree.Index, extendedScope: BOOL] RETURNS [v: Tree.Link] = {
EnterBlock[node, extendedScope];
PushTree[ExpandDecls[tb[node].son[1]]];
PushTree[ExpandTree[tb[node].son[2]]];
v ← IF copying THEN CopyNode[node, 2] ELSE RewriteNode[node, 2];
ExitBlock[GetNode[v]];
RETURN};
ExpandBody: PROC [node: Tree.Index] RETURNS [v: Tree.Link] = {
EnterBody[node];
PushTree[ExpandOpens[tb[node].son[1]]];
PushTree[ExpandDecls[tb[node].son[2]]];
PushTree[ExpandTree[tb[node].son[3]]];
PushTree[ExpandTree[tb[node].son[4]]];
v ← IF copying THEN CopyNode[node, 4] ELSE RewriteNode[node, 4];
ExitBody[GetNode[v]];
RETURN};
ExpandCatch: PROC [node: Tree.Index] RETURNS [v: Tree.Link] = {
EnterCatch[node];
PushTree[ExpandTree[tb[node].son[1]]];
PushTree[ExpandTree[tb[node].son[2]]];
v ← IF copying THEN CopyNode[node, 2] ELSE RewriteNode[node, 2];
ExitCatch[GetNode[v]];
RETURN};
ExpandDo: PROC [node: Tree.Index] RETURNS [v: Tree.Link] = {
decl: BOOL;
subNode: Tree.Index;
IF tb[node].son[1] = Tree.Null THEN decl ← FALSE
ELSE {subNode ← GetNode[tb[node].son[1]]; decl ← OpName[tb[subNode].son[1]] = decl};
IF decl THEN {
nSons: CARDINAL = tb[subNode].nSons;
EnterBlock[subNode, FALSE];
PushTree[ExpandDecls[tb[subNode].son[1]]];
FOR i: CARDINAL IN [2..nSons] DO PushTree[ExpandTree[tb[subNode].son[i]]] ENDLOOP;
IF copying THEN {PushNode[tb[subNode].name, nSons]; SetInfo[tb[subNode].info]}
ELSE PushTree[RewriteNode[subNode, nSons]]}
ELSE PushTree[ExpandTree[tb[node].son[1]]];
PushTree[ExpandTree[tb[node].son[2]]];
PushTree[ExpandOpens[tb[node].son[3]]];
FOR i: CARDINAL IN [4..6] DO PushTree[ExpandTree[tb[node].son[i]]] ENDLOOP;
v ← IF copying THEN CopyNode[node, 6] ELSE RewriteNode[node, 6];
IF decl THEN {
newNode: Tree.Index = GetNode[v];
ExitBlock[GetNode[tb[newNode].son[1]], newNode]};
RETURN};
ExpandBinding: PROC [node: Tree.Index] RETURNS [Tree.Link] = {
nSons: CARDINAL = tb[node].nSons;
PushTree[ExpandOpens[tb[node].son[1]]];
FOR i: CARDINAL IN [2..nSons] DO PushTree[ExpandTree[tb[node].son[i]]] ENDLOOP;
RETURN [IF copying THEN CopyNode[node, nSons] ELSE RewriteNode[node, nSons]]};
ExpandSubst: PROC [node: Tree.Index] RETURNS [Tree.Link] = {
extendedScope: BOOL = tb[node].attr3;
PushTree[ExpandTree[tb[node].son[1]]];
IF extendedScope THEN MapBlock[FindBlock[tb[node].son[2]]];
PushTree[ExpandTree[tb[node].son[2]]];
RETURN [IF copying THEN CopyNode[node, 2] ELSE RewriteNode[node, 2]]};
ExpandThreadedCall: PROC [node: Tree.Index] RETURNS [v: Tree.Link] = {
nSons: CARDINAL = tb[node].nSons;
FOR i: CARDINAL IN [1 .. nSons] DO PushTree[ExpandTree[tb[node].son[i]]] ENDLOOP;
v ← IF copying THEN CopyNode[node, nSons] ELSE RewriteNode[node, nSons];
ThreadSubst[node, v];
RETURN};
ExpandThread: PROC [node: Tree.Index] RETURNS [v: Tree.Link] = {
IF ~copying THEN {tb[node].son[1] ← ExpandTree[tb[node].son[1]]; v ← [subtree[node]]}
ELSE {
PushTree[ExpandTree[tb[node].son[1]]]; PushTree[Tree.Null];
PushNode[thread, 2]; SetInfo[tb[node].info]; v ← PopTree[]};
RETURN};
ExpandLock: PROC [node: Tree.Index] RETURNS [v: Tree.Link] = {
PushTree[ExpandTree[tb[node].son[2]]];
PushTree[ExpandTree[tb[node].son[1]]];
IF copying THEN {PushNode[lock, -2]; SetInfo[tb[node].info]; v ← PopTree[]}
ELSE {
tb[node].son[1] ← PopTree[]; tb[node].son[2] ← PopTree[];
v ← [subtree[index: node]]};
RETURN};
UpdateReturn: PROC [node: Tree.Index] = {
typeOut: RecordSEIndex;
IF tb[node].son[1] = Tree.Null AND
(typeOut←TransferTypes[bb[currentMaster].ioType].typeOut) # RecordSENull THEN {
n: CARDINAL ← 0;
FOR sei: ISEIndex ← FirstCtxSe[FieldCtx[typeOut]], NextSe[sei] UNTIL sei = ISENull DO
PushTree[ExpandSei[sei]]; n ← n+1 ENDLOOP;
tb[node].son[1] ← MakeList[n]};
tb[node].name ← result};
ExpandDecls: Tree.Map = {
n: CARDINAL;
ExpandDecl: Tree.Scan = {
node: Tree.Index;
LinkDecl: Tree.Scan = {
WITH t SELECT FROM
symbol => {
sei: ISEIndex = index;
seb[sei].idValue ← node;
IF ~seb[sei].mark4 AND tb[node].son[3] = Tree.Null AND ~seb[sei].immutable THEN
seb[sei].idInfo ← seb[sei].idInfo - 1};
ENDCASE};
copy: Tree.Link;
IF OpName[t] # typedecl THEN {
PushTree[copy ← ExpandTree[t]]; n ← n+1;
node ← GetNode[copy];
ScanList[tb[node].son[1], LinkDecl]}};
IF OpName[t] = initlist THEN {
node: Tree.Index = GetNode[t];
PushTree[ExpandTree[tb[node].son[1]]];
PushTree[ExpandDecls[tb[node].son[2]]];
IF copying THEN {PushNode[initlist, 2]; SetInfo[tb[node].info]; v ← PopTree[]}
ELSE v ← RewriteNode[node, 2]}
ELSE
IF copying THEN {n ← 0; ScanList[t, ExpandDecl]; v ← MakeList[n]}
ELSE v ← ExpandTree[t];
RETURN};
SharingItem: TYPE = RECORD [old, new: Tree.Link, next: SharingList];
SharingList: TYPE = LONG POINTER TO SharingItem;
sharingMap: SharingList;
MapShared: PROC [t, v: Tree.Link] = {
p: SharingList ← (dataPtr.zone).NEW[SharingItem];
p↑ ← [old:t, new:v, next:sharingMap]; sharingMap ← p;
MarkShared[v, TRUE]};
ExpandShared: PROC [node: Tree.Index] RETURNS [v: Tree.Link] = {
target: Tree.Link = [subtree[index: node]];
UpdateCount: Tree.Scan = {
WITH t SELECT FROM
symbol => IncrCount[index];
subtree => ScanSons[t, UpdateCount];
ENDCASE => NULL};
FOR p: SharingList ← sharingMap, p.next UNTIL p = NIL DO
IF p.old = target THEN GO TO Found;
REPEAT
Found => v ← p.new;
FINISHED => v ← target;
ENDLOOP;
IF copying THEN UpdateCount[v]; RETURN};
ResetSharing: PROC = {
p: SharingList;
UNTIL sharingMap = NIL DO
p ← sharingMap; sharingMap ← sharingMap.next; (dataPtr.zone).FREE[@p];
ENDLOOP};
ExpandOpens: Tree.Map = {
n: CARDINAL;
UpdateOpen: Tree.Scan = {
node: Tree.Index = GetNode[t];
base: Tree.Link;
tb[node].son[1] ← ExpandTree[tb[node].son[1]];
IF ~Shared[base ← tb[node].son[2]] THEN tb[node].son[2] ← ExpandTree[base]
ELSE {
MarkShared[base, FALSE]; base ← ExpandTree[base];
MarkShared[base, TRUE]; tb[node].son[2] ← base}};
ExpandOpen: Tree.Scan = {
node: Tree.Index = GetNode[t];
base: Tree.Link = tb[node].son[2];
copy: Tree.Link;
PushTree[ExpandTree[tb[node].son[1]]];
IF ~Shared[base] THEN PushTree[ExpandTree[base]]
ELSE {
MarkShared[base, FALSE]; PushTree[copy ← ExpandTree[base]];
MarkShared[base, TRUE]; MapShared[base, copy]};
PushNode[item, 2]; SetInfo[tb[node].info]; n ← n+1};
IF ~copying THEN {ScanList[t, UpdateOpen]; v ← t}
ELSE {n ← 0; ScanList[t, ExpandOpen]; v ← MakeList[n]};
RETURN};
-- blocks and bodies
FindBlock: PROC [t: Tree.Link] RETURNS [node: Tree.Index] = {
DO
node ← GetNode[t];
SELECT tb[node].name FROM
list => t ← ListTail[t];
block => EXIT;
open, enable => t ← tb[node].son[2];
lock => t ← tb[node].son[1];
ENDCASE => ERROR;
ENDLOOP;
RETURN};
EnterBlock: PROC [node: Tree.Index, extendedScope: BOOL] = INLINE {
IF ~extendedScope THEN MapBlock[node]};
MapBlock: PROC [node: Tree.Index] = {
oldBti: BTIndex = tb[node].info;
oldCtx: CTXIndex = bb[oldBti].localCtx;
seChain: ISEIndex;
newCtx: CTXIndex;
SELECT TRUE FROM
oldCtx = CTXNull => newCtx ← CTXNull;
~copying => {newCtx ← oldCtx; ctxb[newCtx].level ← bb[currentEnclosing].level};
ENDCASE => {
newCtx ← NewCtx[bb[currentEnclosing].level];
seChain ← MakeSeChain[newCtx, CtxVars[oldCtx], FALSE];
AppendSeChain[newCtx, seChain];
MapIds[oldCtx, seChain, 0]};
[] ← MakeEnclosingBody[IF copying THEN BTNull ELSE oldBti, newCtx];
RETURN};
ExitBlock: PROC [node: Tree.Index, bodyNode: Tree.Index ← Tree.NullIndex] = {
oldBti: BTIndex = tb[node].info;
newBti: BTIndex = currentEnclosing;
tb[node].info ← newBti;
WITH body: bb[newBti].info SELECT FROM
Internal => body.bodyTree ← IF bodyNode = Tree.NullIndex THEN node ELSE bodyNode;
ENDCASE;
IF copying AND bb[oldBti].localCtx # CTXNull THEN UnmapIds[explicit];
currentEnclosing ← ParentBti[currentEnclosing]};
MakeEnclosingBody: PROC [oldBti: BTIndex, ctx: CTXIndex] RETURNS [newBti: BTIndex] = {
newSon: BTIndex;
IF oldBti = BTNull THEN {
newBti ← (dataPtr.table).Words[bodyType, BodyRecord.Other.SIZE]; newSon ← BTNull}
ELSE {newSon ← bb[oldBti].firstSon; DelinkBti[oldBti]; newBti ← oldBti};
bb[newBti] ← BodyRecord[
link: ,
firstSon: newSon,
type: BodyType[ctx],
localCtx: ctx, level: bb[currentEnclosing].level,
sourceIndex: ,
info: BodyInfo[Internal[
bodyTree: Tree.NullIndex,
thread: Tree.NullIndex,
frameSize: ]],
extension: Other[relOffset: ]];
LinkBti[bti: newBti, parent: currentEnclosing];
currentEnclosing ← newBti;
RETURN};
EnterBody: PROC [node: Tree.Index] = {
oldBti: CBTIndex = tb[node].info;
newBti: CBTIndex;
ioType: CSEIndex;
type: RecordSEIndex;
level: ContextLevel = NextLevel[bb[currentEnclosing].level
! StaticNestError => {Log.Error[staticNesting]; RESUME}];
SetArgLevel: PROC [sei: CSEIndex] = {
ctx: CTXIndex = ArgCtx[sei];
IF ctx # CTXNull THEN ctxb[ctx].level ← level};
ctx: CTXIndex;
bodyNesting ← bodyNesting + 1;
IF ~copying THEN DelinkBti[oldBti];
IF ~copying AND (bb[oldBti].level > lL) = (level > lL) THEN {
ctx ← bb[oldBti].localCtx;
IF ctx # CTXNull THEN ctxb[ctx].level ← level;
ioType ← bb[oldBti].ioType; type ← bb[oldBti].type;
newBti ← oldBti}
ELSE {
id: ISEIndex;
IF level > lL THEN {
newBti ← (dataPtr.table).Words[bodyType, BodyRecord.Callable.Inner.SIZE];
bb[newBti] ← [,,,,,,, Callable[,,,,,,,,,, Inner[frameOffset: ]]]}
ELSE {
newBti ← (dataPtr.table).Words[bodyType, BodyRecord.Callable.Outer.SIZE];
bb[newBti] ← [,,,,,,, Callable[,,,,,,,,,, Outer[]]]};
IF ~copying THEN {
ctx ← bb[oldBti].localCtx;
IF ctx # CTXNull THEN ctxb[ctx].level ← level;
id ← bb[oldBti].id; ioType ← bb[oldBti].ioType; type ← bb[oldBti].type;
bb[newBti].firstSon ← bb[oldBti].firstSon}
ELSE {
oldCtx: CTXIndex;
IF (id ← bb[oldBti].id) # ISENull THEN
id ← SearchContext[seb[id].hash, bb[currentEnclosing].localCtx];
ioType ← CopyXferType[bb[oldBti].ioType, NIL];
MapFormals[oldType: bb[oldBti].ioType, newType: ioType];
IF (oldCtx ← bb[oldBti].localCtx) = CTXNull THEN ctx ← CTXNull
ELSE {
ctx ← NewCtx[level];
ctxb[ctx].seList ← MakeSeChain[ctx, CtxVars[oldCtx], FALSE];
MapIds[oldCtx, ctxb[ctx].seList, 0]};
type ← BodyType[ctx];
bb[newBti].firstSon ← BTNull;
dataPtr.nBodies ← dataPtr.nBodies+1;
IF level > lL THEN dataPtr.nInnerBodies ← dataPtr.nInnerBodies+1};
bb[newBti].type ← type;
bb[newBti].localCtx ← ctx;
bb[newBti].info ← bb[oldBti].info;
bb[newBti].inline ← bb[oldBti].inline;
bb[newBti].resident ← bb[oldBti].resident;
bb[newBti].id ← id;
bb[newBti].ioType ← ioType;
bb[newBti].monitored ← bb[oldBti].monitored;
bb[newBti].entry ← bb[oldBti].entry; bb[newBti].internal ← bb[oldBti].internal;
bb[newBti].noXfers ← bb[oldBti].noXfers;
bb[newBti].hints ← bb[oldBti].hints};
bb[newBti].level ← level;
WITH t: seb[ioType] SELECT FROM
transfer => {SetArgLevel[t.typeIn]; SetArgLevel[t.typeOut]};
ENDCASE;
LinkBti[bti: newBti, parent: currentEnclosing];
currentEnclosing ← newBti};
ExitBody: PROC [node: Tree.Index] = {
newBti: CBTIndex = LOOPHOLE[currentEnclosing];
ExitBlock[node];
IF copying THEN UnmapFormals[bb[newBti].ioType];
bodyNesting ← bodyNesting - 1};
EnterCatch: PROC [node: Tree.Index] = {
oldBti: CBTIndex = tb[node].info;
newBti: CBTIndex;
level: ContextLevel = NextLevel[bb[currentEnclosing].level
! StaticNestError => {Log.Error[staticNesting]; RESUME}];
bodyNesting ← bodyNesting + 1;
IF ~copying THEN {
DelinkBti[oldBti]; newBti ← oldBti; bb[newBti].level ← level}
ELSE {
newBti ← (dataPtr.table).Words[bodyType, BodyRecord.Callable.Catch.SIZE];
bb[newBti] ← [
link: ,
firstSon: BTNull,
type: RecordSENull,
localCtx: CTXNull,
level: level,
sourceIndex: bb[oldBti].sourceIndex,
info: bb[oldBti].info,
extension: Callable[
inline: FALSE,
id: ISENull,
ioType: CSENull,
monitored: FALSE,
noXfers: bb[oldBti].noXfers,
resident: bb[oldBti].resident,
entry: FALSE, internal: FALSE,
entryIndex: 0,
hints: bb[oldBti].hints,
closure: Catch[index: ]]]};
FOR bti: BTIndex ← currentEnclosing, ParentBti[bti] UNTIL bti = BTNull DO
WITH b: bb[bti] SELECT FROM
Callable => {bb[newBti].id ← b.id; EXIT};
ENDCASE;
ENDLOOP;
LinkBti[bti: newBti, parent: currentEnclosing];
currentEnclosing ← newBti};
ExitCatch: PROC [node: Tree.Index] = {
newBti: CBTIndex = LOOPHOLE[currentEnclosing];
ExitBlock[node];
bodyNesting ← bodyNesting - 1};
UpdateBodyNesting: PROC [list: Tree.Link, newBti: BTIndex] = {
oldBti: BTIndex = ParentBti[newBti];
UpdateLinks: Tree.Map = {
WITH t SELECT FROM
subtree => {
node: Tree.Index = index;
SELECT tb[node].name FROM
block => {
bti: BTIndex = tb[node].info;
IF ParentBti[bti] = oldBti THEN {DelinkBti[bti]; LinkBti[bti, newBti]};
v ← t};
thread => {
IF tb[node].info = oldBti THEN tb[node].info ← newBti;
tb[node].son[1] ← UpdateLeaves[tb[node].son[1], UpdateLinks];
v ← t};
ENDCASE => v ← UpdateLeaves[t, UpdateLinks]};
ENDCASE => v ← t};
UpdateItem: Tree.Scan = {
WITH t SELECT FROM
subtree => {
node: Tree.Index = index;
SELECT tb[node].name FROM
assign, extract =>
tb[node].son[2] ← UpdateLeaves[tb[node].son[2], UpdateLinks];
ENDCASE};
ENDCASE};
ScanList[list, UpdateItem]};
BodyType: PROC [ctx: CTXIndex] RETURNS [rSei: RecordSEIndex] = {
rSei ← LOOPHOLE[MakeNonCtxSe[SERecord.cons.record.notLinked.SIZE]];
seb[rSei].typeInfo ← record[
machineDep: FALSE, painted: TRUE, argument: FALSE,
hints: [
unifield: FALSE, variant: FALSE,
assignable: FALSE, comparable: FALSE, privateFields: TRUE,
refField: FALSE, default: FALSE, voidable: FALSE],
length: 0,
fieldCtx: CTXNull,
monitored: FALSE,
linkPart: notLinked[]];
seb[rSei].fieldCtx ← ctx; seb[rSei].mark3 ← TRUE;
RETURN};
-- id translation
AppendSeChain: PROC [ctx: CTXIndex, chain: ISEIndex] = {
last, next: ISEIndex;
SELECT TRUE FROM
chain = ISENull => NULL;
(last ← ctxb[ctx].seList) = ISENull => ctxb[ctx].seList ← chain;
ENDCASE => {
UNTIL (next ← NextSe[last]) = ISENull DO last ← next ENDLOOP;
SetSeLink[last, chain]}};
CtxVars: PROC [ctx: CTXIndex] RETURNS [n: CARDINAL ← 0] = {
FOR sei: ISEIndex ← FirstCtxSe[ctx], NextSe[sei] UNTIL sei = ISENull DO
IF seb[sei].idType # typeTYPE THEN n ← n+1 ENDLOOP;
RETURN};
AllocateAList: PROC [ctx: CTXIndex] RETURNS [aLink: AList] = {
maxItems: CARDINAL = CtxEntries[ctx];
aLink ← (dataPtr.zone).NEW[ANode[maxItems] ← [next:NIL, ctx:ctx, nItems:0, map:]]};
-- mapping
AllocateCopyEntries: PROC [nVars: CARDINAL] RETURNS [seChain: ISEIndex] = {
IF nVars = 0 THEN seChain ← ISENull
ELSE {
IF copyCtx = CTXNull THEN copyCtx ← NewCtx[bb[currentEnclosing].level];
seChain ← MakeSeChain[copyCtx, nVars, TRUE];
AppendSeChain[copyCtx, seChain]};
RETURN};
FillArgSe: PROC [copy, master: ISEIndex] = {
CopyArgSe[copy, master];
IF seb[copy].mark4 THEN seb[copy].idValue ← Tree.NullIndex;
seb[copy].mark4 ← FALSE; seb[copy].idInfo ← 0};
ExtractArgs: PROC [argType: RecordSEIndex, formalCtx: CTXIndex, node: Tree.Index]
RETURNS [nAssigns: CARDINAL] = {
aLink: AList = AllocateAList[formalCtx];
nVars: CARDINAL = CtxEntries[formalCtx];
seChain: ISEIndex = AllocateCopyEntries[nVars];
sei1: ISEIndex;
sei2: ISEIndex ← seChain;
FOR sei1 ← FirstCtxSe[formalCtx], NextSe[sei1] UNTIL sei1 = ISENull DO
val: Tree.Link = [symbol[index: sei2]];
FillArgSe[copy: sei2, master: sei1];
PushTree[val]; PushTree[Tree.Null];
PushNode[assign, 2]; SetInfo[dataPtr.textIndex];
IncrCount[sei2];
aLink.map[aLink.nItems] ← [id: sei1, name: FALSE, val: val];
aLink.nItems ← aLink.nItems + 1;
sei2 ← NextSe[sei2];
ENDLOOP;
IF nVars = 0 THEN nAssigns ← 0
ELSE {
PushList[nVars]; PushNode[exlist, 1]; SetInfo[argType];
PushTree[tb[node].son[2]]; tb[node].son[2] ← Tree.Null;
PushNode[extract, 2]; SetInfo[dataPtr.textIndex];
nAssigns ← 1};
PushAList[aLink];
RETURN};
MapArgs: PROC [formalCtx: CTXIndex, node: Tree.Index]
RETURNS [nAssigns: CARDINAL ← 0] = {
aLink: AList = AllocateAList[formalCtx];
nVars: CARDINAL = CountVars[formalCtx, tb[node].son[2]];
seChain: ISEIndex = AllocateCopyEntries[nVars];
sei1, sei2: ISEIndex;
MapArg: Tree.Map = {
name: BOOL;
val: Tree.Link;
IF sei1 = ISENull THEN v ← t
ELSE {
IF MapByName[sei1, t] THEN {
name ← TRUE; AdjustForName[t]; val ← t}
ELSE {
FillArgSe[copy: sei2, master: sei1];
name ← FALSE; val ← [symbol[index: sei2]];
IF t # Tree.Null THEN {
PushTree[val]; PushTree[t];
PushNode[assign, 2]; SetInfo[dataPtr.textIndex];
IncrCount[sei2]; nAssigns ← nAssigns + 1};
sei2 ← NextSe[sei2]};
aLink.map[aLink.nItems] ← [id: sei1, name: name, val: val];
aLink.nItems ← aLink.nItems + 1;
sei1 ← NextSe[sei1]; v ← Tree.Null};
RETURN};
sei1 ← FirstCtxSe[formalCtx]; sei2 ← seChain;
tb[node].son[2] ← UpdateList[tb[node].son[2], MapArg];
PushAList[aLink];
RETURN};
MapIds: PROC [ctx: CTXIndex, chain: ISEIndex, nRefs: [0..1]] = {
aLink: AList = AllocateAList[ctx];
sei1: ISEIndex ← FirstCtxSe[ctx];
sei2: ISEIndex ← chain;
UNTIL sei1 = ISENull DO
IF seb[sei1].idType # typeTYPE THEN {
CopyArgSe[sei2, sei1];
IF seb[sei2].mark4 THEN seb[sei2].idValue ← Tree.NullIndex;
seb[sei2].idInfo ← nRefs;
aLink.map[aLink.nItems] ← [id: sei1, name: FALSE, val: [symbol[index:sei2]]];
aLink.nItems ← aLink.nItems + 1;
sei2 ← NextSe[sei2]};
sei1 ← NextSe[sei1];
ENDLOOP;
PushAList[aLink]};
UnmapIds: PROC [decl: {implicit, explicit}] = {
aLink: AList ← PopAList[];
FOR i: CARDINAL IN [0..aLink.nItems) DO
WITH aLink.map[i].val SELECT FROM
symbol =>
IF decl = implicit AND ~aLink.map[i].name THEN seb[index].mark4 ← TRUE;
ENDCASE;
aLink.map[i].val ← DiscardTree[aLink.map[i].val];
ENDLOOP;
(dataPtr.zone).FREE[@aLink]};
MapFields: PROC [oldRecord, newRecord: CSEIndex, nRefs: [0..1]] = {
oldCtx: CTXIndex = ArgCtx[oldRecord];
IF oldCtx # CTXNull THEN {
aLink: AList = AllocateAList[oldCtx];
sei1: ISEIndex ← FirstCtxSe[oldCtx];
sei2: ISEIndex ← FirstCtxSe[ArgCtx[newRecord]];
UNTIL sei1 = ISENull DO
seb[sei2].idInfo ← nRefs;
aLink.map[aLink.nItems] ← [id: sei1, name: FALSE, val: [symbol[index:sei2]]];
aLink.nItems ← aLink.nItems + 1;
sei1 ← NextSe[sei1]; sei2 ← NextSe[sei2];
ENDLOOP;
PushAList[aLink]}};
MapFormals: PROC [oldType, newType: CSEIndex] = {
WITH new: seb[newType] SELECT FROM
transfer =>
WITH old: seb[oldType] SELECT FROM
transfer => {
MapFields[old.typeIn, new.typeIn, 1];
MapFields[old.typeOut, new.typeOut, 0]};
ENDCASE => ERROR;
ENDCASE};
UnmapFormals: PROC [type: CSEIndex] = {
WITH t: seb[type] SELECT FROM
transfer => {
IF ArgCtx[t.typeOut] # CTXNull THEN UnmapIds[implicit];
IF ArgCtx[t.typeIn] # CTXNull THEN UnmapIds[implicit]};
ENDCASE};
-- reference count adjustment
CountedSei: PROC [sei: ISEIndex] RETURNS [BOOL] = {
ctx: CTXIndex = seb[sei].idCtx;
RETURN [~seb[sei].constant
AND ctxb[ctx].level # lZ AND ctxb[ctx].ctxType # included]};
IncrCount: PROC [sei: ISEIndex] = { -- modified BumpCount (Pass3I)
IF seb[sei].idType # typeTYPE AND (~seb[sei].mark4 OR CountedSei[sei]) THEN
seb[sei].idInfo ← seb[sei].idInfo + 1};
DecrCount: PROC [sei: ISEIndex] = {
IF seb[sei].idType # typeTYPE AND (~seb[sei].mark4 OR CountedSei[sei]) THEN
IF seb[sei].idInfo # 0 THEN seb[sei].idInfo ← seb[sei].idInfo - 1};
AdjustForName: Tree.Scan = {
WITH t SELECT FROM
symbol => DecrCount[index];
subtree => {
node: Tree.Index = index;
SELECT tb[node].name FROM
thread => AdjustForName[tb[node].son[1]];
ENDCASE => ScanSons[t, AdjustForName]};
ENDCASE};
SetCtxCounts: PROC [ctx: CTXIndex, nRefs: [0..1]] = {
FOR sei: ISEIndex ← FirstCtxSe[ctx], NextSe[sei] UNTIL sei = ISENull DO
IF ~seb[sei].constant THEN seb[sei].idInfo ← nRefs;
ENDLOOP};
BumpCtxCounts: PROC [ctx: CTXIndex, incr: CARDINAL] = {
FOR sei: ISEIndex ← FirstCtxSe[ctx], NextSe[sei] UNTIL sei = ISENull DO
IF ~seb[sei].constant THEN seb[sei].idInfo ← seb[sei].idInfo + incr;
ENDLOOP};
ComputeArgCounts: PROC [type: CSEIndex, body: Tree.Link] = {
typeIn, typeOut: RecordSEIndex;
argCtx, resultCtx: CTXIndex;
[typeIn, typeOut] ← TransferTypes[type];
argCtx ← FieldCtx[typeIn]; resultCtx ← FieldCtx[typeOut];
IF argCtx # CTXNull OR resultCtx # CTXNull THEN {
UpdateCount: Tree.Scan = {
WITH t SELECT FROM
symbol => {
sei: ISEIndex = index;
SELECT seb[sei].idCtx FROM
CTXNull => NULL;
argCtx, resultCtx => seb[sei].idInfo ← seb[sei].idInfo + 1;
ENDCASE};
subtree => {
node: Tree.Index = index;
IF tb[node].name = return AND tb[node].son[1] = Tree.Null THEN
BumpCtxCounts[resultCtx, 1];
ScanSons[t, UpdateCount]};
ENDCASE => NULL};
SetCtxCounts[argCtx, 1]; SetCtxCounts[resultCtx, 0];
ScanSons[body, UpdateCount]}};
FieldCtx: PROC [rSei: RecordSEIndex] RETURNS [CTXIndex] = {
RETURN [IF rSei = RecordSENull THEN CTXNull ELSE seb[rSei].fieldCtx]};
-- association lists
PushAList: PROC [aLink: AList] = {aLink.next ← aStack; aStack ← aLink};
PopAList: PROC RETURNS [aLink: AList] = {
IF aStack = NIL THEN ERROR; aLink ← aStack; aStack ← aLink.next};
ExpandSei: PROC [sei: ISEIndex] RETURNS [v: Tree.Link] = {
i: CARDINAL;
FOR aLink: AList ← aStack, aLink.next UNTIL aLink = NIL DO
IF seb[sei].idCtx = aLink.ctx THEN
FOR i IN [0 .. aLink.nItems) DO IF aLink.map[i].id = sei THEN GO TO Found ENDLOOP;
REPEAT
Found => {
saveCopying: BOOL = copying;
copying ← TRUE; v ← ExpandTree[aLink.map[i].val];
copying ← saveCopying};
FINISHED => {IF copying THEN IncrCount[sei]; v ← [symbol[index:sei]]};
ENDLOOP;
RETURN};
-- nested calls
ThreadSubst: PROC [node: Tree.Index, dest: Tree.Link] = {
dThread: Tree.Index = GetNode[NthSon[dest, 1]];
IF copying THEN {
sThread: Tree.Index;
DO
sThread ← GetNode[tb[node].son[1]];
IF tb[sThread].name # thread THEN ERROR;
IF tb[sThread].son[2] = Tree.Null THEN EXIT;
node ← GetNode[tb[sThread].son[2]];
ENDLOOP;
tb[dThread].son[2] ← Tree.Null;
tb[sThread].son[2] ← dest; MarkShared[dest, TRUE]};
tb[dThread].info ← currentEnclosing};
}.