<<>> <> <> <> <> DIRECTORY C2CAccess, C2CBasics, C2CTarget, C2CIntCodeUtils, IntCodeDefs, IntCodeUtils; C2CIntCodeUtilsImpl: CEDAR PROGRAM IMPORTS C2CAccess, C2CBasics, C2CIntCodeUtils, IntCodeUtils EXPORTS C2CIntCodeUtils = BEGIN OPEN IntCodeDefs; CountNodes: PUBLIC PROC [nodes: IntCodeDefs.NodeList] RETURNS [cnt: INT Ź 0] = { WHILE nodes#NIL DO cnt Ź cnt+1; nodes Ź nodes.rest; ENDLOOP; }; AnyNodeHasCode: PUBLIC PROC [nodes: IntCodeDefs.NodeList] RETURNS [BOOL Ź FALSE] = { FOR nl: NodeList Ź nodes, nl.rest WHILE nl#NIL DO IF NodeHasCode[nl.first] THEN RETURN [TRUE]; ENDLOOP; }; NodeHasCode: PUBLIC PROC [node: IntCodeDefs.Node] RETURNS [BOOL] = { IF node=NIL THEN RETURN [FALSE]; WITH node SELECT FROM sourceNode: SourceNode => RETURN [AnyNodeHasCode[sourceNode.nodes]]; commentNode: CommentNode => RETURN [FALSE]; ENDCASE => RETURN [TRUE]; }; LastNodeWithCode: PUBLIC PROC [nodes: IntCodeDefs.NodeList] RETURNS [node: IntCodeDefs.Node Ź NIL] = { FOR nodesLeft: IntCodeDefs.NodeList Ź nodes, nodesLeft.rest WHILE nodesLeft#NIL DO IF NodeHasCode[nodesLeft.first] THEN node Ź nodesLeft.first ENDLOOP }; CheckArgCount: PUBLIC PROC [args: IntCodeDefs.NodeList, n: INT] = { WHILE args#NIL DO IF n<=0 THEN C2CBasics.CantHappen; args Ź args.rest; n Ź n-1; ENDLOOP; IF n#0 THEN C2CBasics.CantHappen; }; IsSimpleConst: PUBLIC PROC [node: IntCodeDefs.Node] RETURNS [is: BOOL Ź FALSE, val: CARD Ź 0] = { IF node#NIL AND node.bits<=bitsPerWord THEN WITH node SELECT FROM constNode: ConstNode => WITH constNode SELECT FROM wordConst: WordConstNode => { RETURN [TRUE, IntCodeUtils.WordToCard[wordConst.word]]; }; ENDCASE; var: Var => WITH var.location SELECT FROM dummy: DummyLocation => RETURN [TRUE, 0]; ENDCASE; ENDCASE; }; <<>> IsFieldVar: PUBLIC PROC [node: IntCodeDefs.Node] RETURNS [is: BOOL Ź FALSE] = { WITH node SELECT FROM var: Var => WITH var.location SELECT FROM field: FieldLocation => RETURN [TRUE]; ENDCASE => NULL; ENDCASE => NULL; }; GenConst: PUBLIC PROC [value: INT, bits: INT] RETURNS [ConstNode] = { RETURN [IntCodeUtils.zone.NEW[NodeRep.const.word Ź [bits, const[word[IntCodeUtils.IntToWord[value]]]]]]; }; keyForMaxVariableId: REF INT ~ NEW[INT]; --unique NewVariableId: PUBLIC PROC [] RETURNS [id: VariableId] = { MaxVariableId: PROC [node: Node] RETURNS [maxVariableId: INT Ź nullVariableId] = { <<--returns the maximal value used as an VariableId recursively down this node>> VisitVariableIds: IntCodeUtils.Visitor = { WITH node SELECT FROM var: Var => maxVariableId Ź MAX[maxVariableId, var.id]; ENDCASE => {}; IntCodeUtils.MapNode[node, VisitVariableIds]; RETURN [node]; }; [] Ź VisitVariableIds[node]; }; WITH C2CBasics.GetProp[keyForMaxVariableId] SELECT FROM ri: REF INT => id Ź ri Ź ri+1 ENDCASE => { id Ź MaxVariableId[C2CBasics.rootNode]; id Ź ((id/100000)+1) * 100000; C2CBasics.PutProp[keyForMaxVariableId, NEW[INT Ź id]] }; }; UseTemporaryIfReused: PUBLIC PROC [arg: Node, addr: BOOL Ź FALSE] RETURNS [BOOL Ź TRUE] = { SimpleReUse: PROC [arg: Node] RETURNS [BOOL Ź TRUE] = { <<--returns TRUE only for constants and very simple variables>> WITH arg SELECT FROM const: ConstNode => RETURN [TRUE]; var: Var => { IF var.location=nullLocation THEN RETURN [TRUE]; WITH var.location SELECT FROM globLoc: GlobalVarLocation => RETURN [TRUE]; locLoc: LocalVarLocation => RETURN [TRUE]; ENDCASE => RETURN [FALSE]; }; ENDCASE => RETURN [FALSE]; }; IF ~IntCodeUtils.SideEffectFree[node: arg, noSignals: TRUE] THEN RETURN [TRUE]; <<--eventual alternative: could consider trap on first deref NOT a sideeffect in case addr=TRUE>> WITH arg SELECT FROM apply: ApplyNode => { WITH apply.proc SELECT FROM oper: OperNode => WITH oper.oper SELECT FROM arithOp: ArithOper => SELECT arithOp.select FROM add, sub => { C2CIntCodeUtils.CheckArgCount[apply.args, 2]; IF SimpleReUse[apply.args.first] AND SimpleReUse[apply.args.rest.first] THEN RETURN [FALSE] }; ENDCASE; ENDCASE; ENDCASE; RETURN [TRUE]; }; const: ConstNode => RETURN [FALSE]; var: Var => { IF var.location=nullLocation THEN RETURN [FALSE]; WITH var.location SELECT FROM globLoc: GlobalVarLocation => RETURN [FALSE]; locLoc: LocalVarLocation => RETURN [FALSE]; derefLoc: DerefLocation => { <<--on Sunos4 compiler for Sparc I have found that the compiler might optimize away a temporary but wont optimize away multiple dereferences >> IF ~addr THEN RETURN [TRUE]; IF SimpleReUse[derefLoc.addr] THEN RETURN [FALSE]; RETURN [TRUE]; } ENDCASE => RETURN [TRUE]; }; ENDCASE => RETURN [TRUE]; }; UsingTemporaryWhichGeneratesStatementCode: PUBLIC PROC [arg: Node] RETURNS [BOOL Ź FALSE] = { <> WITH arg SELECT FROM apply: ApplyNode => WITH apply.proc SELECT FROM oper: OperNode => { IF ~C2CAccess.params.supportInlineFloatingPoint THEN RETURN [FALSE]; WITH oper.oper SELECT FROM arithOp: ArithOper => IF arithOp.class.kind=real THEN { SELECT arithOp.select FROM min, max, abs => RETURN [TRUE] ENDCASE => {}; }; ENDCASE => {}; }; machineCode: MachineCodeNode => {}; ENDCASE => RETURN [TRUE]; ENDCASE => {}; }; StatementCode: PUBLIC PROC [node: Node] RETURNS [hasLabel: BOOL Ź FALSE] = { <<--Checks whether node contains a label, goto, need for temporary, strong in tree. >> <<--To detect statement code which is not ok in conditional expressions >> <<--This is the stronger test >> Visit: IntCodeUtils.Visitor = { IF hasLabel THEN RETURN [node]; IF UsingTemporaryWhichGeneratesStatementCode[node] THEN { hasLabel Ź TRUE; RETURN [node]; }; <> WITH node SELECT FROM var: Var => WITH var.location SELECT FROM localLoc: LocalVarLocation =>{RETURN [node]}; --don't recurse and find this label compLoc: CompositeLocation => { <> hasLabel Ź TRUE; RETURN [node] }; xLoc: IndexedLocation => { <> WITH xLoc.base SELECT FROM bVar: Var => { WITH bVar.location SELECT FROM localLoc: LocalVarLocation => {}; globLoc: GlobalVarLocation => {}; derefLoc: DerefLocation => {}; ENDCASE => {hasLabel Ź TRUE; RETURN [node]}; }; ENDCASE => {hasLabel Ź TRUE; RETURN [node]}; }; ENDCASE => {}; oper: OperNode => WITH oper.oper SELECT FROM --also inside apply code: CodeOper => {RETURN [node]}; --don't recurse and find this label ENDCASE => {}; apply: ApplyNode => { IF apply.handler#NIL THEN {hasLabel Ź TRUE; RETURN [node]}; WITH apply.proc SELECT FROM <<--oper used inside apply because we need arguments...>> oper: OperNode => { WITH oper.oper SELECT FROM mesa: MesaOper => { <> SELECT mesa.mesa FROM all => {hasLabel Ź TRUE; RETURN [node]}; ENDCASE => {} }; arith: ArithOper => { IF arith.class.precision>C2CTarget.bitsPerWord THEN {hasLabel Ź TRUE; RETURN [node]}; SELECT arith.select FROM abs => IF C2CIntCodeUtils.UseTemporaryIfReused[apply.args.first] THEN {hasLabel Ź TRUE; RETURN [node]}; min, max => { cnt: INT Ź0; FOR argl: NodeList Ź apply.args, argl.rest WHILE argl#NIL DO cnt Ź cnt+1; IF cnt>2 OR C2CIntCodeUtils.UseTemporaryIfReused[argl.first] THEN {hasLabel Ź TRUE; RETURN [node]}; ENDLOOP; } ENDCASE => {} }; conv: ConvertOper => { IF C2CIntCodeUtils.UseTemporaryIfReused[apply.args.first] THEN {hasLabel Ź TRUE; RETURN [node]}; IF conv.to.precision>C2CTarget.bitsPerWord THEN {hasLabel Ź TRUE; RETURN [node]}; }; ENDCASE => {}; }; ENDCASE => {} }; block: BlockNode => { nodes: NodeList Ź block.nodes; <<--jump ahead of decls [they either don't generate code, or it is deteced anyway]>> WHILE nodes#NIL AND ISTYPE[nodes.first, DeclNode] DO nodes Ź nodes.rest ENDLOOP; <<--check for more than a single node>> IF nodes#NIL AND nodes.rest#NIL THEN {hasLabel Ź TRUE; RETURN [node]}; }; source: SourceNode => { <<--check for more than a single node>> IF source.nodes#NIL AND source.nodes.rest#NIL THEN {hasLabel Ź TRUE; RETURN [node]}; }; decl: DeclNode => { IF decl.init#NIL THEN {hasLabel Ź TRUE; RETURN [node]}; }; label: LabelNode => --nullLogicalId's are placed in for unused labels IF label.label.id#nullLogicalId THEN {hasLabel Ź TRUE; RETURN [node]}; goto: GotoNode => { hasLabel Ź TRUE; RETURN [node]; --don't recurse and find the destination label }; return: ReturnNode => { hasLabel Ź TRUE; RETURN [node]; --don't recurse }; assign: AssignNode => { <<1) because of lousy implementation of AssignNode>> <<2) also because we stop recursion for check of lHSMaskNShift here>> hasLabel Ź TRUE; RETURN [node] }; lambda: LambdaNode => C2CBasics.CantHappen; --nested procs ENDCASE => {}; IntCodeUtils.MapNode[node, Visit]; RETURN [node]; }; [] Ź Visit[node]; }; StatementJumps: PUBLIC PROC [node: Node] RETURNS [hasLabel: BOOL Ź FALSE] = { <<--Checks whether node contains a label, goto, shallow in tree >> <<--Does not care about assignments in statement part. >> <<--For detection of the so called block assignments >> <<--This is the weaker test >> original: Node Ź node; Visit: IntCodeUtils.Visitor = { IF hasLabel THEN RETURN [node]; <> WITH node SELECT FROM block: BlockNode => { IF block.bits=0 THEN RETURN [node]; }; label: LabelNode => --nullLogicalId's are placed in for unused labels IF label.label.id#nullLogicalId THEN {hasLabel Ź TRUE; RETURN [node]}; goto: GotoNode => { hasLabel Ź TRUE; RETURN [node]; --don't recurse and find the destination label }; lambda: LambdaNode => C2CBasics.CantHappen; --nested procs var: Var => WITH var.location SELECT FROM localVar: LocalVarLocation => {RETURN [node]}; --don't recurse and find this label ENDCASE => {}; oper: OperNode => WITH oper.oper SELECT FROM code: CodeOper => {RETURN [node]}; --don't recurse and find this label ENDCASE => {}; return: ReturnNode => { hasLabel Ź TRUE; RETURN [node]; --don't recurse }; apply: ApplyNode => { IF apply.handler#NIL THEN {hasLabel Ź TRUE; RETURN [node]}; IntCodeUtils.MapNode[apply.proc, Visit]; RETURN [node]; --don't recurse on arguments }; ENDCASE => {}; IntCodeUtils.MapNode[node, Visit]; RETURN [node]; }; [] Ź Visit[node]; }; <<>> SizeIsProvableOk: PUBLIC PROC [node: Node] RETURNS [BOOL Ź FALSE] = { <<--ok is defined as:>> <<--node.size correct, or, >> <<--if not correct such that a load is not wrong, but maybe inefficient>> IF node.bits<=0 THEN RETURN [FALSE]; WITH node SELECT FROM var: Var => WITH var.location SELECT FROM local: LocalVarLocation => RETURN [TRUE]; global: GlobalVarLocation => RETURN [TRUE]; deref: DerefLocation => RETURN [FALSE]; indexed: IndexedLocation => RETURN [TRUE]; field: FieldLocation => RETURN [SizeIsProvableOk[field.base]]; composite: CompositeLocation => RETURN [TRUE]; dummy: DummyLocation => RETURN [TRUE]; ENDCASE => C2CBasics.CaseMissing; apply: ApplyNode => RETURN [TRUE]; block: BlockNode => RETURN [TRUE]; const: ConstNode => RETURN [TRUE]; assign: AssignNode => RETURN [TRUE]; decl: DeclNode => RETURN [TRUE]; cond: CondNode => RETURN [TRUE]; label: LabelNode => RETURN [TRUE]; return: ReturnNode => RETURN [TRUE]; source: SourceNode => RETURN [TRUE]; enable: EnableNode => RETURN [TRUE]; lambda: LambdaNode => RETURN [TRUE]; module: ModuleNode => RETURN [TRUE]; ENDCASE => C2CBasics.CaseMissing; }; HasLabel: PUBLIC PROC [node: Node] RETURNS [hasLabel: BOOL Ź FALSE] = { inner: IntCodeUtils.Visitor = { n: Node Ź node; list: NodeList Ź NIL; DO IF hasLabel THEN EXIT; WITH n SELECT FROM var: Var => { WITH var.location SELECT FROM field: FieldLocation => {n Ź field.base; LOOP}; deref: DerefLocation => {n Ź deref.addr; LOOP}; indexed: IndexedLocation => { [] Ź inner[indexed.base]; n Ź indexed.index; LOOP }; comp: CompositeLocation => {list Ź comp.parts; EXIT}; ENDCASE; }; labelNode: LabelNode => { label: Label = labelNode.label; IF label.used THEN {hasLabel Ź TRUE; EXIT}; n Ź label.node; LOOP; }; lambda: LambdaNode => {hasLabel Ź TRUE; EXIT}; block: BlockNode => {list Ź block.nodes; EXIT}; source: SourceNode => {list Ź source.nodes; EXIT}; enable: EnableNode => {list Ź enable.scope; EXIT}; rtn: ReturnNode => {list Ź rtn.rets; EXIT}; goto: GotoNode => EXIT; mc: MachineCodeNode => hasLabel Ź TRUE; --there might be a label inside... cond: CondNode => { FOR each: CaseList Ź cond.cases, each.rest WHILE each#NIL AND ~ hasLabel DO FOR tests: NodeList Ź each.tests, tests.rest WHILE tests#NIL AND ~ hasLabel DO [] Ź inner[tests.first]; ENDLOOP; IF ~hasLabel THEN [] Ź inner[each.body]; ENDLOOP; }; apply: ApplyNode => { [] Ź inner[apply.proc]; list Ź apply.args; EXIT }; ENDCASE => IF n # NIL THEN IntCodeUtils.MapNode[n, inner]; EXIT; ENDLOOP; WHILE list#NIL AND ~ hasLabel DO [] Ź inner[list.first]; list Ź list.rest; ENDLOOP; RETURN [node]; }; [] Ź inner[node]; }; END.