MimBodyCorrectImpl.mesa
Copyright Ó 1989, 1990, 1991, 1992 by Xerox Corporation. All rights reserved.
Russ Atkinson (RRA) August 3, 1990 10:38:13 am PDT
This module takes a list of procedures and creates BodyRecord objects in the symbol table for all procedures that do not have valid BodyRecord objects.
DIRECTORY
Alloc,
IntCodeDefs,
IntCodeUtils,
IO,
MimBodyCorrect,
MimData,
MimZonePort,
Rope,
Symbols,
Table;
MimBodyCorrectImpl: CEDAR PROGRAM
IMPORTS Alloc, IntCodeUtils, IO, MimData, MimZonePort, Rope
EXPORTS MimBodyCorrect
= BEGIN OPEN IntCodeDefs, Symbols;
ROPE: TYPE = Rope.ROPE;
BadBti: CARD = 100000;
Notify: Alloc.Notifier = {
called by allocator whenever tables are repacked
bb ¬ base[Symbols.bodyType];
seb ¬ base[Symbols.seType];
};
bb: Symbols.Base;
seb: Symbols.Base;
bbZoneScratch: MimZonePort.Scratch;
bbZone: UNCOUNTED ZONE = NewUZone[];
NewUZone: PROC RETURNS [UNCOUNTED ZONE] = TRUSTED {
RETURN [MimZonePort.MakeZone[alloc: BbZoneProc, free: NIL, scratch: @bbZoneScratch]];
};
BbZoneProc: UNSAFE PROC
[self: UNCOUNTED ZONE, size: CARDINAL] RETURNS [ptr: LONG POINTER] = UNCHECKED {
index: Alloc.OrderedIndex = (MimData.table).Units[Symbols.bodyType, size];
ptr ¬ @bb[index];
};
CBTRelative: UNSAFE PROC
[ptr: LONG POINTER TO BodyRecord.Callable] RETURNS [CBTIndex]
= UNCHECKED INLINE {
RETURN [LOOPHOLE[ptr-LOOPHOLE[bb, LONG POINTER TO BodyRecord.Callable]]];
};
CantHappen: SIGNAL = CODE;
AllocateBody: PROC [lambda: LambdaNode] RETURNS [CBTIndex] = TRUSTED {
Allocates a new BodyRecord object with reasonable defaults for all of the fields. No linking to parents or children is performed.
bPtr: LONG POINTER TO BodyRecord.Callable ¬ bbZone.NEW[BodyRecord.Callable ¬ [
link: [which: sibling, index: Symbols.BTNull],
firstSon: Symbols.BTNull,
type: Symbols.RecordSENull,
localCtx: Symbols.CTXNull,
sourceIndex: 0,
info: Symbols.BodyInfo[cases: External[0, 0, 0, 0]],
level: Symbols.lZ,
class: Blank,
extension: Callable[
id: Symbols.ISENull,
ioType: Symbols.typeANY,
frameOffset: 0,
entryIndex: 0,
hints: [safe: FALSE, argUpdated: TRUE, nameSafe: FALSE, noStrings: TRUE, pad: 0],
entry: FALSE, internal: FALSE, inline: FALSE,
monitored: FALSE, noXfers: FALSE, resident: FALSE,
kind: Other]
]];
bti: CBTIndex = CBTRelative[bPtr];
RETURN [bti];
};
FindVarBti: PROC [bti: BTIndex, ctx: CTXIndex] RETURNS [BTIndex] = TRUSTED {
Recursive search for the BTIndex that contains the given ctx starting with the given bti
IF bti = Symbols.BTNull OR bb[bti].localCtx = ctx THEN RETURN [bti];
WHILE bti # Symbols.BTNull AND bb[bti].link.which # parent DO
son: BTIndex = FindVarBti[bb[bti].firstSon, ctx];
IF son # Symbols.BTNull THEN RETURN [son];
bti ¬ bb[bti].link.index;
ENDLOOP;
RETURN [Symbols.BTNull];
};
ParentBti: PROC [bti: BTIndex] RETURNS [BTIndex] = TRUSTED {
IF bti = Symbols.BTNull OR bti = Symbols.RootBti THEN ERROR;
WHILE bti # Symbols.BTNull DO
link: BTIndex = bb[bti].link.index;
IF bb[bti].link.which = parent THEN RETURN [link];
bti ¬ link;
ENDLOOP;
ERROR;
};
LastSon: PROC [bti: BTIndex] RETURNS [BTIndex] = TRUSTED {
lastSon: BTIndex ¬ bb[bti].firstSon;
WHILE lastSon # Symbols.BTNull AND bb[lastSon].link.which # parent DO
lastSon ¬ bb[lastSon].link.index;
ENDLOOP;
RETURN [lastSon];
};
DelinkBti: PROC [bti: BTIndex] = TRUSTED {
parent: BTIndex = ParentBti[bti];
prev: BTIndex ¬ bb[parent].firstSon;
firstSon: BTIndex ¬ bb[bti].firstSon;
lastSon: BTIndex ¬ LastSon[bti];
IF prev = bti
THEN {
The bti is the first in the chain
link: BTIndex = bb[bti].link.index;
bb[parent].firstSon ¬ IF link = parent THEN BTNull ELSE link;
IF firstSon # Symbols.BTNull THEN {
At this point we have to take all of the sons and put them where the original node was (more or less).
bb[parent].firstSon ¬ firstSon;
bb[lastSon].link.which ¬ IF link = parent THEN parent ELSE sibling;
bb[lastSon].link.index ¬ link;
};
}
ELSE {
The bti is somewhere in the chain
DO
next: BTIndex ¬ bb[prev].link.index;
IF next = parent OR next = Symbols.BTNull THEN ERROR;
IF next = bti THEN {bb[prev].link ¬ bb[bti].link; EXIT};
prev ¬ next;
ENDLOOP;
IF firstSon # Symbols.BTNull THEN {
At this point we have to take all of the sons and put them where the original node was (more or less).
bb[lastSon].link ¬ bb[prev].link;
bb[prev].link.which ¬ sibling;
bb[prev].link.index ¬ firstSon;
};
};
bb[bti].link.index ¬ Symbols.BTNull;
bb[bti].firstSon ¬ Symbols.BTNull;
};
MakeFirstSon: PROC [bti: BTIndex, parent: BTIndex] = TRUSTED {
son: BTIndex = bb[parent].firstSon;
IF bti = BTNull OR parent = BTNull THEN ERROR CantHappen;
IF son = BTNull
THEN bb[bti].link ¬ [which: parent, index: parent]
No sons, so this procedure is the only child
ELSE bb[bti].link ¬ [which: sibling, index: son];
Insert this body just after the last seen variable
bb[parent].firstSon ¬ bti;
};
RelinkBodies: PROC [bodies: NodeList] = {
zeroPass: PROC [procBti: BTIndex, startBti: BTIndex] = TRUSTED {
Recursively visit the linked bodies, initializing the relOffset fields.
sonBti: BTIndex ¬ bb[startBti].firstSon;
IF sonBti = BTNull THEN RETURN;
DO
link: BTIndex ¬ bb[sonBti].link.index;
WITH body: bb[sonBti] SELECT FROM
Callable => zeroPass[sonBti, sonBti];
Other => {
otherBodies ¬ otherBodies + 1;
body.relOffset ¬ -1;
zeroPass[procBti, sonBti];
};
ENDCASE => ERROR;
IF link = startBti THEN EXIT;
IF link = BTNull THEN ERROR;
IF bb[sonBti].link.which = parent THEN ERROR;
sonBti ¬ link;
ENDLOOP;
};
firstPass: PROC = {
FOR each: NodeList ¬ bodies, each.rest WHILE each # NIL DO
WITH each.first SELECT FROM
parent: LabelNode => {
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
WITH node SELECT FROM
decl: DeclNode => {
var: Var = decl.var;
IF var # NIL AND var.flags[named] THEN {
We may have changed the scope of the body for this var
ctx: CTXIndex = CtxForVar[var];
IF ctx # CTXNull THEN {
bti: BTIndex = BtiForCtx[Symbols.RootBti, ctx];
IF bti # BTNull THEN TRUSTED {
WITH body: bb[bti] SELECT FROM
Other => body.relOffset ¬ LOOPHOLE[parentBti];
Callable => {};
ENDCASE => ERROR;
};
};
};
};
ENDCASE;
IntCodeUtils.MapNode[node, inner];
RETURN [node];
};
parentBti: BTIndex = LOOPHOLE[parent.label.id];
IntCodeUtils.MapNode[parent, inner];
};
ENDCASE;
ENDLOOP;
};
secondPass: PROC [procBti: BTIndex, startBti: BTIndex] = TRUSTED {
Recursively visit the linked bodies, moving those that are incorrectly linked.
sonBti: BTIndex ¬ bb[startBti].firstSon;
IF sonBti = BTNull THEN RETURN;
DO
link: BTIndex ¬ bb[sonBti].link.index;
WITH body: bb[sonBti] SELECT FROM
Callable => secondPass[sonBti, sonBti];
Other => {
IF body.relOffset >= 0 THEN {
desiredParent: BTIndex = LOOPHOLE[body.relOffset, BTIndex];
WITH cbody: bb[startBti] SELECT FROM
Callable => IF desiredParent = startBti THEN GO TO linkOK;
Other => {
cdp: BTIndex = LOOPHOLE[cbody.relOffset, BTIndex];
IF cdp = desiredParent THEN GO TO linkOK;
};
ENDCASE => ERROR;
DelinkBti[sonBti];
MakeFirstSon[sonBti, desiredParent];
secondPass[desiredParent, sonBti];
GO TO linkChanged;
EXITS linkOK => {};
};
secondPass[procBti, sonBti];
EXITS linkChanged => {
A link was changed so we scan all of the sons again
link ¬ bb[startBti].firstSon;
IF link = BTNull THEN EXIT;
};
};
ENDCASE => ERROR;
IF link = startBti THEN EXIT;
IF link = BTNull THEN ERROR;
sonBti ¬ link;
ENDLOOP;
};
otherBodies: INT ¬ 0;
zeroPass[Symbols.RootBti, Symbols.RootBti];
IF debug # NIL THEN {
IO.PutRope[debug, "\n**** After RelinkBodies Pass 0 ****\n"];
PrintBodies[debug, Symbols.RootBti, 0];
};
IF otherBodies # 0 THEN {
firstPass[];
IF debug # NIL THEN {
IO.PutRope[debug, "\n**** After RelinkBodies Pass 1 ****\n"];
PrintBodies[debug, Symbols.RootBti, 0];
};
secondPass[Symbols.RootBti, Symbols.RootBti];
IF debug # NIL THEN {
IO.PutRope[debug, "\n**** After RelinkBodies Pass 2 ****\n"];
PrintBodies[debug, Symbols.RootBti, 0];
};
};
};
debug: IO.STREAM ¬ NIL;
BadBody: ERROR = CODE;
PrintBodies: PROC [st: IO.STREAM, bti: BTIndex, depth: NAT] = TRUSTED {
start: BTIndex = bti;
IF depth > 100 THEN {
IO.PutRope[st, "ERROR! Too Deep!\n"];
ERROR BadBody;
};
THROUGH [0..depth) DO IO.PutRope[st, " "]; ENDLOOP;
IF bti = BTNull THEN {IO.PutRope[st, "{null bti}\n"]; RETURN};
IO.PutF1[st, "bti: %g, ", [integer[LOOPHOLE[bti]]]];
SELECT bb[bti].class FROM
Blank => {};
Outer => IO.PutRope[st, "outer "];
Inner => IO.PutRope[st, "inner "];
Install => IO.PutRope[st, "install "];
Init => IO.PutRope[st, "init "];
Catch => IO.PutRope[st, "catch "];
Scope => IO.PutRope[st, "scope "];
Fork => IO.PutRope[st, "fork "];
ENDCASE => IO.PutRope[st, "?? "];
WITH body: bb[bti] SELECT FROM
Callable => IO.PutF[st, "Callable (ctx: %g, src: %g)\n",
[integer[LOOPHOLE[bb[bti].localCtx]]],
[cardinal[bb[bti].sourceIndex]] ];
Other => IO.PutF[st, "Other (ctx: %g, src: %g, ip: %g)\n",
[integer[LOOPHOLE[bb[bti].localCtx]]],
[cardinal[bb[bti].sourceIndex]],
[integer[body.relOffset]] ];
ENDCASE => ERROR;
IF bb[bti].firstSon # BTNull THEN {
son: BTIndex ¬ bb[bti].firstSon;
count: NAT ¬ 0;
DO
link: BTIndex ¬ bb[son].link.index;
PrintBodies[st, son, depth+1];
IF link = bti THEN EXIT;
IF bb[son].link.which = parent THEN {
IO.PutF1[st, "ERROR! Bad Parent Link = %g!!!!\n", [integer[LOOPHOLE[link]]]];
ERROR BadBody;
};
IF link = BTNull THEN {
IO.PutRope[st, "ERROR! Link = BTNull!!!!\n"];
ERROR BadBody;
};
count ¬ count + 1;
IF count > 100 THEN {
IO.PutRope[st, "ERROR! Too Wide!\n"];
ERROR BadBody;
};
son ¬ link;
ENDLOOP;
};
};
BtiForCtx: PROC [startBti: BTIndex, ctx: CTXIndex] RETURNS [BTIndex] = TRUSTED {
Starting at the given bti, return the bti corresponding to the given ctx. Use recursive search to find such a bti in sons.
IF startBti # BTNull THEN {
IF bb[startBti].localCtx = ctx AND ctx # CTXNull THEN RETURN [startBti];
FOR son: BTIndex ¬ bb[startBti].firstSon, bb[son].link.index
WHILE son # BTNull AND son # startBti DO
sbti: BTIndex = BtiForCtx[son, ctx];
IF sbti # BTNull THEN RETURN [sbti];
ENDLOOP;
};
RETURN [BTNull];
};
CtxForVar: PROC [var: Var] RETURNS [CTXIndex] = {
varId: INT = var.id;
IF var.flags[named] AND varId > 0 THEN {
tag: CARD = LOOPHOLE[Table.IndexRep[tag: Symbols.seTag, highBits: 0, lowBits: 0]];
IF CARD[varId] < tag THEN TRUSTED {
sei: Symbols.SEIndex = LOOPHOLE[tag+varId];
WITH se: seb[sei] SELECT FROM
id => RETURN [se.idCtx];
ENDCASE => ERROR;
};
};
RETURN [Symbols.CTXNull];
};
FixBodies: PUBLIC PROC [bodies: NodeList] = {
TRUSTED {(MimData.table).AddNotify[Notify]};
First, establish the renaming of labels (pass 1: count, pass 2: rename)
FOR each: NodeList ¬ bodies, each.rest WHILE each # NIL DO
WITH each.first SELECT FROM
labelNode: REF NodeRep.label =>
WITH labelNode.label.node SELECT FROM
lambda: REF NodeRep.lambda => TRUSTED {
id: CARD = LOOPHOLE[labelNode.label.id];
bti: CBTIndex ¬ LOOPHOLE[id];
class: Symbols.ProcClass = SELECT lambda.kind FROM
outer => Outer, inner => Inner, install => Install, init => Init,
catch => Catch, scope => Scope, fork => Fork, ENDCASE => Blank;
IF id >= BadBti THEN {
This lambda needs a new BodyRecord in the symbol table
bti ¬ AllocateBody[lambda];
labelNode.label.id ¬ LOOPHOLE[bti];
};
IF class = Install THEN {
The installation proc is always the sibling of the init procedure, which is the root bti. Neither one has a parent.
bb[Symbols.RootBti].link ¬ [which: sibling, index: bti];
bb[bti].link ¬ [which: parent, index: BTNull];
};
bb[bti].class ¬ class;
};
ENDCASE;
ENDCASE;
ENDLOOP;
Now fix up the world
FOR each: NodeList ¬ bodies, each.rest WHILE each # NIL DO
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
WITH node SELECT FROM
var: Var => IF var.flags[named] THEN recentVar ¬ var;
assign: AssignNode => prevAssign ¬ assign;
block: REF NodeRep.block => {
oldVar: Var ¬ recentVar;
IntCodeUtils.MapNodeList[block.nodes, inner];
recentVar ¬ oldVar;
RETURN [node];
};
source: REF NodeRep.source => {
oldSource: Node ¬ recentSource;
recentSource ¬ source;
IntCodeUtils.MapNodeList[source.nodes, inner];
recentSource ¬ oldSource;
RETURN [node];
};
apply: REF NodeRep.apply =>
WITH apply.proc SELECT FROM
mc: REF NodeRep.machineCode => {
guts: ROPE = mc.bytes;
SELECT TRUE FROM
Rope.Equal[guts, "XR𡤎nable"] => {
scopeId: CARD = IdFromOperNode[apply.args.first];
catchId: CARD = IdFromOperNode[apply.args.rest.first];
InsertBody[scopeId, recentSource];
InsertBody[catchId, recentSource];
};
ENDCASE;
};
operNode: REF NodeRep.oper => WITH operNode.oper SELECT FROM
code: REF OperRep.code => {
id: CARD = LOOPHOLE[code.label.id];
IF id >= BadBti THEN GO TO failed;
};
mesa: REF OperRep.mesa =>
SELECT mesa.mesa FROM
fork =>
IF prevAssign # NIL THEN WITH prevAssign.rhs SELECT FROM
aVar: Var => WITH aVar.location SELECT FROM
comp: REF LocationRep.composite =>
IF comp.parts # NIL THEN {
id: CARD = IdFromOperNode[comp.parts.first];
IF id # CARD.LAST THEN InsertBody[id, recentSource];
};
ENDCASE;
ENDCASE;
ENDCASE;
ENDCASE;
ENDCASE;
labelNode: REF NodeRep.label =>
WITH labelNode.label.node SELECT FROM
lambda: REF NodeRep.lambda => {
recentLambda ¬ lambda;
recentSource ¬ NIL;
recentVar ¬ NIL;
recentLambdaBti ¬ LOOPHOLE[labelNode.label.id];
IF LOOPHOLE[labelNode.label.id, CARD] >= BadBti THEN SIGNAL CantHappen;
};
ENDCASE;
ENDCASE;
IntCodeUtils.MapNode[node, inner];
RETURN [node];
EXITS failed => {SIGNAL CantHappen; RETURN [node]};
};
IdToLambda: PROC [id: CARD] RETURNS [LambdaNode] = {
FOR each: NodeList ¬ bodies, each.rest WHILE each # NIL DO
WITH each.first SELECT FROM
labelNode: REF NodeRep.label =>
WITH labelNode.label.node SELECT FROM
ln: REF NodeRep.lambda =>
IF id = LOOPHOLE[labelNode.label.id, CARD] THEN RETURN [ln];
ENDCASE;
ENDCASE;
ENDLOOP;
RETURN [NIL];
};
InsertBody: PROC [id: CARD, src: Node] = TRUSTED {
bti: CBTIndex = LOOPHOLE[id];
lambda: LambdaNode ¬ IdToLambda[id];
IF id >= BadBti OR lambda = NIL THEN SIGNAL CantHappen;
WITH src SELECT FROM
srcNode: REF NodeRep.source =>
IF srcNode.source.start > 0 THEN bb[bti].sourceIndex ¬ srcNode.source.start;
ENDCASE;
SELECT lambda.kind FROM
catch, scope, fork => {
These procedures were synthesized
parent: BTIndex ¬ recentLambdaBti;
IF recentVar # NIL THEN {
This is the most recently found "live" variable, so it should be in a scope that is a better parent than simply the lambda
varId: CARD = LOOPHOLE[recentVar.id];
tag: CARD = LOOPHOLE[Table.IndexRep[tag: Symbols.seTag, highBits: 0, lowBits: 0]];
IF varId >= tag
THEN SIGNAL CantHappen
ELSE {
sei: Symbols.ISEIndex = LOOPHOLE[tag+varId];
varBti: BTIndex ¬ FindVarBti[parent, seb[sei].idCtx];
IF varBti # Symbols.BTNull
AND varBti # recentLambdaBti THEN {
Insert this cookie as the sibling of the most recent variable
bb[bti].link ¬ bb[varBti].link;
bb[varBti].link ¬ [which: sibling, index: bti];
RETURN;
};
};
};
For now, just insert as the first son of the parent. This needs to be fixed when we consider the source.
MakeFirstSon[bti, parent];
};
ENDCASE => GO TO failed;
These cases should never need an insertion!
EXITS failed => SIGNAL CantHappen;
};
recentSource: Node ¬ NIL;
recentVar: Var ¬ NIL;
prevAssign: AssignNode ¬ NIL;
recentLambda: LambdaNode ¬ NIL;
recentLambdaBti: CBTIndex ¬ Symbols.CBTNull;
each.first ¬ inner[each.first];
ENDLOOP;
RelinkBodies[bodies];
Now shut down the world
TRUSTED {(MimData.table).DropNotify[Notify]};
};
IdFromOperNode: PROC [node: Node] RETURNS [CARD] = {
WITH node SELECT FROM
opNode: REF NodeRep.oper => WITH opNode.oper SELECT FROM
code: REF OperRep.code => RETURN [LOOPHOLE[code.label.id]];
ENDCASE;
ENDCASE;
RETURN [CARD.LAST];
};
END.