<<>> <> <> <> <> <> 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; <> smallExceptions: BOOL Ź FALSE; < use small exception raising>> < use "normal" exception raising>> <<>> simplifyValueBlocks: BOOL Ź TRUE; < perform some simplifications of value-returning blocks>> < no transformation of value-returning blocks>> <<>> useMemoryFromHandlers: BOOL = TRUE; < uplevel use from catch phrase handlers force the target variable into memory>> < uplevel use from catch phrase handlers can use registers>> <<>> heapAllocFX: BOOL = FALSE; < use heap allocation for frame extensions>> < declare the frame extension as a simple (addressed) variable>> <<>> cleanupCode: BOOL Ź TRUE; < call CleanupLambda to remove junk>> < don't call CleanupLambda>> <<>> <> indexedImpliesAddressedLimit: INT Ź LAST[INT]; <> localVarRegisterLimit: INT Ź LAST[INT]; <> firstMappedOffset: INT Ź 8*LONG[1024]*IntCodeTarget.bitsPerAU; <> worst: NAT = Target.Alignments[Target.AlignmentIndex.LAST]; <<>> <> staticLinkOffset: NAT = 0; <> firstLocalOffsetLinks: NAT = 4; <> firstLocalOffset: NAT = firstLocalOffsetLinks*bitsPerLink; <> <> z: ZONE Ź IntCodeUtils.zone; <> rewriteEnables: PROC [node: Node, genTemp: GenTemp, genLabel: GenLabel] RETURNS [Node] Ź NIL; <> Duplicate: PUBLIC SIGNAL = CODE; <> CantHappen: SIGNAL = CODE; <> NotYetImplemented: SIGNAL = CODE; <> <> DoModule: PUBLIC PROC [module: Node, switches: Switches] RETURNS [BaseModel] = { ENABLE CantHappen => IF switches['i] THEN { <> 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]; <> CanonVars[base, module, NIL]; <> <<[[ This pass sets the upLevel and addressed (=> notRegister) variable flags ]]>> <> <<[[ 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 <> FOR m: LambdaModel Ź base.first, m.next WHILE m # NIL DO IntCodeOpt.SimplifyValueBlocks[base, m, m.lambda]; ENDLOOP; IF lastStack # 0 THEN <> FOR m: LambdaModel Ź base.first, m.next WHILE m # NIL DO CheckStackDepth[base, m, m.lambda]; ENDLOOP; <> FOR m: LambdaModel Ź base.first, m.next WHILE m # NIL DO AllocMemLocals[base, m, m.lambda]; ENDLOOP; <> FOR m: LambdaModel Ź base.first, m.next WHILE m # NIL DO SubstUplevelLocals[base, m, m.lambda]; ENDLOOP; <> <<[[ 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; <> <<[[ 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; <> 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]; }; <> 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 map>> var: Var => WITH var.location SELECT FROM local: LocalVarLocation => RETURN [node]; < no map>> global: GlobalVarLocation => RETURN [node]; < 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]]; <> 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; <> 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]; <> IF model.forceLong OR model.argumentBits > maxBitsArgumentRecord THEN { <> 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 <> 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 { <> FOR each: VarList Ź lambda.formalArgs, each.rest WHILE each # NIL DO AddVar[each.first, model]; ENDLOOP; }; <> IntCodeUtils.MapNodeList[lambda.body, inner]; <> IF model.returnVar # NIL OR HasLongReturnVar[model, model.returnBits] THEN <> 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 => { <> 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]; <> WITH apply.proc SELECT FROM mc: MachineCodeNode => RETURN [node]; <> 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 { <> 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_Error0"; 1 => name Ź "XR_Error1"; 2 => name Ź "XR_Error2"; 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 => {}; <> <> retBits = 0 => <> rest Ź NodeListCons[defaultNIL, rest]; ENDCASE => { <> 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 => { <> rtnBits: INT Ź node.bits; node.bits Ź bitsPerLink; <> 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]]; <> tail: NodeList Ź head; tail Ź tail.rest Ź NodeListCons[GenDecl[rtnPtr, node]]; <> tail Ź tail.rest Ź NodeListCons[GenAssign[result, rtnSrc]]; <> tail Ź tail.rest Ź NodeListCons[GenFree[rtnPtr]]; <> tail Ź tail.rest Ź NodeListCons[result]; <> RETURN [GenBlock[head, rtnBits]]; }; RETURN [GenAssign[GenDummy[bitsPerLink], node]]; <> }; resume, reject, unwind => { <> [] Ź HasLongReturnVar[model, minBitsPerArgument*2]; GO TO checkArgs; }; startGlobal => { <> 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 <> node Ź GenLargeArgs[base, apply, model]; <> IF useLargeRets THEN { <> 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 => { <> 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 <> 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 <> 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 => { <> canon: Var Ź DeclsFetch[base, var.id]; IF canon # NIL THEN { WITH canon.location SELECT FROM local: LocalVarLocation => { <> 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 { <> IF model # NIL AND model.globalLink = NIL THEN <> model.globalLink Ź IntCodeOpt.GenAnonLocal[base, model.label, bitsPerLink]; }; ENDCASE; var Ź canon; }; WITH var.location SELECT FROM local: LocalVarLocation => { <> IF var.bits > localVarRegisterLimit THEN <> MarkAddressed[var]; }; indexed: IndexedLocation => { base: Node Ź indexed.base Ź inner[indexed.base]; index: Node Ź indexed.index Ź inner[indexed.index]; WITH index SELECT FROM const: WordConstNode => { <> val: INT Ź IntCodeUtils.WordToInt[const.word]; var.location Ź GenFieldLoc[base, val*var.bits]; }; ENDCASE => IF base # NIL AND base.bits > indexedImpliesAddressedLimit THEN <> MarkAddressed[base]; }; ENDCASE => IntCodeUtils.MapNode[var, inner]; RETURN [var]; }; decl: DeclNode => { var: Var Ź DeclsFetch[base, decl.var.id]; <> decl.init Ź inner[decl.init]; <> 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]; <> 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 => { <> 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 <> RETURN [inner[list.first]]; 2 => IF decl0 # NIL AND decl0.var = var1 THEN <> RETURN [inner[decl0.init]]; 3 => IF decl0 # NIL AND decl0.var = var2 AND decl0.init = NIL AND assign1 # NIL AND assign1.lhs = var2 THEN <> IF NOT NodeContains[assign1.rhs, var2] THEN <> 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 <> DetermineNesting[base, model]; CanonVars[base, lambda, model]; SELECT TRUE FROM model.isCatch => { <> model.staticLink Ź GetHandlerArgs[model].regsPtr; model.returnBits Ź 2*bitsPerLink; }; lambda.parent # NIL => { <> 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 { <> 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; <> IF node = NIL OR CanSimplyPush[node, depth] THEN RETURN [node]; <> WITH node SELECT FROM decl: DeclNode => { <> 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 { <> var.flags[notRegister] Ź TRUE; } ELSE { <> depth Ź next; IF depth > max THEN max Ź depth; }; }; ENDCASE; decl.init Ź inner[decl.init]; RETURN [node]; }; apply: ApplyNode => { <> 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 { <> new.rest Ź NodeListCons[apply]; node Ź GenBlock[new, apply.bits]; } ELSE { <> new.rest Ź tail.rest; tail.rest Ź new; }; tail Ź new; RETURN [var]; }; IF NOT CanSimplyPush[apply.proc, depth+argsUnits] THEN <> apply.proc Ź PutArgInMemory[apply.proc]; <> SELECT TRUE FROM args = NIL => GO TO commonExit; args.rest = NIL => { <> 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; <> mesa: REF OperRep.mesa => SELECT mesa.mesa FROM addr, equal, notEqual => GO TO useAddrs; ENDCASE; ENDCASE; <> 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] => <> each.first Ź inner[arg]; ENDCASE => <> each.first Ź PutArgInMemory[arg]; ENDLOOP; GO TO commonExit; EXITS useProcApply => {}; useAddrs => { <> localsPerLink: NAT = bitsPerLink/bitsPerLocal; <> 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 => { <> depth Ź next; each.first Ź inner[arg]; }; CanSimplyPush[arg, depth] => <> each.first Ź inner[arg]; ENDCASE => <> each.first Ź PutArgInMemory[arg]; ENDLOOP; GO TO commonExit; EXITS commonExit => { depth Ź oldDepth; RETURN [node]; }; }; lambda: LambdaNode => RETURN [node]; source: SourceNode => { <> 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] = { <> <> 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 { <> notRegister: BOOL Ź var.flags[notRegister]; FOR mod: LambdaModel Ź model, mod.parentModel DO SELECT TRUE FROM mod = NIL => { <> VarCantHappen[var, "ref to non-enclosing lambda"]; EXIT}; mod.label = target => { var.flags[notRegister] Ź notRegister; RETURN [CopyVar[var]]; }; mod.staticLink = NIL => { <> VarCantHappen[var, "can't find static link"]; EXIT}; ENDCASE; IF useMemoryFromHandlers OR NOT mod.isCatch THEN <> 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 { <> nVar: Var Ź CopyVar[var]; head: NodeList Ź NIL; tail: NodeList Ź NIL; nLoc: REF LocationRep.composite Ź z.NEW[LocationRep.composite Ź [composite[NIL]]]; <> 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; <> IF tail = NIL THEN tail Ź nLoc.parts Ź NodeListCons[new] ELSE tail Ź tail.rest Ź NodeListCons[new]; <> 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 => <> node Ź CanonReturn[return, model]; apply: ApplyNode => { <> 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 => { <> rets: NodeList Ź NodeListCons[constant0, NodeListCons[constant0]]; node Ź GenReturn[rets]; GO TO fixReturn; }; resume => { <> <> 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 => { <> 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] = { <> 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; <> 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] => {}; <> NOT heapAllocFX AND NOT var.flags[upLevel] => {}; <> ENDCASE => { <> 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; <> 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 <> model.memDepth Ź model.memMax Ź 0 ELSE { <> 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; <> IF model.staticLink # NIL THEN <> 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 { <> IF lambda.body = NIL THEN <> lambda.body Ź NodeListCons[GenComment["entry point"]]; model.entryPoint Ź lambda.body; IF NOT useMemoryFromHandlers THEN { <> 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; <> }; <> }; }; AddFrameExtension: PROC [base: BaseModel, model: LambdaModel, lambda: LambdaNode] = { <> link: Var Ź model.memoryLink; ext: Var Ź model.frameExtension; <> <<{decl {var link} {apply {oper mesa alloc} {const word size}}}>> <<{enable {} body}>> <> <<{apply {oper mesa free} {var link}}>> bits: INT Ź ext.bits; units: INT Ź ToUnits[bits, minBitsPerArgument, logMinBitsPerArgument]; <> 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 => { <> IF freeExit # NIL THEN <> RETURN [GenGoTo[freeExit.label]]; IF return.rets = NIL THEN SIGNAL CantHappen ELSE { <> 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] = { <> 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 => { <> }; # NIL => { <> link: Var Ź model.staticLink; mod: LambdaModel Ź model; fromCatch: BOOL Ź mod.isCatch; DO parentModel: LambdaModel Ź mod.parentModel; SELECT TRUE FROM target = mod.parentLabel => { <> 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]]; <> link Ź GenUpLevel[link, mod.parentModel.memoryLink]; <> }; parentModel # NIL AND parentModel.staticLink = var => { <> 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 => <> link Ź GenFieldOfDeref[link, staticLinkOffset, bitsPerLink]; ENDCASE => <> 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 { <> gVar: Var Ź GenFieldOfDeref[model.globalLink, global.id, var.bits]; gVar.id Ź var.id; RETURN [gVar]; }; stack: REF LocationRep.stack => { <> 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] = { <> 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] => {}; <> NOT heapAllocFX AND NOT var.flags[upLevel] => {}; <> var = model.frameExtension => {}; <> ENDCASE => { target: Label = local.parent; SELECT target FROM model.label => { <> ext: Var Ź model.frameExtension; IF ext = NIL THEN VarCantHappen[var, "SubstLocals"] ELSE var.location Ź GenFieldLocOfVar[ext, ToBits[local.id, logBitsPerLocal]]; }; ENDCASE => SIGNAL CantHappen; <> }; }; field: FieldLocation => { <> base: Node Ź field.base Ź inner[field.base]; WITH base SELECT FROM fv: Var => WITH fv.location SELECT FROM ff: FieldLocation => { <> 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 { <> 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 { <> 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 => { <> x: CARD Ź IntCodeUtils.WordToCard[wc.word]; sz: CARD Ź var.bits; IF x < CARD[firstMappedOffset]/sz THEN derefAddr Ź NIL; }; ENDCASE => { <> [] Ź scanner[index]; }; IF derefAddr = NIL THEN <> 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]; <> IF model.frameExtension # NIL AND lambda.formalArgs # NIL THEN { <> 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 => { <> 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; <> lag.rest Ź head; EXIT; }; lag Ź each; ENDLOOP; }; }; { <> 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 { <> args: NodeList Ź NodeListCons[staticLink, NodeListCons[GenConst[units, minBitsPerArgument]]]; assign: Node Ź GenAssign[staticLink, GenApply[subOperNode, args]]; lambda.body Ź NodeListCons[assign, lambda.body]; }; }; ENDCASE; }; }; }; }; <> TransformFork: PROC [base: BaseModel, model: LambdaModel, apply: ApplyNode] RETURNS [Node] = { <> 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]]; <> <<[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]; <> apply.bits Ź 0; <> { <> 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]]; <> 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 { <> 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 { <> 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]]]; <> 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 => <> NodeListTail[module.procs].rest Ź NodeListCons[helperNode]; ENDCASE => ERROR; }; RETURN [GenBlock[ NodeListCons5[rtnDecl, tempDecl, assignNode, apply, rtnVar], Target.bitsPerProcess]]; }; <> CanonReturn: PROC [return: ReturnNode, model: LambdaModel] RETURNS [node: Node] = { <> 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] => { <> rets: NodeList Ź return.rets; <> 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 { <> rtnVar: Var Ź model.returnVar; IF bits = 0 THEN bits Ź bitsPerLink; IF rtnVar = NIL THEN { <> 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] = { <> IF arg = NIL THEN RETURN [TRUE] <> 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 { <> eachUnits: INT Ź ToUnits[eachBits, bitsPerLocal, logBitsPerLocal]; IF unitDepth+eachUnits > lastRegister THEN { <> alignedBits: INT Ź ToBits[unitDepth, logBitsPerLocal]; IF alignedBits # bitDepth THEN RETURN [FALSE]; <> }; }; 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; <> 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 { <> 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.