<<>> <> <> <> <<>> DIRECTORY IntCodeDefs, IntCodeEnables, IntCodeStuff, <> IntCodeUtils; IntCodeEnablesImpl: CEDAR PROGRAM IMPORTS IntCodeStuff, <> IntCodeUtils EXPORTS IntCodeEnables = BEGIN OPEN IntCodeDefs, IntCodeEnables, IntCodeStuff, <> IntCodeUtils; <> bitsPerWord: NAT = 32; procDescBodyBits: NAT = 2*bitsPerWord; LabelsList: TYPE = REF LabelsListRep; LabelsListRep: TYPE = RECORD [ first: LabelEntry, rest: LabelsList ]; LabelEntry: TYPE = REF LabelEntryRep; LabelEntryRep: TYPE = RECORD [ label: Label, <> parent: Label, <> code: INT <> ]; LambdaState: TYPE = {none, normal, artificial, handler}; <> RewriteEnables: PUBLIC PROC [node: Node, genTemp: GenTemp, genLabel: GenLabel] RETURNS [Node] = { VisitScope: PROC [label: Label, scope: NodeList, newState: LambdaState] = { oldState: LambdaState = state; oldParentLabel: Label = parentLabel; state Ź newState; WITH label.node SELECT FROM lambda: LambdaNode => { IF lambda.parent = NIL THEN lambda.parent Ź parentLabel; parentLabel Ź label; IF lambda.formalArgs # NIL THEN IntCodeUtils.MapVarList[lambda.formalArgs, FixVarLocation]; }; ENDCASE => SIGNAL CantHappen; IntCodeUtils.MapNodeList[scope, DefineLabels]; IntCodeUtils.MapNodeList[scope, AssignCodes]; state Ź oldState; parentLabel Ź oldParentLabel; }; DefineLabels: IntCodeUtils.Visitor = { <<[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]>> WITH node SELECT FROM decl: DeclNode => <> [] Ź FixVarLocation[decl.var]; labNode: LabelNode => { label: Label = labNode.label; WITH label.node SELECT FROM lambda: LambdaNode => RETURN [node]; <> <> ENDCASE => [] Ź DefineEntry[label, 0, parentLabel]; <> }; lambda: REF NodeRep.lambda => ERROR CantHappen; apply: REF NodeRep.apply => { WITH apply.proc SELECT FROM opNode: REF NodeRep.oper => WITH opNode.oper SELECT FROM mesa: REF OperRep.mesa => SELECT mesa.mesa FROM unwind => { label: Label Ź PeelLabel[apply.args.first]; IF label = NIL THEN ERROR CantHappen; RETURN [z.NEW[NodeRep.goto Ź [0, goto[label]]]]; }; ENDCASE; ENDCASE; ENDCASE; apply.proc Ź DefineLabels[apply.proc]; IntCodeUtils.MapNodeList[apply.args, DefineLabels]; RETURN [node]; }; enable: REF NodeRep.enable => { scope: NodeList = enable.scope; IF scope = NIL THEN RETURN [NIL]; RETURN [node]; <> }; ENDCASE; IntCodeUtils.MapNode[node, DefineLabels]; RETURN [node]; }; FixVarLocation: IntCodeUtils.Visitor = { WITH node SELECT FROM var: Var => WITH var.location SELECT FROM local: REF LocationRep.localVar => local.parent Ź parentLabel; ENDCASE => IF var.location = NIL THEN { loc: Location = z.NEW[LocationRep.localVar Ź [localVar[0, parentLabel]]]; var.location Ź loc; }; ENDCASE; RETURN [node]; }; AssignCodes: IntCodeUtils.Visitor = { <<[node: IntCodeDefs.Node] RETURNS [IntCodeDefs.Node]>> <> WITH node SELECT FROM decl: REF NodeRep.decl => { <> var: Var = decl.var; WITH var.location SELECT FROM local: REF LocationRep.localVar => { IF var.flags[upLevel] AND state = artificial THEN { <> init: Node = decl.init; IF init # NIL THEN node Ź GenAssign[var, AssignCodes[init]] ELSE node Ź NIL; promotedVars Ź VarListCons[var, promotedVars]; RETURN [node]; }; }; ENDCASE; [] Ź FixVarLocation[var]; }; goto: REF NodeRep.goto => { label: Label = goto.dest; IF definedTab = NIL THEN SIGNAL CantHappen; WITH IntCodeUtils.Fetch[definedTab, label.id] SELECT FROM entry: LabelEntry => { IF entry.parent # parentLabel THEN { <> rets: NodeList Ź NIL; IF entry.code = 0 THEN { <> labelCode Ź labelCode + 1; entry.code Ź labelCode; }; rets Ź NodeListCons[GenConst[entry.code, bitsPerWord]]; SELECT state FROM artificial => {}; <> handler => <> rets Ź NodeListCons[upLevelCode, rets]; ENDCASE => SIGNAL CantHappen; upLevelList Ź InsertEntry[upLevelList, entry]; RETURN [GenReturn[rets]]; }; }; ENDCASE => SIGNAL CantHappen; }; return: REF NodeRep.return => SELECT state FROM normal => {}; <> artificial => { <> head: VarList Ź returnVars; retNode: Node Ź GenReturn[NodeListCons[returnCode]]; IF returnLabelNode = NIL THEN { <> labelNode: LabelNode = genLabel[NIL]; label: Label = labelNode.label; entry: LabelEntry = DefineEntry[label, retLabelCounter, lambdaLabel]; upLevelList Ź InsertEntry[upLevelList, entry]; returnLabelNode Ź labelNode; IF head = NIL THEN { <> tail: VarList Ź NIL; FOR each: NodeList Ź return.rets, each.rest WHILE each # NIL DO <> var: Var Ź genTemp[lambdaLabel, each.first.bits]; new: VarList Ź VarListCons[var]; IF tail = NIL THEN head Ź new ELSE tail.rest Ź new; tail Ź new; ENDLOOP; returnVars Ź head; }; }; IF return.rets # NIL THEN { <> retList: NodeList Ź NodeListCons[retNode]; assigns: NodeList Ź NIL; IF head = NIL THEN SIGNAL CantHappen; IntCodeUtils.MapNodeList[return.rets, AssignCodes]; <> <> FOR each: NodeList Ź return.rets, each.rest WHILE each # NIL DO <> val: Node = each.first; var: Var Ź NIL; IF head = NIL THEN SIGNAL CantHappen; var Ź head.first; IF val.bits # var.bits THEN SIGNAL CantHappen; assigns Ź NodeListCons[GenAssign[var, val, 0], assigns]; head Ź head.rest; ENDLOOP; IF head # NIL THEN SIGNAL CantHappen; <> WHILE assigns # NIL DO rest: NodeList = assigns.rest; assigns.rest Ź retList; retList Ź assigns; assigns Ź rest; ENDLOOP; <

> retNode Ź GenBlock[retList, 0]; }; RETURN [retNode]; }; ENDCASE => SIGNAL CantHappen; labNode: LabelNode => { label: Label = labNode.label; WITH label.node SELECT FROM lambda: REF NodeRep.lambda => { body: NodeList Ź lambda.body; oldLambdaLabel: Label = lambdaLabel; oldReturnLabelNode: LabelNode = returnLabelNode; oldReturnVars: VarList = returnVars; returnLabelNode Ź NIL; returnVars Ź NIL; lambdaLabel Ź label; VisitScope[label, body, normal]; IF returnLabelNode # NIL THEN { <> retNodeList: NodeList Ź NIL; tail: NodeList Ź NIL; FOR each: VarList Ź returnVars, each.rest WHILE each # NIL DO var: Var = each.first; new: NodeList Ź NodeListCons[var]; IF tail = NIL THEN retNodeList Ź new ELSE tail.rest Ź new; tail Ź new; body Ź NodeListCons[GenDecl[var, NIL], body]; <> ENDLOOP; tail Ź NodeListTail[body]; tail.rest Ź NodeListCons2[returnLabelNode, GenReturn[retNodeList]]; lambda.body Ź body; }; returnLabelNode Ź oldReturnLabelNode; returnVars Ź oldReturnVars; lambdaLabel Ź oldLambdaLabel; RETURN [node]; }; ENDCASE; }; apply: REF NodeRep.apply => IF apply.handler # NIL THEN { <> bits: INT = apply.bits; handler: Handler = apply.handler; declHead: NodeList Ź NIL; declTail: NodeList Ź NIL; apply.handler Ź NIL; FOR each: NodeList Ź apply.args, each.rest WHILE each # NIL DO arg: Node Ź each.first; IF NOT IntCodeUtils.SideEffectFree[arg, TRUE] THEN { temp: Var = genTemp[parentLabel, arg.bits]; new: NodeList Ź NodeListCons[GenDecl[temp, arg]]; IF declTail = NIL THEN declHead Ź new ELSE declTail.rest Ź new; declTail Ź new; each.first Ź temp; }; ENDLOOP; IF NOT IntCodeUtils.SideEffectFree[apply.proc, TRUE] THEN { temp: Var = genTemp[parentLabel, apply.proc.bits]; new: NodeList Ź NodeListCons[GenDecl[temp, apply.proc]]; IF declTail = NIL THEN declHead Ź new ELSE declTail.rest Ź new; declTail Ź new; apply.proc Ź temp; }; node Ź GenApply[apply.proc, apply.args, bits]; <> IF bits = 0 THEN node Ź TransformHandler[NodeListCons[node], handler, mostRecentSource] < No temporary needed>> ELSE { <> temp: Var = genTemp[parentLabel, bits]; scope: NodeList = NodeListCons[GenAssign[temp, node]]; node Ź TransformHandler[scope, handler, mostRecentSource]; node Ź GenBlock[NodeListCons3[GenDecl[temp, NIL], node, temp], bits]; }; IF declHead # NIL THEN { <> declTail.rest Ź NodeListCons[node]; node Ź GenBlock[declHead, bits]; }; RETURN [node]; }; enable: REF NodeRep.enable => { handler: Handler = enable.handle; node Ź TransformHandler[enable.scope, enable.handle, NIL]; RETURN [node]; }; source: REF NodeRep.source => { oldRecentSource: Node Ź mostRecentSource; mostRecentSource Ź source; FOR each: NodeList Ź source.nodes, each.rest WHILE each # NIL DO each.first Ź AssignCodes[each.first]; ENDLOOP; mostRecentSource Ź oldRecentSource; RETURN [node]; }; module: REF NodeRep.module => { head: NodeList Ź NIL; tail: NodeList Ź NIL; MarkUpLevel[node]; <> FOR each: NodeList Ź module.procs, each.rest WHILE each # NIL DO new: NodeList Ź NodeListCons[AssignCodes[each.first]]; IF tail = NIL THEN head Ź new ELSE tail.rest Ź new; tail Ź new; WHILE innerBlockList # NIL DO next: NodeList Ź innerBlockList.rest; tail Ź tail.rest Ź innerBlockList; innerBlockList Ź next; ENDLOOP; ENDLOOP; WHILE handlersList # NIL DO next: NodeList Ź handlersList.rest; tail Ź tail.rest Ź handlersList; handlersList Ź next; ENDLOOP; module.procs Ź head; RETURN [node]; }; ENDCASE; IntCodeUtils.MapNode[node, AssignCodes]; RETURN [node]; }; TransformHandler: PROC [scope: NodeList, handler: Handler, recentSource: Node] RETURNS [Node] = { <> handleContext: Node = handler.context; handleProc: Node = handler.proc; scopeLambda: LambdaNode = z.NEW[NodeRep.lambda Ź [0, lambda[ parent: parentLabel, descBody: NIL, kind: scope, bitsOut: bitsPerWord, formalArgs: NIL, body: scope]]]; applyNode: ApplyNode = GenApply[ xrEnable, NIL, bitsPerWord]; procNode: LabelNode = genLabel[scopeLambda]; scopeLabel: Label = procNode.label; retList: NodeList Ź NIL; assignNode: Node Ź NIL; oldUpLevelList: LabelsList Ź upLevelList; oldPromotedVars: VarList Ź promotedVars; IF state = normal THEN upLevelList Ź NIL; promotedVars Ź NIL; <> VisitScope[scopeLabel, scope, artificial]; scope Ź NodeListTail[scope]; scope.rest Ź NodeListCons[GenReturn[NodeListCons[zeroCode]]]; <> WITH recentSource SELECT FROM rs: REF NodeRep.source => { <> newSource: Node Ź z.NEW[NodeRep.source Ź [0, source[rs.source, scopeLambda.body]]]; scopeLambda.body Ź NodeListCons[newSource]; }; ENDCASE; <<>> <> WITH handleProc SELECT FROM labNode: LabelNode => { label: Label = labNode.label; loc: Location Ź z.NEW[LocationRep.stack Ź [stack[0]]]; <> applyNode.args Ź NodeListCons3[ GenLabelAddress[scopeLabel, FALSE], GenLabelAddress[label, FALSE], GenAddr[GenAnonVar[0, loc]]]; IF label # NIL THEN WITH label.node SELECT FROM lambda: REF NodeRep.lambda => { lambda.parent Ź parentLabel; lambda.bitsOut Ź 2*bitsPerWord; VisitScope[label, lambda.body, handler]; }; ENDCASE => SIGNAL CantHappen; }; ENDCASE => SIGNAL CantHappen; IF upLevelList = NIL THEN { <> temp: Var Ź GenDummy[bitsPerWord]; assignNode Ź GenAssign[temp, applyNode]; } ELSE { <> temp: Var Ź genTemp[parentLabel, bitsPerWord]; cases: CaseList Ź NIL; cond: Node = CondFromLabelsList[temp, upLevelList]; IF cond # NIL THEN retList Ź NodeListCons[cond, retList]; assignNode Ź GenDecl[temp, applyNode]; FOR each: LabelsList Ź upLevelList, each.rest WHILE each # NIL DO <> entry: LabelEntry = each.first; IF entry.parent # parentLabel THEN oldUpLevelList Ź InsertEntry[oldUpLevelList, entry]; ENDLOOP; }; retList Ź NodeListCons[assignNode, retList]; handlersList Ź NodeListCons[handleProc, handlersList]; innerBlockList Ź NodeListCons[procNode, innerBlockList]; upLevelList Ź oldUpLevelList; IF promotedVars # NIL AND state # artificial THEN { <> FOR each: VarList Ź promotedVars, each.rest WHILE each # NIL DO var: Var Ź NARROW[FixVarLocation[each.first]]; retList Ź NodeListCons[GenDecl[var, NIL], retList]; ENDLOOP; promotedVars Ź NIL; }; FOR each: VarList Ź promotedVars, each.rest WHILE each # NIL DO oldPromotedVars Ź VarListCons[each.first, oldPromotedVars]; ENDLOOP; promotedVars Ź oldPromotedVars; RETURN [GenBlock[retList]]; }; DefineEntry: PROC [label: Label, code: INT, parentLabel: Label] RETURNS [LabelEntry] = { new: LabelEntry = z.NEW[LabelEntryRep Ź [label, parentLabel, code]]; IF definedTab = NIL THEN definedTab Ź IntCodeUtils.NewIdTab[]; IF parentLabel = NIL THEN SIGNAL CantHappen; IF IntCodeUtils.Store[definedTab, label.id, new] # NIL THEN SIGNAL CantHappen; RETURN [new]; }; CondFromLabelsList: PROC [temp: Var, list: LabelsList] RETURNS [Node] = { cases: CaseList Ź NIL; WHILE list # NIL DO entry: LabelEntry = list.first; code: INTEGER = entry.code; tests: NodeList = NodeListCons[GenEqTest[temp, entry.code]]; IF code > 0 THEN { body: Node Ź NIL; IF entry.parent = parentLabel THEN <> body Ź GenGoTo[entry.label] ELSE { <> retList: NodeList Ź NodeListCons[GenConst[code, bitsPerWord]]; SELECT state FROM artificial => {}; handler => retList Ź NodeListCons[upLevelCode, retList]; ENDCASE => GO TO vanishedLabel; body Ź GenReturn[retList]; }; cases Ź z.NEW[CaseListRep Ź [tests: tests, body: body, rest: cases]]; EXITS vanishedLabel => { <> }; }; list Ź list.rest; ENDLOOP; IF cases = NIL THEN RETURN [NIL]; RETURN [z.NEW[NodeRep.cond Ź [0, cond[cases]]]]; }; MakeConst: PROC [const: INT] RETURNS [Node] = { SELECT const FROM 0 => RETURN [zeroCode]; 1 => RETURN [oneCode]; 2 => RETURN [twoCode]; 3 => RETURN [threeCode]; ENDCASE => RETURN [GenConst[const, bitsPerWord]]; }; <> definedTab: IntCodeUtils.IdTab Ź NIL; parentLabel: Label Ź NIL; labelCode: INT Ź initLabelCounter; initLabelCounter: NAT = 1; retLabelCounter: NAT = 1; <> <<< 0 => illegal>> <<0 => normal termination, flow through>> <<1 => return temp rets>> < go to label coded>> upLevelList: LabelsList Ź NIL; state: LambdaState Ź none; zeroCode: Node = GenConst[0, bitsPerWord]; oneCode: Node = GenConst[1, bitsPerWord]; twoCode: Node = GenConst[2, bitsPerWord]; threeCode: Node = GenConst[3, bitsPerWord]; returnCode: Node = MakeConst[retLabelCounter]; upLevelCode: Node = MakeConst[2]; lambdaLabel: Label Ź NIL; returnLabelNode: LabelNode Ź NIL; returnVars: VarList Ź NIL; xrEnable: Node = z.NEW[NodeRep.machineCode Ź [0, machineCode["XR_Enable"]]]; innerBlockList: NodeList Ź NIL; handlersList: NodeList Ź NIL; promotedVars: VarList Ź NIL; mostRecentSource: Node Ź NIL; node Ź AssignCodes[node]; RETURN [node]; }; <> GenEqTest: PROC [temp: Var, code: INT] RETURNS [Node] = { class: IntCodeDefs.ArithClass = [unsigned, FALSE, bitsPerWord]; eqTest: Node = GenOperNode[[compare[class: class, sense: eq]]]; RETURN [GenApply[eqTest, NodeListCons2[temp, GenConst[code, bitsPerWord]], 1]]; }; InsertEntry: PROC [old: LabelsList, entry: LabelEntry] RETURNS [LabelsList] = { <> lag: LabelsList Ź NIL; code: INT = entry.code; IF code <= 0 THEN SIGNAL CantHappen; FOR each: LabelsList Ź old, each.rest WHILE each # NIL DO ee: LabelEntry = each.first; SELECT ee.code FROM > code => EXIT; = code => { IF entry.label.id # ee.label.id THEN SIGNAL CantHappen; GO TO done; }; ENDCASE; lag Ź each; ENDLOOP; { new: LabelsList Ź z.NEW[LabelsListRep Ź [first: entry, rest: NIL]]; IF lag = NIL THEN {new.rest Ź old; old Ź new} ELSE {new.rest Ź lag.rest; lag.rest Ź new}; }; GO TO done; EXITS done => RETURN [old]; }; PeelLabel: PROC [node: Node] RETURNS [Label] = { WITH node SELECT FROM opNode: REF NodeRep.oper => WITH opNode.oper SELECT FROM op: REF OperRep.code => RETURN [op.label]; ENDCASE; ENDCASE; RETURN [NIL]; }; MarkUpLevel: PROC [node: Node] = { innerMark: IntCodeUtils.Visitor = { WITH node SELECT FROM var: Var => WITH var.location SELECT FROM local: REF LocationRep.localVar => { IF local.parent # parentLabel THEN var.flags[upLevel] Ź TRUE; RETURN [node]; }; ENDCASE; labelNode: LabelNode => { label: Label = labelNode.label; WITH labelNode.label.node SELECT FROM lambda: LambdaNode => { oldParent: Label Ź parentLabel; parentLabel Ź label; IntCodeUtils.MapNodeList[lambda.body, innerMark]; parentLabel Ź oldParent; RETURN [node]; }; ENDCASE; }; ENDCASE; IntCodeUtils.MapNode[node, innerMark]; RETURN [node]; }; parentLabel: Label Ź NIL; node Ź innerMark[node]; }; CantHappen: SIGNAL = CODE; z: ZONE = IntCodeUtils.zone; END.