IntCodeTwigImpl.mesa
Copyright Ó 1986, 1987, 1988, 1989, 1990, 1991, 1993 by Xerox Corporation. All rights reserved.
Russ Atkinson (RRA) April 9, 1990 9:17:33 pm PDT
JKF July 27, 1988 8:00:10 am PDT
Christian Jacobi, May 4, 1993 8:30 pm PDT
DIRECTORY
Basics32 USING [BITXOR],
IntCodeDefs USING [ApplyNode, AssignNode, BlockNode, CaseList, CommentNode, CompositeLocation, ConstNode, DeclNode, DerefLocation, EnableNode, EscapeLocation, FieldLocation, GlobalVarLocation, GotoNode, Handler, HandlerRep, IndexedLocation, Label, LabelNode, LabelRep, LambdaNode, LocalVarLocation, Location, LocationRep, LogicalId, MachineCodeNode, ModuleNode, Node, NodeList, NodeRep, nullVariableId, OperNode, OperRep, ReturnNode, SourceNode, Var, VariableFlags, VarList, WordConstNode],
IntCodeEnables USING [GenLabel, GenTemp, RewriteEnables],
IntCodeOpt USING [CleanupLambda, GenAnonLocal, SimplifyValueBlocks],
IntCodeStuff USING [addrOperNode, allocOperNode, BitsForArgList, constant0, constant1, constant2, CopyVar, defaultNIL, emptyReturn, freeOperNode, GenAddr, GenAnonVar, GenApply, GenAssign, GenBlock, GenComment, GenComposite, GenConst, GenDecl, GenDeref, GenDummy, GenField, GenFieldLoc, GenXFieldLoc, GenFieldLocOfVar, GenFieldOfDeref, GenFree, GenGoTo, GenLabelAddress, GenLargeReturn, GenReturn, GenUpLevel, globalLinkInit, MarkAddressed, MarkAssigned, MarkUsed, NodeContains, NodeListCons2, NodeListCons3, NodeListCons5, PadComposite, StripNilCheck, subOperNode],
IntCodeTarget USING [bitsPerAU, bitsPerGlobal, bitsPerLink, bitsPerLocal, directGlobals, firstGlobalOffset, lastRegister, lastStack, logBitsPerGlobal, logBitsPerLocal, logMinBitsPerArgument, logMinBitsPerReturn, maxBitsArgumentRecord, maxBitsReturnRecord, minBitsPerArgument, minBitsPerReturn, ToBits, ToUnits],
IntCodeTwig USING [BaseModel, BaseModelRep, DeclsFetch, DeclsSize, DeclsStore, Duplicate, LabelsFetch, LabelsSize, LabelsStore, LambdaModel, LambdaModelRep, ModelsFetch, ModelsStore, Switches],
IntCodeUtils USING [IdTab, LabelVisitor, MapNode, MapNodeList, NewIdTab, NodeListCons, NodeListTail, SideEffectFree, SimplyEqual, VarListCons, VarListTail, VisitLabels, Visitor, WordToCard, WordToInt, zone],
IO USING [PutF1, PutFR, PutFR1, STREAM],
ProcessProps USING [GetProp],
Rope USING [ROPE],
Target: TYPE MachineParms USING [AlignmentIndex, Alignments, bitsPerProc, bitsPerWord, bitsPerProcess];
IntCodeTwigImpl: CEDAR PROGRAM
IMPORTS Basics32, IntCodeEnables, IntCodeOpt, IntCodeStuff, IntCodeTarget, IntCodeTwig, IntCodeUtils, IO, ProcessProps
EXPORTS IntCodeTwig
= BEGIN OPEN IntCodeDefs, IntCodeEnables, IntCodeStuff, IntCodeTarget, IntCodeTwig, IntCodeUtils, Rope;
IdTab: TYPE = IntCodeUtils.IdTab;
Options
smallExceptions: BOOL ¬ FALSE;
TRUE => use small exception raising
FALSE => use "normal" exception raising
simplifyValueBlocks: BOOL ¬ TRUE;
TRUE => perform some simplifications of value-returning blocks
FALSE => no transformation of value-returning blocks
useMemoryFromHandlers: BOOL = TRUE;
TRUE => uplevel use from catch phrase handlers force the target variable into memory
FALSE => uplevel use from catch phrase handlers can use registers
heapAllocFX: BOOL = FALSE;
TRUE => use heap allocation for frame extensions
FALSE => declare the frame extension as a simple (addressed) variable
cleanupCode: BOOL ¬ TRUE;
TRUE => call CleanupLambda to remove junk
FALSE => don't call CleanupLambda
Funny machine limitations (should be relocated some day)
indexedImpliesAddressedLimit: INT ¬ LAST[INT];
for larger indexed bases they must be addressable
localVarRegisterLimit: INT ¬ LAST[INT];
for larger local vars they must be addressable
firstMappedOffset: INT ¬ 8*LONG[1024]*IntCodeTarget.bitsPerAU;
This should be parameterized!
worst: NAT = Target.Alignments[Target.AlignmentIndex.LAST];
Statically known offsets in the frame extension
staticLinkOffset: NAT = 0;
link to next enclosing frame extension (bits)
firstLocalOffsetLinks: NAT = 4;
offset for first local variable (in words)
firstLocalOffset: NAT = firstLocalOffsetLinks*bitsPerLink;
offset for first local variable (in bits)
The global zone
z: ZONE ¬ IntCodeUtils.zone;
The (optional) pass to rewrite enables
rewriteEnables: PROC
[node: Node, genTemp: GenTemp, genLabel: GenLabel] RETURNS [Node] ¬ NIL;
Signals & Errors
Duplicate: PUBLIC SIGNAL = CODE;
Signalled when a duplicate condition is found
CantHappen: SIGNAL = CODE;
Signalled when something is simply not possible (according to our intentions, at least)
NotYetImplemented: SIGNAL = CODE;
Signalled when something is not yet supported.
Public routines
DoModule: PUBLIC PROC [module: Node, switches: Switches] RETURNS [BaseModel] = {
ENABLE
CantHappen => IF switches['i] THEN {
Eventually do some debugging here and allow for resuming
RESUME;
};
RETURN [DoModuleInner[module, switches]];
};
DoModuleInner: PROC [module: Node, switches: Switches] RETURNS [BaseModel] = {
base: BaseModel ¬ z.NEW[BaseModelRep ¬ [
module: module,
labels: IntCodeUtils.NewIdTab[],
decls: IntCodeUtils.NewIdTab[],
models: IntCodeUtils.NewIdTab[]
]];
IF switches['h] OR rewriteEnables # NIL THEN {
genTemp: GenTemp = {
RETURN [IntCodeOpt.GenAnonLocal[base, parent, bits]];
};
genLabel: GenLabel = {
RETURN [GenAnonLabelNode[base, node]];
};
IF rewriteEnables # NIL
THEN module ¬ rewriteEnables[module, genTemp, genLabel]
ELSE module ¬ IntCodeEnables.RewriteEnables[module, genTemp, genLabel];
};
InitModels[base, module, NIL];
Build the initial models for each procedure in the graph.
CanonVars[base, module, NIL];
Canonicalize the variables for each procedure in the graph.
[[ This pass sets the upLevel and addressed (=> notRegister) variable flags ]]
Find and mark all of the local variables that are up-level referenced
[[ This pass sets the notRegister variable flag ]]
FOR m: LambdaModel ¬ base.first, m.next WHILE m # NIL DO
MarkUplevelLocals[base, m, m.lambda];
ENDLOOP;
IF simplifyValueBlocks THEN
Run a pass to remove block exprs, since we only introduce simple locals
FOR m: LambdaModel ¬ base.first, m.next WHILE m # NIL DO
IntCodeOpt.SimplifyValueBlocks[base, m, m.lambda];
ENDLOOP;
IF lastStack # 0 THEN
There is stack depth checking in force. If lastStack = 0 then the stack is effectively unlimited (as is the case for translating into some higher-level language).
FOR m: LambdaModel ¬ base.first, m.next WHILE m # NIL DO
CheckStackDepth[base, m, m.lambda];
ENDLOOP;
Allocate the memory for local variables that must be placed in memory locations (as opposed to registers). This creates the frame extension.
FOR m: LambdaModel ¬ base.first, m.next WHILE m # NIL DO
AllocMemLocals[base, m, m.lambda];
ENDLOOP;
Create the locations for up-level references to local variables in enclosing scopes
FOR m: LambdaModel ¬ base.first, m.next WHILE m # NIL DO
SubstUplevelLocals[base, m, m.lambda];
ENDLOOP;
Create the locations for local variables that must be in memory
[[ This pass sets the used and assigned bits for variables ]]
FOR m: LambdaModel ¬ base.first, m.next WHILE m # NIL DO
SubstLocals[base, m, m.lambda];
ENDLOOP;
Cleanup the world
[[ At this point we can rely on the used & assigned flags ]]
IF cleanupCode THEN
FOR m: LambdaModel ¬ base.first, m.next WHILE m # NIL DO
rtnPtr: Var ¬ NIL;
IF m.returnVar # NIL THEN
WITH m.returnVar.location SELECT FROM
deref: REF LocationRep.deref =>
WITH deref.addr SELECT FROM
v: Var => rtnPtr ¬ v;
ENDCASE;
ENDCASE;
IntCodeOpt.CleanupLambda[base, m, m.lambda, rtnPtr];
ENDLOOP;
Place the final comment
WITH module SELECT FROM
m: ModuleNode => {
tail: NodeList ¬ m.procs ¬ NIL;
FOR lm: LambdaModel ¬ base.first, lm.next WHILE lm # NIL DO
labelNode: LabelNode ¬ z.NEW[NodeRep.label ¬ [0, label[lm.label]]];
list: NodeList ¬ NodeListCons[labelNode];
IF tail = NIL THEN m.procs ¬ list ELSE tail.rest ¬ list;
tail ¬ list;
ENDLOOP;
};
ENDCASE;
RETURN [base];
};
Private routines
InitModels: PROC [base: BaseModel, node: Node, model: LambdaModel] = {
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
WITH node SELECT FROM
const: ConstNode => RETURN [node];
No components => no map
var: Var =>
WITH var.location SELECT FROM
local: LocalVarLocation => RETURN [node];
No components => no map
global: GlobalVarLocation => RETURN [node];
No components => no map
ENDCASE;
decl: DeclNode =>
AddVar[decl.var, model];
label: LabelNode => {
lab: Label ¬ label.label;
IF lab # NIL THEN {
id: LogicalId ¬ lab.id;
IF LabelsFetch[base, id] # lab THEN LabelsStore[base, id, lab];
WITH lab.node SELECT FROM
lambda: LambdaNode => {
newModel: LambdaModel ¬ z.NEW[LambdaModelRep ¬ [
label: lab,
lambda: lambda,
parentModel: NIL,
parentLabel: lambda.parent,
nesting: 0,
forceLong: id = 0]];
Note the test for id = 0
IF lambda.parent # NIL
AND lambda.descBody = NIL
AND lambda.formalArgs # NIL THEN
newModel.isCatch ¬ TRUE;
ModelsStore[base, id, newModel];
IF base.tail = NIL
THEN base.first ¬ newModel
ELSE base.tail.next ¬ newModel;
base.tail ¬ newModel;
InitModels[base, lambda, newModel];
RETURN [node];
};
ENDCASE;
};
};
lambda: LambdaNode => {
units: INT ¬ 0;
model.returnBits ¬ lambda.bitsOut;
First, calculate the size of the argument record.
FOR each: VarList ¬ lambda.formalArgs, each.rest WHILE each # NIL DO
arg: Var ¬ each.first;
IF arg # NIL THEN
units ¬ units + ToUnits[arg.bits, minBitsPerArgument, logMinBitsPerArgument];
ENDLOOP;
model.argumentBits ¬ ToBits[units, logMinBitsPerArgument];
Now assign initial locations to the arguments.
IF model.forceLong OR model.argumentBits > maxBitsArgumentRecord
THEN {
This procedure has a large argument record, so replace it with an argument record pointer. Also replace the locations of the formal arguments with field values.
oldArgList: VarList ¬ lambda.formalArgs;
argPtr: Var ¬ GenAnonVar[bitsPerLink];
argTemp: Var ¬ GenDeref[argPtr, MAX[model.argumentBits, bitsPerLink], worst];
units: INT ¬ 0;
model.argumentBits ¬ bitsPerLink;
FOR each: VarList ¬ oldArgList, each.rest WHILE each # NIL DO
reassign the location to be a field of the arg record
arg: Var ¬ each.first;
IF arg # NIL THEN {
bits: INT ¬ ToBits[units, logMinBitsPerArgument];
arg.location ¬ GenFieldLocOfVar[argTemp, bits];
AddVar[arg, model];
units ¬ units + ToUnits[arg.bits, minBitsPerArgument, logMinBitsPerArgument];
};
ENDLOOP;
lambda.formalArgs ¬ VarListCons[argPtr];
model.argVar ¬ argTemp;
AddVar[argPtr, model];
}
ELSE {
The arguments are all simple local variables.
FOR each: VarList ¬ lambda.formalArgs, each.rest WHILE each # NIL DO
AddVar[each.first, model];
ENDLOOP;
};
Now map over the subsidiary nodes of the procedure.
IntCodeUtils.MapNodeList[lambda.body, inner];
At this point we have determined the number of bits that are to be returned.
IF model.returnVar # NIL OR HasLongReturnVar[model, model.returnBits] THEN
The return variable is indirect from an argument!
WITH model.returnVar.location SELECT FROM
deref: REF LocationRep.deref =>
WITH deref.addr SELECT FROM
rtnPtr: Var => {
AddVar[rtnPtr, model];
lambda.formalArgs ¬ VarListCons[rtnPtr, lambda.formalArgs];
lambda.bitsOut ¬ 0;
};
ENDCASE => SIGNAL CantHappen;
ENDCASE => SIGNAL CantHappen;
RETURN [node];
};
goto: GotoNode => {
label: Label = goto.dest;
SELECT TRUE FROM
label = NIL => {};
NOT label.used OR NOT label.jumpedTo => {};
goto.backwards AND NOT label.backTarget => {};
ENDCASE => RETURN [node];
SIGNAL CantHappen;
RETURN [node];
};
apply: ApplyNode => {
Make long argument & return records into indirections. Do the same for argument & resume records for signals & errors. Don't do it for applications of machine code!
retBits: INT ¬ apply.bits;
argBits: INT ¬ BitsForArgList[apply.args];
units: INT ¬ ToUnits[argBits, minBitsPerArgument, logMinBitsPerArgument];
tail: NodeList ¬ NIL;
useLargeArgs: BOOL ¬ argBits > maxBitsArgumentRecord;
useLargeRets: BOOL ¬ retBits > minBitsPerReturn;
IntCodeUtils.MapNode[apply, inner];
Map all of the pieces first
WITH apply.proc SELECT FROM
mc: MachineCodeNode => RETURN [node];
Don't transform this further, since we are being quite trusting here.
oper: OperNode => {
args: NodeList ¬ apply.args;
WITH oper.oper SELECT FROM
code: REF OperRep.code => {
IF code.label = NIL OR NOT code.label.used THEN SIGNAL CantHappen;
};
mesa: REF OperRep.mesa => {
SELECT mesa.mesa FROM
signal, error => IF apply.args = NIL THEN SIGNAL CantHappen ELSE {
The first argument is the signal or error to be raised. For a signal, the second argument is the pointer to the resume record (NIL if none). The remaining argument is a pointer to the argument record (NIL if none). The signaller does not need to know the size of the arguments.
first: Node ¬ args.first;
rest: NodeList ¬ args.rest;
nArgs: INT ¬ 0;
FOR each: NodeList ¬ rest, each.rest WHILE each # NIL DO
nArgs ¬ nArgs + 1;
ENDLOOP;
IF smallExceptions THEN {
name: ROPE ¬ NIL;
SELECT mesa.mesa FROM
error => SELECT nArgs FROM
0 => name ¬ "XR𡤎rror0";
1 => name ¬ "XR𡤎rror1";
2 => name ¬ "XR𡤎rror2";
ENDCASE => GO TO notSmall;
signal => {
IF retBits # 0 THEN GO TO notSmall;
SELECT nArgs FROM
0 => name ¬ "XR←Signal0";
1 => name ¬ "XR←Signal1";
2 => name ¬ "XR←Signal2";
ENDCASE => GO TO notSmall;
};
ENDCASE => ERROR;
apply.proc ¬ z.NEW[NodeRep.machineCode ¬
[bits: 0, details: machineCode[name]]];
GO TO ret;
EXITS notSmall => {};
};
IF rest = NIL
THEN rest ¬ NodeListCons[defaultNIL]
ELSE {
apply.args ¬ rest;
node ¬ GenLargeArgs[base, apply, model];
rest ¬ apply.args;
};
SELECT TRUE FROM
mesa.mesa = error => {};
No resume value possible for errors, none expected. However, retBits need not be 0, as in the code for:
x ← IF P[...] THEN 4 ELSE ERROR
retBits = 0 =>
No resume value possible. Pass in a NIL.
rest ¬ NodeListCons[defaultNIL, rest];
ENDCASE => {
There may be a resume value passed back. It always gets assigned through the memory pointer.
addr: Node ¬ NIL;
[new: node, addr: addr]
¬ GenLargeRets[base, model, node, retBits];
rest ¬ NodeListCons[addr, rest];
};
apply.args ¬ NodeListCons[first, rest];
GO TO ret;
};
fork => {
node ¬ TransformFork[base, model, apply];
GO TO ret;
};
join => {
need to create a block with a temp large enough to contain the return value, then free the return record
rtnBits: INT ¬ node.bits;
node.bits ¬ bitsPerLink;
The join primitive always returns a pointer
IF rtnBits # 0 THEN {
result: Var ¬ IntCodeOpt.GenAnonLocal[base, model.label, rtnBits];
rtnPtr: Var ¬ IntCodeOpt.GenAnonLocal[base, model.label, bitsPerLink];
rtnSrc: Node ¬ GenDeref[rtnPtr, rtnBits, worst];
head: NodeList ¬ NodeListCons[GenDecl[result, NIL]];
declare the result variable
tail: NodeList ¬ head;
tail ¬ tail.rest ¬ NodeListCons[GenDecl[rtnPtr, node]];
gen the call to primitive JOIN and save the result pointer
tail ¬ tail.rest ¬ NodeListCons[GenAssign[result, rtnSrc]];
assign from the result pointer to the actual result variable
tail ¬ tail.rest ¬ NodeListCons[GenFree[rtnPtr]];
free the temporary variable variable
tail ¬ tail.rest ¬ NodeListCons[result];
the result is in the result variable
RETURN [GenBlock[head, rtnBits]];
};
RETURN [GenAssign[GenDummy[bitsPerLink], node]];
In the case of no return values we just ignore the result
};
resume, reject, unwind => {
We need to return two things
[] ¬ HasLongReturnVar[model, minBitsPerArgument*2];
GO TO checkArgs;
};
startGlobal => {
rets ← START module[args]
prog: Node ¬ apply.args.first;
rest: NodeList ¬ apply.args ¬ apply.args.rest;
IF rest # NIL
THEN node ¬ GenLargeArgs[base, apply, model]
ELSE apply.args ¬ NodeListCons[defaultNIL];
apply.args ¬ NodeListCons[prog, apply.args];
IF retBits = 0
THEN apply.args ¬ NodeListCons[defaultNIL, apply.args]
ELSE {
addr: Node ¬ NIL;
[node, addr] ¬ GenLargeRets[base, model, node, retBits];
apply.args ¬ NodeListCons[addr, apply.args];
};
GO TO ret;
};
addr => apply.proc ¬ addrOperNode;
free => apply.proc ¬ freeOperNode;
alloc => apply.proc ¬ allocOperNode;
ENDCASE;
GO TO ret;
};
ENDCASE => GO TO ret;
EXITS checkArgs => {};
};
ENDCASE;
IF useLargeArgs THEN
There is a large argument record, which must be placed in memory. The argument list is then converted into passing a pointer to that temporary.
node ¬ GenLargeArgs[base, apply, model];
note: changes apply.args!
IF useLargeRets THEN {
There is a large return record. This means that the first argument for the procedure is really a pointer to the return record.
addr: Node ¬ NIL;
[node, addr] ¬ GenLargeRets[base, model, node, retBits];
apply.args ¬ NodeListCons[addr, apply.args];
};
GO TO ret;
EXITS ret => RETURN [node];
};
return: ReturnNode => {
IF return.rets = NIL THEN RETURN [emptyReturn];
IntCodeUtils.MapNode[node, inner];
node ¬ CanonReturn[return, model];
RETURN [node];
};
module: ModuleNode => {
Assign global locations to the variables.
offset: INT ¬ IntCodeTarget.firstGlobalOffset;
FOR each: VarList ¬ module.vars, each.rest WHILE each # NIL DO
var: Var ¬ each.first;
IF var # NIL THEN {
bits: INT ¬ var.bits;
units: INT ¬ ToUnits[bits, IntCodeTarget.bitsPerGlobal, IntCodeTarget.logBitsPerGlobal];
round: INT ¬ ToBits[units, IntCodeTarget.logMinBitsPerArgument];
loc: Location ¬ z.NEW[LocationRep.globalVar ¬ [globalVar[offset]]];
var.location ¬ loc;
DeclsStore[base, var.id, var];
offset ¬ offset + round;
};
ENDLOOP;
};
ENDCASE;
IntCodeUtils.MapNode[node, inner];
RETURN [node];
};
AddVar: PROC [var: Var, model: LambdaModel] = {
IF var # NIL AND model # NIL AND DeclsFetch[base, var.id] = NIL THEN {
IF var.id = nullVariableId THEN
Generate a new id
var.id ¬ -DeclsSize[base]-1;
IF var.location = NIL THEN
var.location ¬ z.NEW[LocationRep.localVar ¬ [localVar[var.id, model.label]]];
DeclsStore[base, var.id, var];
};
};
canonLabels: IntCodeUtils.LabelVisitor = {
[label: Label, node: Node, define: BOOL ← FALSE] RETURNS [Label]
IF NOT define THEN {
new: Label ¬ LabelsFetch[base, label.id];
IF new # NIL THEN RETURN [new];
};
RETURN [label];
};
[] ¬ inner[node];
IF model = NIL THEN
Canonicalize the labels for the whole model
IntCodeUtils.VisitLabels[node: node, visitor: canonLabels, fullTree: TRUE, visitNIL: FALSE];
};
CanonVars: PROC [base: BaseModel, node: Node, model: LambdaModel] = {
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
WITH node SELECT FROM
var: Var => {
Canonicalize the variable
canon: Var ¬ DeclsFetch[base, var.id];
IF canon # NIL THEN {
WITH canon.location SELECT FROM
local: LocalVarLocation => {
Any use of a local variable outside of its parent scope causes it to become addressed and marked as an upLevel variable.
parent: Label ¬ IF model = NIL THEN NIL ELSE model.label;
IF local.parent # parent THEN canon.flags[upLevel] ¬ TRUE;
};
global: GlobalVarLocation => IF NOT IntCodeTarget.directGlobals THEN {
A global variable, and we need a global link.
IF model # NIL AND model.globalLink = NIL THEN
We have to have a global link, which looks like an anonymous local variable.
model.globalLink ¬ IntCodeOpt.GenAnonLocal[base, model.label, bitsPerLink];
};
ENDCASE;
var ¬ canon;
};
WITH var.location SELECT FROM
local: LocalVarLocation => {
Any use of a local variable outside of its parent scope causes it to become addressed.
IF var.bits > localVarRegisterLimit THEN
A local variable is addressable if it is large enough
MarkAddressed[var];
};
indexed: IndexedLocation => {
base: Node ¬ indexed.base ¬ inner[indexed.base];
index: Node ¬ indexed.index ¬ inner[indexed.index];
WITH index SELECT FROM
const: WordConstNode => {
If a constant index gets this far we can turn it into a field
val: INT ¬ IntCodeUtils.WordToInt[const.word];
var.location ¬ GenFieldLoc[base, val*var.bits];
};
ENDCASE =>
IF base # NIL AND base.bits > indexedImpliesAddressedLimit THEN
An array is addressable if it is large enough and indexed
MarkAddressed[base];
};
ENDCASE => IntCodeUtils.MapNode[var, inner];
RETURN [var];
};
decl: DeclNode => {
var: Var ¬ DeclsFetch[base, decl.var.id];
No processing necessary for a declared variable.
decl.init ¬ inner[decl.init];
Process the initialization as a normal expression
RETURN [node];
};
labelNode: LabelNode => {
label: Label = labelNode.label;
IF label # NIL THEN {
id: LogicalId ¬ label.id;
WITH label.node SELECT FROM
lambda: LambdaNode => {
newModel: LambdaModel ¬ ModelsFetch[base, id];
lambda.descBody ¬ NARROW[inner[lambda.descBody]];
CanonLambda[base, newModel, lambda];
IF newModel.isCatch THEN
[] ¬ GetHandlerArgs[newModel];
For argument list verification.
RETURN [node];
};
ENDCASE;
};
};
enable: EnableNode => {
handler: Handler ¬ enable.handle;
IF handler # NIL THEN {
proc: Node ¬ handler.proc;
handler.proc ¬ MarkCatch[base, proc];
[] ¬ inner[proc];
};
};
assign: AssignNode => {
IntCodeUtils.MapNode[node, inner];
IF assign.lhs # NIL AND assign.lhs.id # nullVariableId THEN
assign.lhs.flags[assigned] ¬ TRUE;
RETURN [node];
};
apply: ApplyNode => {
handler: Handler ¬ apply.handler;
IF handler # NIL THEN {
proc: Node ¬ handler.proc;
handler.proc ¬ MarkCatch[base, proc];
[] ¬ inner[proc];
};
IntCodeUtils.MapNode[node, inner];
WITH apply.proc SELECT FROM
oper: OperNode => {
WITH oper.oper SELECT FROM
mesa: REF OperRep.mesa =>
SELECT mesa.mesa FROM
addr => {
args: NodeList ¬ apply.args;
IF args # NIL THEN MarkAddressed[args.first];
};
ENDCASE;
ENDCASE;
};
ENDCASE;
RETURN [node];
};
block: BlockNode => {
Sometimes blocks get generated for no particularly good reason
list: NodeList ¬ block.nodes;
count: INT ¬ 0;
decl0: DeclNode ¬ NIL;
assign1: AssignNode ¬ NIL;
var1: Var ¬ NIL;
var2: Var ¬ NIL;
FOR each: NodeList ¬ list, each.rest WHILE each # NIL DO
WITH each.first SELECT FROM
decl: DeclNode =>
IF count = 0 THEN decl0 ¬ decl ELSE decl0 ¬ NIL;
assign: AssignNode =>
IF count = 1 THEN assign1 ¬ assign ELSE assign1 ¬ NIL;
var: Var => {
IF count = 1 THEN var1 ¬ var ELSE var1 ¬ NIL;
IF count = 2 THEN var2 ¬ var ELSE var2 ¬ NIL;
};
ENDCASE;
count ¬ count + 1;
IF count > 3 THEN EXIT;
ENDLOOP;
SELECT count FROM
1 => IF decl0 = NIL THEN
This is a trivial block, so just use the first node
RETURN [inner[list.first]];
2 => IF decl0 # NIL AND decl0.var = var1 THEN
This is a nearly trivial block, so just use the decl0 initialization
RETURN [inner[decl0.init]];
3 => IF decl0 # NIL AND decl0.var = var2 AND decl0.init = NIL
AND assign1 # NIL AND assign1.lhs = var2 THEN
This may be a trivial block, so check farther
IF NOT NodeContains[assign1.rhs, var2] THEN
How about that, the block is trivial!
RETURN [inner[assign1.rhs]];
ENDCASE;
};
ENDCASE;
IntCodeUtils.MapNode[node, inner];
RETURN [node];
};
[] ¬ inner[node];
};
DetermineNesting: PROC [base: BaseModel, model: LambdaModel] = {
parent: Label ¬ model.parentLabel;
IF parent # NIL AND model.nesting = 0 THEN {
parentModel: LambdaModel ¬ ModelsFetch[base, parent.id];
IF parentModel # NIL THEN {
DetermineNesting[base, parentModel];
model.parentModel ¬ parentModel;
model.parentLabel ¬ parentModel.label;
model.nesting ¬ parentModel.nesting + 1;
};
};
};
CanonLambda: PROC [base: BaseModel, model: LambdaModel, lambda: LambdaNode] = {
IF model # NIL AND model.parentLabel # NIL AND model.parentModel = NIL THEN
Finally we can determine the parent model.
DetermineNesting[base, model];
CanonVars[base, lambda, model];
SELECT TRUE FROM
model.isCatch => {
The static link is passed in via the regsPtr argument
model.staticLink ¬ GetHandlerArgs[model].regsPtr;
model.returnBits ¬ 2*bitsPerLink;
};
lambda.parent # NIL => {
This procedure always takes a static link, which appears as an extra argument.
static: Var ¬ IntCodeOpt.GenAnonLocal[base, model.label, bitsPerLink];
staticList: VarList ¬ VarListCons[static];
model.staticLink ¬ static;
IF lambda.formalArgs = NIL
THEN lambda.formalArgs ¬ staticList
ELSE VarListTail[lambda.formalArgs].rest ¬ staticList;
};
ENDCASE;
IF model.globalLink # NIL THEN {
This lambda uses global variables, so we add a global link.
decl: Node ¬ GenDecl[model.globalLink, globalLinkInit];
model.globalLink.flags[frequent] ¬ TRUE;
lambda.body ¬ NodeListCons[decl, lambda.body];
};
};
CheckStackDepth: PROC [base: BaseModel, model: LambdaModel, lambda: LambdaNode] = {
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
oldDepth: INT ¬ depth;
IF depth > lastStack THEN ERROR CantHappen;
This is simply not right!
IF node = NIL OR CanSimplyPush[node, depth] THEN RETURN [node];
Guaranteed to be simple enough to push without transformations. This includes having no declarations, so no further transformations are needed.
WITH node SELECT FROM
decl: DeclNode => {
Each decl that can be on the stack is assumed to be there.
var: Var ¬ decl.var;
IF var # NIL AND NOT var.flags[notRegister] THEN
WITH var.location SELECT FROM
local: LocalVarLocation => {
units: INT ¬ ToUnits[var.bits, bitsPerLocal, logBitsPerLocal];
next: INT ¬ depth+units;
IF next > lastRegister
THEN {
Can't be an addressable register
var.flags[notRegister] ¬ TRUE;
}
ELSE {
Can be an addressable register
depth ¬ next;
IF depth > max THEN max ¬ depth;
};
};
ENDCASE;
decl.init ¬ inner[decl.init];
RETURN [node];
};
apply: ApplyNode => {
For complicated applications we may have to build some arguments in memory.
args: NodeList ¬ apply.args;
argsUnits: INT ¬ ToUnits[BitsForArgList[args], bitsPerLocal, logBitsPerLocal];
tail: NodeList ¬ NIL;
lastTemp: INT ¬ lastStack-maxBitsArgumentRecord/bitsPerLocal;
PutArgInMemory: PROC [arg: Node] RETURNS [Var] = {
var: Var ¬ GenMemTemp[base, arg.bits, model];
new: NodeList ¬ NodeListCons[GenDecl[var, inner[arg]]];
var.flags[constant] ¬ TRUE;
IF tail = NIL
THEN {
The first time through we turn the node into a block expression. The tail is always the most recent thing to be made into a memory temporary.
new.rest ¬ NodeListCons[apply];
node ¬ GenBlock[new, apply.bits];
}
ELSE {
Slip the new node in between the last thing made into a temporary and the apply node.
new.rest ¬ tail.rest;
tail.rest ¬ new;
};
tail ¬ new;
RETURN [var];
};
IF NOT CanSimplyPush[apply.proc, depth+argsUnits] THEN
In the unlikely case that the procedure is really complicated, then put it into a temp first of all. This keeps us from getting into trouble by putting all of the arguments on the stack before discovering disaster.
apply.proc ¬ PutArgInMemory[apply.proc];
If there are 0 arguments or a single argument then no further temporary is necessary.
SELECT TRUE FROM
args = NIL =>
GO TO commonExit;
args.rest = NIL => {
Single argument procedure.
args.first ¬ inner[args.first];
GO TO commonExit;
};
ENDCASE;
WITH apply.proc SELECT FROM
oper: OperNode => {
WITH oper.oper SELECT FROM
code: REF OperRep.code => GO TO useProcApply;
Use normal application mechanism
mesa: REF OperRep.mesa =>
SELECT mesa.mesa FROM
addr, equal, notEqual => GO TO useAddrs;
ENDCASE;
ENDCASE;
Multi-argument operations get special treatment because the order of evaluation for the arguments is not always specified. We make a very conservative estimate here, which can be worse (but not better) than the normal procedure call case.
FOR each: NodeList ¬ args, each.rest WHILE each # NIL DO
arg: Node ¬ each.first;
units: INT ¬ ToUnits[arg.bits, minBitsPerArgument, logMinBitsPerArgument];
SELECT TRUE FROM
depth <= lastTemp, CanSimplyPush[arg, depth+argsUnits] =>
No temporary needed
each.first ¬ inner[arg];
ENDCASE =>
This is a complicated argument and the stack is pretty full, so evaluate the argument into memory.
each.first ¬ PutArgInMemory[arg];
ENDLOOP;
GO TO commonExit;
EXITS
useProcApply => {};
useAddrs => {
We are actually using the addresses of the arguments, not the arguments themselves. So we just calculate the number of words we need, then transform the arguments.
localsPerLink: NAT = bitsPerLink/bitsPerLocal;
to allocate locals for a link
FOR each: NodeList ¬ args, each.rest WHILE each # NIL DO
depth ¬ depth + localsPerLink;
ENDLOOP;
FOR each: NodeList ¬ args, each.rest WHILE each # NIL DO
each.first ¬ inner[each.first];
ENDLOOP;
GO TO commonExit;
};
};
ENDCASE;
FOR each: NodeList ¬ args, each.rest WHILE each # NIL DO
arg: Node ¬ each.first;
units: INT ¬ ToUnits[arg.bits, minBitsPerArgument, logMinBitsPerArgument];
next: INT ¬ units+depth;
SELECT TRUE FROM
next <= lastTemp => {
Push this argument
depth ¬ next;
each.first ¬ inner[arg];
};
CanSimplyPush[arg, depth] =>
This can be generated as necessary, so we do not need to pre-evaluate it
each.first ¬ inner[arg];
ENDCASE =>
This is a complicated argument and the stack is nearly full, so evaluate the argument into memory.
each.first ¬ PutArgInMemory[arg];
ENDLOOP;
GO TO commonExit;
EXITS commonExit => {
depth ¬ oldDepth;
RETURN [node];
};
};
lambda: LambdaNode => RETURN [node];
source: SourceNode => {
Source nodes must preserve any depth alterations
FOR each: NodeList ¬ source.nodes, each.rest WHILE each # NIL DO
each.first ¬ inner[each.first];
ENDLOOP;
RETURN [node];
};
ENDCASE;
IntCodeUtils.MapNode[node, inner];
depth ¬ oldDepth;
RETURN [node];
};
depth: INT ¬ ToUnits[model.argumentBits, minBitsPerArgument, logMinBitsPerArgument];
max: INT ¬ depth;
localsPerLink: NAT = bitsPerLink/bitsPerLocal;
IF model.returnVar # NIL THEN depth ¬ depth+localsPerLink;
IF model.globalLink # NIL THEN depth ¬ depth+localsPerLink;
IntCodeUtils.MapNode[lambda, inner];
};
MarkUplevelLocals: PROC [base: BaseModel, model: LambdaModel, lambda: LambdaNode] = {
This routine walks the tree and marks all variables that are up-level referenced. We also have to copy them because the locations will be altered when we assign memory & register locations to locals.
Also, this routine transforms reject, resume and unwind nodes into the appropriate return nodes.
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
WITH node SELECT FROM
var: Var => {
WITH var.location SELECT FROM
local: LocalVarLocation => {
IF model # NIL AND var.flags[upLevel] THEN {
target: Label = local.parent;
IF target # NIL AND target # model.label THEN {
This is an up-level reference to a local variable.
notRegister: BOOL ¬ var.flags[notRegister];
FOR mod: LambdaModel ¬ model, mod.parentModel DO
SELECT TRUE FROM
mod = NIL => {
Up-level reference to a lambda that does not logically enclose!
VarCantHappen[var, "ref to non-enclosing lambda"];
EXIT};
mod.label = target => {
var.flags[notRegister] ¬ notRegister;
RETURN [CopyVar[var]];
};
mod.staticLink = NIL => {
This should have been done in CanonLambda! Why not?
VarCantHappen[var, "can't find static link"];
EXIT};
ENDCASE;
IF useMemoryFromHandlers OR NOT mod.isCatch THEN
Must use memory locations for this variable
notRegister ¬ TRUE;
ENDLOOP;
};
};
RETURN [node];
};
deref: DerefLocation => {
old: Node ¬ deref.addr;
IF old # NIL THEN {
new: Node ¬ inner[old];
IF new # old THEN {
nVar: Var ¬ CopyVar[var];
nVar.location ¬ z.NEW[LocationRep.deref ¬ [deref[new, deref.align]]];
RETURN [nVar];
};
};
RETURN [var];
};
field: FieldLocation => {
old: Node ¬ field.base;
IF old # NIL THEN {
new: Node ¬ inner[old];
IF new # old THEN {
nVar: Var ¬ CopyVar[var];
IF field.cross
THEN nVar.location ¬ GenXFieldLoc[new, field.start] --ChJ, May 4, 1993
ELSE nVar.location ¬ GenFieldLoc[new, field.start];
RETURN [nVar];
};
};
RETURN [var];
};
indexed: IndexedLocation => {
base: Node ¬ indexed.base;
index: Node ¬ indexed.index;
IF base # NIL THEN base ¬ inner[base];
IF index # NIL THEN index ¬ inner[index];
IF base # indexed.base OR index # indexed.index THEN {
nVar: Var ¬ CopyVar[var];
nVar.location ¬ z.NEW[LocationRep.indexed ¬ [indexed[base, index]]];
RETURN [nVar];
};
RETURN [var];
};
composite: CompositeLocation => {
FOR each: NodeList ¬ composite.parts, each.rest WHILE each # NIL DO
old: Node ¬ each.first;
IF old # NIL THEN {
new: Node ¬ inner[old];
IF old # new THEN {
At this point we have to copy the current part of the list, then map the rest, and return the new variable.
nVar: Var ¬ CopyVar[var];
head: NodeList ¬ NIL;
tail: NodeList ¬ NIL;
nLoc: REF LocationRep.composite
¬ z.NEW[LocationRep.composite ¬ [composite[NIL]]];
Copy the head of the list up to the list node that differs
FOR lead: NodeList ¬ composite.parts, lead.rest WHILE lead # each DO
copy: NodeList ¬ NodeListCons[lead.first];
IF tail = NIL THEN nLoc.parts ¬ copy ELSE tail.rest ¬ copy;
tail ¬ copy;
ENDLOOP;
Now append the differing element
IF tail = NIL
THEN tail ¬ nLoc.parts ¬ NodeListCons[new]
ELSE tail ¬ tail.rest ¬ NodeListCons[new];
Now append the rest, mapping if not NIL
FOR lead: NodeList ¬ each.rest, lead.rest WHILE lead # NIL DO
copy: NodeList ¬ NodeListCons[old ¬ lead.first];
IF old # NIL THEN copy.first ¬ inner[old];
tail ¬ tail.rest ¬ copy;
ENDLOOP;
nVar.location ¬ nLoc;
RETURN [nVar];
};
};
ENDLOOP;
RETURN [var];
};
escape: EscapeLocation => {
base: Node ¬ escape.base;
IF base # NIL THEN {
base ¬ inner[base];
IF base # escape.base THEN {
nVar: Var ¬ CopyVar[var];
nVar.location ¬ z.NEW[LocationRep.escape
¬ [escape[id: escape.id, base: base, offset: escape.offset]]];
RETURN [nVar];
};
};
RETURN [var];
};
ENDCASE;
};
return: ReturnNode =>
Just in case we changed things
node ¬ CanonReturn[return, model];
apply: ApplyNode => {
Transform application of resume & unwind applications.
WITH apply.proc SELECT FROM
oper: OperNode => {
args: NodeList ¬ apply.args;
WITH oper.oper SELECT FROM
mesa: REF OperRep.mesa => {
SELECT mesa.mesa FROM
reject => {
Return with code = 0.
rets: NodeList ¬ NodeListCons[constant0, NodeListCons[constant0]];
node ¬ GenReturn[rets];
GO TO fixReturn;
};
resume => {
The return values (if any) get assigned through the rtnPtr.
Then we return with code = 1.
rets: NodeList ¬ NodeListCons[constant1, NodeListCons[constant0]];
node ¬ GenReturn[rets];
IF args # NIL THEN {
comp: Node ¬ PadComposite[args, logMinBitsPerReturn];
dest: Var ¬ GenDeref[
GetHandlerArgs[model].rtnPtr, comp.bits, worst];
assign: Node ¬ GenAssign[dest, comp];
node ¬ GenBlock[NodeListCons2[assign, node]];
};
GO TO fixReturn;
};
unwind => {
Return with code = 2.
rets: NodeList ¬ NodeListCons[constant2, args];
node ¬ GenReturn[rets];
GO TO fixReturn;
};
ENDCASE;
EXITS fixReturn => RETURN [inner[node]];
};
ENDCASE;
};
ENDCASE;
};
lambda: LambdaNode => RETURN [node];
ENDCASE;
IntCodeUtils.MapNode[node, inner];
RETURN [node];
};
IntCodeUtils.MapNode[lambda, inner];
};
AllocMemLocals: PROC [base: BaseModel, model: LambdaModel, lambda: LambdaNode] = {
This routine allocates space in the frame extension for the various memory locals.
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
WITH node SELECT FROM
var: Var => WITH var.location SELECT FROM
stack: REF LocationRep.stack => forceExtension ¬ TRUE;
Refers to some offset in the frame extension
ENDCASE;
decl: DeclNode => CountVar[decl.var];
block: BlockNode => {
oldDepth: INT ¬ model.memDepth;
IntCodeUtils.MapNode[node, inner];
model.memDepth ¬ oldDepth;
RETURN [node];
};
enable: EnableNode => IF enable.handle # NIL THEN forceExtension ¬ TRUE;
apply: ApplyNode => IF apply.handler # NIL THEN forceExtension ¬ TRUE;
lambda: LambdaNode => RETURN [node];
ENDCASE;
IntCodeUtils.MapNode[node, inner];
RETURN [node];
};
CountVar: PROC [var: Var] = {
WITH var.location SELECT FROM
local: LocalVarLocation =>
SELECT TRUE FROM
NOT var.flags[notRegister] => {};
Any variable still marked as being possibly in a register is not in the FX.
NOT heapAllocFX AND NOT var.flags[upLevel] => {};
If we are NOT heap allocating the FX, then only upLevel accessed variables are forced into the FX.
ENDCASE => {
This variable must be in the FX.
units: INT ¬ ToUnits[var.bits, bitsPerLocal, logBitsPerLocal];
depth: INT ¬ model.memDepth;
IF local.parent # model.label THEN {
varId: Rope.ROPE = IF local.parent = NIL
THEN "??"
ELSE IO.PutFR1["%g", [integer[local.parent.id]] ];
modelId: Rope.ROPE = IF model.label = NIL
THEN "??"
ELSE IO.PutFR1["%g", [integer[model.label.id]] ];
VarCantHappen[var, IO.PutFR["%g # %g", [rope[varId]], [rope[modelId]] ]];
};
local.id ¬ depth;
IF (model.memDepth ¬ depth + units) > model.memMax THEN
model.memMax ¬ model.memDepth;
};
stack: REF LocationRep.stack => forceExtension ¬ TRUE;
Refers to some offset in the frame extension
ENDCASE => VarCantHappen[var, "location not stack, not local"];
};
forceExtension: BOOL ¬ FALSE;
model.memDepth ¬ model.memMax ¬ firstLocalOffsetLinks;
FOR each: VarList ¬ lambda.formalArgs, each.rest WHILE each # NIL DO
CountVar[each.first];
ENDLOOP;
IntCodeUtils.MapNode[lambda, inner];
IF model.memMax = firstLocalOffsetLinks AND NOT forceExtension
THEN
No memory locals, so no memoryLink needed.
model.memDepth ¬ model.memMax ¬ 0
ELSE {
Make up the memory link & the frame extension
memBits: INT ¬ ToBits[model.memMax, logBitsPerLocal];
fxLink: Var ¬ IntCodeOpt.GenAnonLocal[base, model.label, bitsPerLink];
fxSpace: Var ¬ model.frameExtension ¬ IF heapAllocFX
THEN GenDeref[fxLink, memBits, worst]
ELSE IntCodeOpt.GenAnonLocal[base, model.label, memBits];
fxLink.flags[frequent] ¬ TRUE;
Just an approximation, perhaps we can do better some day
IF model.staticLink # NIL THEN
Make sure that the static link is in the first word of the frame extension. Do NOT use the fxLink variable.
lambda.body ¬ NodeListCons[
GenAssign[
lhs: GenField[fxSpace, staticLinkOffset, bitsPerLink],
rhs: model.staticLink],
lambda.body];
IF heapAllocFX
THEN {
model.memoryLink ¬ fxLink;
AddFrameExtension[base, model, lambda];
}
ELSE {
This is the simplest way to allocate space if the target is kind enough.
IF lambda.body = NIL THEN
There must be something here
lambda.body ¬ NodeListCons[GenComment["entry point"]];
model.entryPoint ¬ lambda.body;
IF NOT useMemoryFromHandlers THEN {
In this case we still need a "register" to point at the frame extension, since that is how we chain from handlers.
model.memoryLink ¬ fxLink;
lambda.body ¬ NodeListCons[
GenDecl[var: fxLink, init: GenAddr[fxSpace]],
lambda.body];
};
lambda.body ¬ NodeListCons[
GenDecl[var: fxSpace, init: NIL],
lambda.body];
fxSpace.flags[notRegister] ¬ FALSE;
Despite the addressing, force this to be "register" based (not really a register)
};
Note: at this point model.frameExtension # NIL indicates that there is a frame extension to hold addressed variables and variables that are too large. However, model.memoryLink # NIL indicates that there is a separate variable to hold onto the address of the extension, something that we only need when (heapAllocFX OR NOT useMemoryFromHandlers).
};
};
AddFrameExtension: PROC [base: BaseModel, model: LambdaModel, lambda: LambdaNode] = {
The idea here is to add the allocation, freeing, and unwind code associated with managing frame extensions. Allocation is handled at the start of the procedure (is the size constant?), then we start an enables node to deal with the UNWIND and the need to free the extension (this is also used to deal with RETURN WITH ERROR). After the enables scope we have an explict unwind before the return. For frames with extensions the return nodes must be transformed into goto nodes which transfer to the extension freeing code.
link: Var ¬ model.memoryLink;
ext: Var ¬ model.frameExtension;
First, generate the code to deal with the frame extension. This includes the allocation, the enables block, and the freeing code. This involves replacing body with:
{decl {var link} {apply {oper mesa alloc} {const word size}}}
{enable {} body}
A NIL handle is used to indicate that the signaller should get rid of the frame extension.
{apply {oper mesa free} {var link}}
bits: INT ¬ ext.bits;
units: INT ¬ ToUnits[bits, minBitsPerArgument, logMinBitsPerArgument];
Note: alloc expects units quantized to min arg size
alloc: Node ¬ GenDecl[link, GenApply[allocOperNode,
NodeListCons[GenConst[units, minBitsPerArgument]]]];
free: Node ¬ GenFree[link];
freeExit: LabelNode ¬ SELECT model.returnBits FROM
0, > maxBitsReturnRecord => GenAnonLabelNode[base, free],
ENDCASE => NIL;
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
WITH node SELECT FROM
return: ReturnNode => {
This simple version ignores conflicts between return values and memory temporaries. We have to fix this sometime!
IF freeExit # NIL THEN
We can go to a common label for empty returns.
RETURN [GenGoTo[freeExit.label]];
IF return.rets = NIL
THEN SIGNAL CantHappen
ELSE {
The cleanup is done by a dummy return value.
clean: NodeList ¬ NodeListCons[free];
NodeListTail[return.rets].rest ¬ clean;
};
RETURN [node];
};
lambda: LambdaNode => RETURN [node];
ENDCASE;
IntCodeUtils.MapNode[node, inner];
RETURN [node];
};
lambda.body ¬ NodeListCons[
alloc,
model.entryPoint ¬ NodeListCons[
z.NEW[NodeRep.enable ¬ [0, enable[
handle: z.NEW[HandlerRep ¬ [context: link, proc: NIL]],
scope: lambda.body]]],
IF freeExit # NIL THEN NodeListCons[freeExit] ELSE NIL
]];
IntCodeUtils.MapNode[lambda, inner];
};
SubstUplevelLocals: PROC [base: BaseModel, model: LambdaModel, lambda: LambdaNode] = {
This routine walks the tree and substitutes memory-based locations for local variables that cannot be in registers and are referenced upLevel. Note that we have to make completely new variables for these transformations to avoid aliasing problems we would get into if we just replaced the locations.
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
WITH node SELECT FROM
var: Var => {
WITH var.location SELECT FROM
local: LocalVarLocation => {
target: Label = local.parent;
SELECT target FROM
model.label => {
This is local to the enclosing lambda, and cannot be transformed yet
};
# NIL => {
This is an up-level reference to a local variable for another lambda.
link: Var ¬ model.staticLink;
mod: LambdaModel ¬ model;
fromCatch: BOOL ¬ mod.isCatch;
DO
parentModel: LambdaModel ¬ mod.parentModel;
SELECT TRUE FROM
target = mod.parentLabel => {
found it!
inRegister: BOOL ¬ NOT var.flags[notRegister];
offset: INT ¬ ToBits[local.id, logBitsPerLocal];
bits: INT ¬ var.bits;
SELECT TRUE FROM
fromCatch AND NOT useMemoryFromHandlers => {
IF inRegister THEN RETURN [GenUpLevel[link, var]];
Direct reference to a register
link ¬ GenUpLevel[link, mod.parentModel.memoryLink];
Must chase the memory link register
};
parentModel # NIL AND parentModel.staticLink = var => {
Can chase through static links even though marked as being in registers
link ¬ mod.staticLink;
offset ¬ staticLinkOffset;
};
inRegister => VarCantHappen[var, "SubstUplevelLocals"];
ENDCASE;
IF link = NIL
THEN VarCantHappen[var, "SubstUplevelLocals"]
ELSE RETURN [GenFieldOfDeref[link, offset, bits]];
};
ENDCASE => {
next: LambdaModel ¬ mod.parentModel;
IF next = NIL OR next.staticLink = NIL THEN {
VarCantHappen[var, "SubstUplevelLocals"];
EXIT;
};
SELECT TRUE FROM
useMemoryFromHandlers OR NOT fromCatch =>
We are chasing through the frame extension
link ¬ GenFieldOfDeref[link, staticLinkOffset, bitsPerLink];
ENDCASE =>
Catch phrase, and can use registers
link ¬ GenUpLevel[link, next.staticLink];
fromCatch ¬ mod.isCatch;
mod ¬ next;
};
ENDLOOP;
};
ENDCASE => VarCantHappen[var, "SubstUplevelLocals"];
RETURN [node];
};
global: GlobalVarLocation => IF NOT IntCodeTarget.directGlobals THEN
IF model.globalLink # NIL THEN {
Substitute a dereference for the global variable
gVar: Var ¬ GenFieldOfDeref[model.globalLink, global.id, var.bits];
gVar.id ¬ var.id;
RETURN [gVar];
};
stack: REF LocationRep.stack => {
Refers to some offset in the frame extension
ext: Var = model.frameExtension;
new: Node ¬ ext;
IF ext = NIL THEN ERROR CantHappen;
new ¬ GenField[new, stack.offset*IntCodeTarget.bitsPerAU, node.bits];
RETURN [new];
};
ENDCASE;
};
lambda: LambdaNode => RETURN [node];
ENDCASE;
IntCodeUtils.MapNode[node, inner];
RETURN [node];
};
IntCodeUtils.MapNode[lambda, inner];
};
SubstLocals: PROC [base: BaseModel, model: LambdaModel, lambda: LambdaNode] = {
This routine walks the tree and substitutes memory-based locations for local variables that cannot be in registers. We can go ahead and clobber the locations, because upLevel uses have already been transformed (it says here).
innerVar: PROC [var: Var] RETURNS [Var] = {
IF var # NIL THEN {
loc: Location ¬ var.location;
WITH loc SELECT FROM
local: LocalVarLocation => {
SELECT TRUE FROM
NOT var.flags[notRegister] => {};
This variable is not in the FX
NOT heapAllocFX AND NOT var.flags[upLevel] => {};
This variable is not in the FX
var = model.frameExtension => {};
Don't try to nest the FX inside itself!
ENDCASE => {
target: Label = local.parent;
SELECT target FROM
model.label => {
This is a local variable in memory.
ext: Var ¬ model.frameExtension;
IF ext = NIL
THEN VarCantHappen[var, "SubstLocals"]
ELSE var.location ¬
GenFieldLocOfVar[ext, ToBits[local.id, logBitsPerLocal]];
};
ENDCASE => SIGNAL CantHappen;
This is an up-level reference to a local variable for another lambda. We should have transformed all of these already!
};
};
field: FieldLocation => {
This stuff is to simplify field descriptions.
base: Node ¬ field.base ¬ inner[field.base];
WITH base SELECT FROM
fv: Var => WITH fv.location SELECT FROM
ff: FieldLocation => {
If a nested field gets this far we collapse the locations
IF ff.cross#field.cross
THEN {
--Lifted from little endian compiler without understanding, ChJ, May 4, 1993
IF fv.bits >= Target.bitsPerWord
THEN {
-- we should test if the basefield.start is a multiple of words LAI
field.start ← field.start + ff.start;
}
ELSE {
field.start ← field.start + Basics32.BITXOR[ff.start + fv.bits-1, Target.bitsPerWord-1]
};
}
ELSE {
field.start ¬ field.start + ff.start;
};
field.base ¬ ff.base;
};
fd: DerefLocation => IF NOT var.flags[addressed] THEN {
addr: Node ¬ StripNilCheck[fd.addr];
IF addr # fd.addr THEN {
There is a NIL check in here that we might discard
IF field.start < firstMappedOffset
THEN fd.addr ¬ addr
ELSE addr ¬ fd.addr;
};
};
ENDCASE;
ENDCASE;
};
indexed: IndexedLocation => {
derefLoc: DerefLocation ¬ NIL;
WITH indexed.base SELECT FROM
var: Var => WITH var.location SELECT FROM
field: FieldLocation => IF field.start < firstMappedOffset THEN
WITH field.base SELECT FROM
fv: Var => WITH fv.location SELECT FROM
deref: DerefLocation => derefLoc ¬ deref;
ENDCASE;
ENDCASE;
deref: DerefLocation => derefLoc ¬ deref;
ENDCASE;
ENDCASE;
IF derefLoc # NIL THEN {
derefAddr: Node ¬ derefLoc.addr;
stripped: Node ¬ StripNilCheck[derefAddr];
index: Node ¬ indexed.index;
IF stripped # derefAddr
AND IntCodeUtils.SideEffectFree[stripped, FALSE]
AND IntCodeUtils.SideEffectFree[index, FALSE] THEN {
At this point we may be performing a gratuitous NIL check
scanner: IntCodeUtils.Visitor = {
IF derefAddr # NIL THEN {
WITH node SELECT FROM
var: Var => WITH var.location SELECT FROM
deref: DerefLocation => {
ds: Node ¬ StripNilCheck[deref.addr];
IF ds = stripped THEN GO TO noMap;
IF IntCodeUtils.SimplyEqual[ds, stripped] THEN GO TO noMap;
};
ENDCASE;
ENDCASE;
IntCodeUtils.MapNode[node, scanner];
EXITS noMap => {derefAddr ¬ NIL};
};
RETURN [node];
};
WITH index SELECT FROM
wc: WordConstNode => {
A constant offset that may be within the unmapped region
x: CARD ¬ IntCodeUtils.WordToCard[wc.word];
sz: CARD ¬ var.bits;
IF x < CARD[firstMappedOffset]/sz THEN derefAddr ¬ NIL;
};
ENDCASE => {
We must scan over the index expression to find other derefs of the expression
[] ¬ scanner[index];
};
IF derefAddr = NIL THEN
We can eliminate the NIL check, since the indexing node will fault first if there really is a problem.
derefLoc.addr ¬ stripped;
};
};
};
ENDCASE => IF loc = NIL THEN VarCantHappen[var, "SubstLocals"];
};
RETURN [var];
};
inner: IntCodeUtils.Visitor = {
[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]
WITH node SELECT FROM
var: Var => {
var ¬ innerVar[var];
MarkUsed[var];
};
decl: DeclNode => {
decl.var ¬ innerVar[decl.var];
decl.init ¬ inner[decl.init];
RETURN [node];
};
assign: AssignNode => {
MarkAssigned[assign.lhs];
};
lambda: LambdaNode => RETURN [node];
apply: ApplyNode =>
IF apply.handler # NIL THEN
IF apply.handler.context = NIL AND model.frameExtension # NIL THEN
apply.handler.context ¬ GenAddr[model.frameExtension];
enable: EnableNode =>
IF enable.handle # NIL THEN
IF enable.handle.context = NIL AND model.frameExtension # NIL THEN
enable.handle.context ¬ GenAddr[model.frameExtension];
ENDCASE;
IntCodeUtils.MapNode[node, inner];
RETURN [node];
};
IntCodeUtils.MapNode[lambda, inner];
Transform all of the local variables that must be in memory
IF model.frameExtension # NIL AND lambda.formalArgs # NIL THEN {
At this point we may have moved some of the arguments into memory. We need to generate assignments from the incoming `registers' into the eventual memory locations.
tail: NodeList ¬ NIL;
head: NodeList ¬ NIL;
lag: NodeList ¬ NIL;
FOR each: VarList ¬ lambda.formalArgs, each.rest WHILE each # NIL DO
var: Var ¬ each.first;
WITH var.location SELECT FROM
local: LocalVarLocation => {};
register: REF LocationRep.register => {};
ENDCASE => {
This variable is in memory (sigh), and must be transformed.
anon: Var ¬ IntCodeOpt.GenAnonLocal[base, model.label, var.bits];
assign: NodeList ¬ NodeListCons[GenDecl[var, anon]];
each.first ¬ anon;
IF tail = NIL THEN head ¬ assign ELSE tail.rest ¬ assign;
tail ¬ assign;
};
ENDLOOP;
IF tail # NIL THEN {
FOR each: NodeList ¬ lambda.body, each.rest WHILE each # NIL DO
IF each = model.entryPoint THEN {
tail.rest ¬ each;
IF lag = NIL THEN SIGNAL CantHappen;
We should not be missing the allocation for the memory!
lag.rest ¬ head;
EXIT;
};
lag ¬ each;
ENDLOOP;
};
};
{
This code deals with inserting the initial subtraction that converts a procedure descriptor into a static link. The idea is that the variable describing the procedure descriptor has been planted in the lambda node, and that variable has a field location if the offset # 0. After all of this is over, only nested procedures that are NOT catch phrases will have lambda.parent # NIL (for later use).
parent: Label ¬ lambda.parent;
descBody: Var ¬ lambda.descBody;
lambda.descBody ¬ NIL;
IF descBody # NIL AND NOT model.isCatch THEN {
staticLink: Var ¬ model.staticLink;
IF staticLink # NIL THEN {
WITH descBody.location SELECT FROM
field: FieldLocation => {
units: INT ¬ field.start / bitsPerAU;
IF field.cross THEN ERROR; -- cross record here??? LAI
IF units # 0 THEN {
There is a static link, which must be adjusted.
args: NodeList ¬ NodeListCons[staticLink,
NodeListCons[GenConst[units, minBitsPerArgument]]];
assign: Node ¬ GenAssign[staticLink, GenApply[subOperNode, args]];
lambda.body ¬ NodeListCons[assign, lambda.body];
};
};
ENDCASE;
};
};
};
};
Big Utilities
TransformFork: PROC [base: BaseModel, model: LambdaModel, apply: ApplyNode]
RETURNS [Node] = {
To allow a runtime routine to deal with constant types for the forked routine we construct an intermediary routine of a constant type (takes an argument that points at the actual proc and arguments, returns one result that points at the actual return values). This is the routine that is fed to the runtime, while the routine that we really wanted to call is called from the specially constructed intermediary.
args: NodeList ¬ apply.args;
procToFork: Node = args.first;
retBits: INT ¬ IntCodeUtils.WordToInt[
NARROW[args.rest.first, IntCodeDefs.WordConstNode].word];
nRets: INT ¬ ToUnits[retBits, minBitsPerArgument, logMinBitsPerArgument];
argsToCallWith: NodeList = args.rest.rest;
argBits: INT ¬ BitsForArgList[argsToCallWith];
nArgs: INT ¬ ToUnits[argBits, minBitsPerArgument, logMinBitsPerArgument];
helperNode: LabelNode ¬ GenAnonLabelNode[base, NIL];
helperLabel: Label ¬ helperNode.label;
helperAddr: Node ¬ GenLabelAddress[helperLabel, FALSE];
tempVar: Var ¬ IntCodeOpt.GenAnonLocal[base, model.label, bitsPerLink];
newArgs: NodeList ¬ NodeListCons[helperAddr, NodeListCons[constant0, args]];
Prefix the arg list with a proc desc body!
[pc, 0, proc, nRets, args...]
bogusBits: INT ¬ BitsForArgList[newArgs];
nBogus: INT ¬ ToUnits[bogusBits, minBitsPerArgument, logMinBitsPerArgument];
rtnVar: Var ¬ IntCodeOpt.GenAnonLocal[base, model.label, Target.bitsPerProcess];
rtnDecl: DeclNode ¬ GenDecl[rtnVar, NIL];
tempDecl: DeclNode ¬ GenDecl[tempVar,
GenApply[allocOperNode, NodeListCons[GenConst[nBogus, minBitsPerArgument]]]];
assignNode: Node ¬ GenAssign[
GenDeref[tempVar, bogusBits, worst],
GenComposite[newArgs, bogusBits]];
apply.args ¬ NodeListCons2[GenAddr[rtnVar], tempVar];
The arguments to the FORK primitive are the address of the rtnVar and the args.
apply.bits ¬ 0;
No bits are returned (but rtnVar is modified).
{
Now generate the bogus procedure that we need to intermediate the forking call
formal: Var ¬ IntCodeOpt.GenAnonLocal[base, helperLabel, bitsPerLink];
actualProc: Var ¬ IntCodeOpt.GenAnonLocal[base, helperLabel, Target.bitsPerProc];
actualProcDecl: Node ¬ GenDecl[actualProc,
GenFieldOfDeref[formal, 2*minBitsPerArgument, Target.bitsPerProc]];
applyNode: ApplyNode ¬ GenApply[actualProc, NIL, retBits];
applyListNode: NodeList ¬ NodeListCons[applyNode];
tail: NodeList ¬ applyListNode;
head: NodeList ¬ NodeListCons[
actualProcDecl,
NodeListCons[GenFree[formal], applyListNode]];
Start list with the proc decl, the formal free, and the actual application.
result: Node ¬ defaultNIL;
newProc: LambdaNode ¬ z.NEW[NodeRep.lambda ¬ [0, lambda[
parent: NIL,
descBody: NIL,
kind: fork,
bitsOut: bitsPerLink,
formalArgs: VarListCons[formal],
body: NIL]]];
IF argBits # 0 THEN {
We also need to declare (and initialize) the actual arguments. To make the C code turn out correctly over various implementations, we have to declare the arguments with the same number and sizes that the actual argument list has.
actualArgs: Var ¬ IntCodeOpt.GenAnonLocal[base, helperLabel, argBits];
actualArgsDecl: Node ¬ GenDecl[
actualArgs,
GenFieldOfDeref[formal, 4*minBitsPerArgument, argBits]];
argsTail: NodeList ¬ NIL;
offset: INT ¬ 0;
FOR each: NodeList ¬ argsToCallWith, each.rest WHILE each # NIL DO
bits: INT ¬ IF each.first = NIL THEN 0 ELSE each.first.bits;
IF bits # 0 THEN {
new: NodeList ¬ NodeListCons[GenField[actualArgs, offset, bits]];
IF argsTail = NIL THEN applyNode.args ¬ new ELSE argsTail.rest ¬ new;
argsTail ¬ new;
};
offset ¬ offset + bits;
ENDLOOP;
head ¬ NodeListCons[actualArgsDecl, head];
};
IF nRets # 0 THEN {
There are some returns to process
retTemp: Var ¬ IntCodeOpt.GenAnonLocal[base, helperLabel, bitsPerLink];
retDecl: DeclNode ¬ GenDecl[retTemp, GenApply[allocOperNode, NodeListCons[GenConst[nRets, minBitsPerArgument]]]];
applyListNode.first ¬ GenAssign[GenDeref[retTemp, retBits, worst], applyNode];
head ¬ NodeListCons[retDecl, head];
result ¬ retTemp;
};
tail ¬ tail.rest ¬ NodeListCons[GenReturn[NodeListCons[result]]];
Finally return the newly allocated return record
head ¬ NodeListCons[
GenComment[IO.PutFR[
"intermediary proc for a FORK, nArgs: %g, nRets: %g",
[integer[nArgs]], [integer[nRets]] ]],
head];
newProc.body ¬ head;
helperLabel.node ¬ newProc;
WITH base.module SELECT FROM
module: ModuleNode =>
Splice the new proc at the tail
NodeListTail[module.procs].rest ¬ NodeListCons[helperNode];
ENDCASE => ERROR;
};
RETURN [GenBlock[
NodeListCons5[rtnDecl, tempDecl, assignNode, apply, rtnVar],
Target.bitsPerProcess]];
};
Little Utilities
CanonReturn: PROC [return: ReturnNode, model: LambdaModel] RETURNS [node: Node] = {
Whenever there is a return node we have to look at the return bits. If we have a long return record then we transform the return node into an assignment followed by a return of nothing.
IF return.rets # NIL THEN {
units: INT ¬ 0;
bits: INT ¬ 0;
FOR each: NodeList ¬ return.rets, each.rest WHILE each # NIL DO
ret: Node ¬ each.first;
IF ret # NIL THEN
units ¬ units + ToUnits[ret.bits, minBitsPerReturn, logMinBitsPerReturn];
ENDLOOP;
bits ¬ ToBits[units, logMinBitsPerReturn];
SELECT TRUE FROM
bits # model.returnBits => SIGNAL CantHappen;
HasLongReturnVar[model, bits] => {
A large return record
rets: NodeList ¬ return.rets;
At this point we have to assign the current rets to the return value. The transformed return does not return anything at all.
IF bits = 0 THEN RETURN [emptyReturn];
RETURN [GenLargeReturn[rets, model.returnVar]];
};
ENDCASE;
};
RETURN [return];
};
HasLongReturnVar: PROC [model: LambdaModel, bits: INT] RETURNS [BOOL] = {
IF model.forceLong OR bits > maxBitsReturnRecord THEN {
A large return record
rtnVar: Var ¬ model.returnVar;
IF bits = 0 THEN bits ¬ bitsPerLink;
IF rtnVar = NIL THEN {
Time to have a new large variable
rtnPtr: Var ¬ GenAnonVar[bitsPerLink];
rtnVar ¬ GenDeref[rtnPtr, bits, worst];
model.returnVar ¬ rtnVar;
};
IF rtnVar.bits # bits THEN SIGNAL CantHappen;
RETURN [TRUE];
};
RETURN [FALSE];
};
GenLargeArgs: PROC
[base: BaseModel, apply: ApplyNode, model: LambdaModel] RETURNS [Node] = {
comp: Node ¬ PadComposite[apply.args, logMinBitsPerArgument];
IF comp # NIL THEN {
var: Var ¬ GenMemTemp[base, comp.bits, model];
var.flags[constant] ¬ TRUE;
apply.args ¬ NodeListCons[GenAddr[var]];
RETURN [GenBlock[bits: apply.bits, nodes: NodeListCons2[GenDecl[var, comp], apply]]];
};
apply.args ¬ NIL;
RETURN [apply];
};
GenLargeRets: PROC
[base: BaseModel, model: LambdaModel, node: Node, bits: INT]
RETURNS [new: Node, addr: Node] = {
WITH node SELECT FROM
apply: ApplyNode => {
temp: Var ¬ GenMemTemp[base, bits, model];
temp.flags[constant] ¬ TRUE;
addr ¬ GenAddr[temp];
apply.bits ¬ 0;
new ¬ GenBlock[bits: bits, nodes: NodeListCons3[GenDecl[temp, NIL], node, temp]];
RETURN;
};
block: BlockNode =>
FOR each: NodeList ¬ block.nodes, each.rest WHILE each # NIL DO
WITH each.first SELECT FROM
apply: ApplyNode => {
[each.first, addr] ¬ GenLargeRets[base, model, apply, bits];
new ¬ node;
RETURN;
};
ENDCASE;
ENDLOOP;
ENDCASE;
SIGNAL CantHappen;
new ¬ node;
addr ¬ NIL;
};
GenAnonLabelNode: PROC [base: BaseModel, node: Node]
RETURNS [LabelNode] = {
next: LogicalId ¬ -LabelsSize[base]-1;
label: Label ¬ z.NEW[LabelRep ¬ [
id: next, node: node, backTarget: FALSE, jumpedTo: FALSE, used: FALSE]];
LabelsStore[base, next, label];
RETURN [z.NEW[NodeRep.label ¬ [0, label[label]]]];
};
GenMemTemp: PROC
[base: BaseModel, bits: INT, model: LambdaModel]
RETURNS [Var] = {
var: Var ¬ IntCodeOpt.GenAnonLocal[base, model.label, bits];
model.memTemps ¬ VarListCons[var, model.memTemps];
RETURN [var];
};
CanSimplyPush: PROC [arg: Node, depth: INT] RETURNS [BOOL] = {
This is very conservative right now. It is meant to return TRUE if the given argument can be pushed onto the stack only using the given number of available stack locations.
IF arg = NIL
THEN RETURN [TRUE]
Special case for things like the default counted zone (not really pushed anyway)
ELSE {
DO
units: INT ¬ ToUnits[arg.bits, bitsPerLocal, logBitsPerLocal];
IF depth+units > lastStack THEN RETURN [FALSE];
WITH arg SELECT FROM
var: Var =>
WITH var.location SELECT FROM
deref: REF LocationRep.deref => {arg ¬ deref.addr; LOOP};
indexed: REF LocationRep.indexed => {
index: Node ¬ indexed.index;
IF CanSimplyPush[index, depth] THEN {
indexUnits: INT ¬ ToUnits[index.bits, bitsPerLocal, logBitsPerLocal];
depth ¬ depth + indexUnits;
arg ¬ indexed.base;
LOOP;
};
};
field: REF LocationRep.field => {arg ¬ field.base; LOOP};
upLevel: REF LocationRep.upLevel => {arg ¬ upLevel.link; LOOP};
composite: REF LocationRep.composite => {
bitDepth: INT ¬ ToBits[depth, logBitsPerLocal];
FOR each: NodeList ¬ composite.parts, each.rest WHILE each # NIL DO
eachBits: INT ¬ each.first.bits;
unitDepth: INT ¬ ToUnits[bitDepth, bitsPerLocal, logBitsPerLocal];
IF NOT CanSimplyPush[each.first, unitDepth] THEN RETURN [FALSE];
IF eachBits > bitsPerLocal THEN {
This is a big (more than 1 local reg) value
eachUnits: INT ¬ ToUnits[eachBits, bitsPerLocal, logBitsPerLocal];
IF unitDepth+eachUnits > lastRegister THEN {
What's worse, the value can't be easily addressed!
alignedBits: INT ¬ ToBits[unitDepth, logBitsPerLocal];
IF alignedBits # bitDepth THEN RETURN [FALSE];
Sigh, the big value isn't aligned, so we can't simply push!
};
};
bitDepth ¬ bitDepth + eachBits;
ENDLOOP;
};
escape: REF LocationRep.escape => RETURN [FALSE];
ENDCASE => RETURN [TRUE];
const: ConstNode => RETURN [TRUE];
oper: OperNode => RETURN [TRUE];
machineCode: MachineCodeNode => RETURN [TRUE];
apply: ApplyNode => {
args: NodeList ¬ apply.args;
IF args # NIL THEN {
WITH apply.proc SELECT FROM
oper: OperNode =>
WITH oper.oper SELECT FROM
mesa: REF OperRep.mesa =>
SELECT mesa.mesa FROM
addr => IF args # NIL THEN {arg ¬ args.first; LOOP};
ENDCASE;
ENDCASE;
ENDCASE;
FOR each: NodeList ¬ args, each.rest WHILE each # NIL DO
first: Node ¬ each.first;
IF first # NIL THEN {
IF NOT CanSimplyPush[first, depth] THEN RETURN [FALSE];
depth ¬ depth + ToUnits[first.bits, bitsPerLocal, logBitsPerLocal];
};
ENDLOOP;
};
arg ¬ apply.proc;
LOOP;
};
ENDCASE;
Whenever we fall through we have a case more complicated than we want to handle.
EXIT;
ENDLOOP;
RETURN [FALSE];
};
};
MarkCatch: PROC [base: BaseModel, node: Node] RETURNS [Node] = {
WITH node SELECT FROM
labelNode: LabelNode => {
lab: Label ¬ labelNode.label;
IF lab # NIL THEN {
handlerModel: LambdaModel ¬ ModelsFetch[base, lab.id];
IF handlerModel = NIL
THEN SIGNAL CantHappen
ELSE handlerModel.isCatch ¬ TRUE;
RETURN [GenGoTo[lab]];
};
};
ENDCASE;
IF node # NIL THEN SIGNAL CantHappen;
RETURN [node];
};
GetHandlerArgs: PROC
[model: LambdaModel] RETURNS [regsPtr, except, rtnPtr, argPtr: Var ¬ NIL] = {
IF model.isCatch THEN {
args: VarList ¬ model.lambda.formalArgs;
rtnVar: Var ¬ model.returnVar;
IF args = NIL THEN GO TO noGood;
IF rtnVar # NIL THEN
WITH rtnVar.location SELECT FROM
deref: DerefLocation => IF deref.addr = args.first THEN {
There is a return var in front of the "normal" arguments
args ¬ args.rest;
IF args = NIL THEN GO TO noGood;
};
ENDCASE => GO TO noGood;
regsPtr ¬ args.first;
IF (args ¬ args.rest) = NIL THEN GO TO noGood;
except ¬ args.first;
IF (args ¬ args.rest) = NIL THEN GO TO noGood;
rtnPtr ¬ args.first;
IF (args ¬ args.rest) = NIL THEN GO TO noGood;
argPtr ¬ args.first;
IF (args ¬ args.rest) # NIL THEN GO TO noGood;
RETURN;
EXITS noGood => {};
};
SIGNAL CantHappen;
};
VarCantHappen: PROC [var: Var, msg: Rope.ROPE ¬ NIL] = {
IF var # NIL THEN
WITH ProcessProps.GetProp[$StdOut] SELECT FROM
st: IO.STREAM => {
IO.PutF1[st, "\nBadVar[id: %g] ", [integer[var.id]] ];
IF msg # NIL THEN IO.PutF1[st, "(%g) ", [rope[msg]] ];
};
ENDCASE;
SIGNAL CantHappen;
};
END.