<<>> <> <> <> <> <> DIRECTORY IntCodeDefs, IntCodeStuff, IntCodeUtils, C2CBasics, C2CIntCodeUtils, C2CPreprocessing, C2CTarget, Rope; C2CPreprocessingImpl: CEDAR PROGRAM IMPORTS C2CBasics, IntCodeStuff, C2CIntCodeUtils, IntCodeUtils EXPORTS C2CPreprocessing = BEGIN OPEN IntCodeDefs; debugDontChangeIntCode: BOOL Ź FALSE; -- while debugging plain generation we might want to make sure that the int code tree is correct z: ZONE Ź IntCodeUtils.zone; defaultFlags: VariableFlags ~ DefaultFlags[]; DefaultFlags: PROC [] RETURNS [dummyParameterFlags: VariableFlags] = { dummyParameterFlags[used] Ź TRUE; dummyParameterFlags[constant] Ź FALSE; dummyParameterFlags[addressed] Ź TRUE; dummyParameterFlags[upLevel] Ź FALSE; dummyParameterFlags[notRegister] Ź TRUE; dummyParameterFlags[named] Ź FALSE; }; dummyParameterFlags: VariableFlags ~ DummyParameterFlags[]; DummyParameterFlags: PROC [] RETURNS [dummyParameterFlags: VariableFlags] = { dummyParameterFlags[used] Ź TRUE; dummyParameterFlags[constant] Ź TRUE; dummyParameterFlags[addressed] Ź FALSE; dummyParameterFlags[upLevel] Ź FALSE; dummyParameterFlags[notRegister] Ź TRUE; dummyParameterFlags[named] Ź FALSE; }; addition: Node Ź IntCodeStuff.GenOperNode[operRep: [arith[class: [unsigned, FALSE, C2CTarget.bitsPerWord], select: add]], bits: C2CTarget.bitsPerWord]; multiplication: Node Ź IntCodeStuff.GenOperNode[operRep: [arith[class: [unsigned, FALSE, C2CTarget.bitsPerWord], select: mul]], bits: C2CTarget.bitsPerWord]; AppendNode: PROC [nodes: NodeList, node: Node] RETURNS [NodeList] = { IF node=NIL THEN RETURN [nodes]; IF nodes=NIL THEN RETURN [IntCodeUtils.NodeListCons[first: node]]; FOR nl: NodeList Ź nodes, nl.rest DO IF nl.rest=NIL THEN {nl.rest Ź IntCodeUtils.NodeListCons[first: node]; RETURN [nodes]} ENDLOOP; }; GenNullSource: PROC [nodes: NodeList, bits: INT Ź 0] RETURNS [SourceNode] = { RETURN [z.NEW[NodeRep.source Ź [bits, source[nullSourceRange, nodes]]]]; }; HasFreeDecl: PROC [node: Node] RETURNS [has: BOOL Ź FALSE] = { <<--returns whether node has declarations not inside local blocks>> Inner: IntCodeUtils.Visitor = { WITH node SELECT FROM block: BlockNode => RETURN [node]; --stop recursion decl: DeclNode => {has Ź TRUE; RETURN [node]}; ENDCASE => {}; IntCodeUtils.MapNode[node, Inner]; RETURN [node] }; [] Ź Inner[node]; }; GenWordConst: PROC [val: Word, bits: INT] RETURNS [ConstNode] = { RETURN [ IntCodeStuff.GenConst[int: IntCodeUtils.WordToInt[val], bits: bits] ]; }; GenLocalLocation: PROC [id: VariableId, parent: Label Ź NIL] RETURNS [loc: Location] = { loc Ź z.NEW[LocationRep.localVar Ź [localVar[id: id, parent: parent]]]; }; GenIndexedLocation: PROC [base: Node, index: Node] RETURNS [loc: IndexedLocation] = { loc Ź z.NEW[LocationRep.indexed Ź [indexed[base: base, index: index]]]; }; ProcDescMayRaiseErrors: PROC [applyNode: ApplyNode] RETURNS [BOOL] = { <<--this does NOT tell whether the procedure raises errors, but,>> <<--whether finding the procedure descriptor may raise errors >> WITH applyNode.proc SELECT FROM oper: OperNode => RETURN [FALSE]; mc: MachineCodeNode => RETURN [FALSE]; ENDCASE => RETURN [~IntCodeUtils.SideEffectFree[applyNode.proc, TRUE]]; }; ArgsMayRaiseErrors: PROC [applyNode: ApplyNode] RETURNS [BOOL] = { RETURN [~IntCodeUtils.SideEffectFreeList[applyNode.args, TRUE]] }; ConsideredConstant: PROC [node: Node] RETURNS [isConst: BOOL Ź TRUE] = { isConst Ź WITH node SELECT FROM var: Var => var.flags[constant], const: ConstNode => TRUE, decl: DeclNode => ConsideredConstant[decl.var] AND IntCodeUtils.SideEffectFree[decl.init, TRUE], comment: CommentNode => TRUE, ENDCASE => FALSE; }; MoveFrontParametersWhichMayRaiseErrors: PROC [node: Node] = { DoIt: PROC [outer: Node, parent: Label] = { Inner: IntCodeUtils.Visitor = { DoIt[node, parent]; WITH node SELECT FROM applyNode: ApplyNode => { IF applyNode.handler#NIL THEN { descDanger: BOOL Ź ProcDescMayRaiseErrors[applyNode: applyNode]; argDanger: BOOL Ź ArgsMayRaiseErrors[applyNode: applyNode]; blockNodes: NodeList Ź NIL; Move: PROC [node: Node] RETURNS [substitute: Var] = { <<--side effect: changes blockNode (also uses C2CIntCodeUtils.NewVariableId, parent)>> GenLocalVariable: PROC [parent: Label, bits: INT, flags: VariableFlags Ź defaultFlags] RETURNS [var: Var] = { <<--generates new variable, but not yet declared>> id: VariableId Ź C2CIntCodeUtils.NewVariableId[]; loc: Location Ź GenLocalLocation[id, parent]; var Ź IntCodeStuff.GenAnonVar[bits, loc]; var.id Ź id; var.flags Ź flags; }; var: Var Ź GenLocalVariable[parent, node.bits, dummyParameterFlags]; declNode: Node Ź IntCodeStuff.GenDecl[var: var, init: node]; blockNodes Ź AppendNode[blockNodes, declNode]; RETURN [var]; }; IF descDanger THEN { substitute: Var Ź Move[applyNode.proc]; applyNode.proc Ź substitute; }; IF argDanger THEN { FOR args: NodeList Ź applyNode.args, args.rest WHILE args#NIL DO IF ~ConsideredConstant[args.first] THEN { <<--constancy required, not error-freeness (evaluation order!)>> substitute: Var Ź Move[args.first]; args.first Ź substitute; } ENDLOOP; }; IF blockNodes#NIL THEN { blockNodes Ź AppendNode[blockNodes, applyNode]; IF HasFreeDecl[applyNode] THEN RETURN [GenNullSource[nodes: blockNodes, bits: applyNode.bits]] ELSE RETURN [IntCodeStuff.GenBlock[nodes: blockNodes, bits: applyNode.bits]]; }; }; }; ENDCASE => {}; RETURN [node]; }; <<--DoIt>> WITH outer SELECT FROM labelNode: LabelNode => WITH labelNode.label.node SELECT FROM labeledLambda: LambdaNode => parent Ź labelNode.label; ENDCASE => {}; ENDCASE => {}; IntCodeUtils.MapNode[outer, Inner]; }; <<--don't clobber IntCode tree while debugging other parts>> IF debugDontChangeIntCode THEN RETURN; <<--check to make sure the recursion starts right at this point>> IF ISTYPE[node, ApplyNode] THEN ERROR; --recursion starts wrong DoIt[node, NIL]; }; EliminateSideEffectsOfErrors: PUBLIC PROC [] = { CleanupFields[]; CleanupLabels[]; MoveFrontParametersWhichMayRaiseErrors[C2CBasics.rootNode]; C2CBasics.Report[]; }; CleanupLabels: PROC [] = { usedlabels: IntCodeUtils.IdTab Ź IntCodeUtils.NewIdTab[]; FindGotos: IntCodeUtils.Visitor = { WITH node SELECT FROM goto: GotoNode => [] Ź IntCodeUtils.Store[usedlabels, goto.dest.id, $used]; oper: OperNode => WITH oper.oper SELECT FROM codeOp: CodeOper => [] Ź IntCodeUtils.Store[usedlabels, codeOp.label.id, $used]; ENDCASE => {}; ENDCASE => {}; IntCodeUtils.MapNode[node, FindGotos]; RETURN [node]; }; VisitLambdas: IntCodeUtils.Visitor = { <<--for each lambda call VisitLabels>> WITH node SELECT FROM lambda: LambdaNode => { IntCodeUtils.MapNode[node, VisitLabels]; RETURN [node]; --dont recurse }; ENDCASE => {}; IntCodeUtils.MapNode[node, VisitLambdas]; RETURN [node]; }; VisitLabels: IntCodeUtils.Visitor = { <<--and replace id of unused labels>> WITH node SELECT FROM label: LabelNode => { IF label.label.id#nullLogicalId AND IntCodeUtils.Fetch[usedlabels, label.label.id]=IntCodeUtils.NullValue THEN { label.label.id Ź nullLogicalId }; }; ENDCASE => {}; IntCodeUtils.MapNode[node, VisitLabels]; RETURN [node]; }; [] Ź FindGotos[C2CBasics.rootNode]; [] Ź VisitLambdas[C2CBasics.rootNode]; }; MaskOut: PROC [use: Word, from, bits: INT] RETURNS [Word] = { <<--returns "bits" rightadjusted bits from location "from">> ShiftRight: PROC [use: Word, bits: INT] RETURNS [Word] = { IF bits#0 THEN { FOR b: INT DECREASING IN [bits..IntCodeDefs.bitsPerWord) DO use[b] Ź use[b-bits] ENDLOOP; }; RETURN [use]; }; RestrictTo: PROC [use: Word, bits: INT] RETURNS [Word] = { FOR b: INT IN [0..IntCodeDefs.bitsPerWord-bits) DO use[b] Ź FALSE; ENDLOOP; RETURN [use]; }; use Ź ShiftRight[use, C2CTarget.bitsPerWord-(from+bits)]; RETURN [RestrictTo[use, bits]]; }; HasLeftBitSet: PROC [limWord: Word, leftBits: INT] RETURNS [BOOL Ź FALSE] = { FOR b: INT IN [0..leftBits+IntCodeDefs.bitsPerWord-C2CTarget.bitsPerWord) DO IF limWord[b] THEN RETURN [TRUE]; ENDLOOP }; SimplifyBoundsChecks: PROC [oBckApply: ApplyNode] RETURNS [replaceBy: Node] = { <<--oCkApply = outer bounds checking apply>> <<--When called, oBckApply oper most be a check operation, lt, unsigned, <= one word>> replaceBy Ź oBckApply; IF oBckApply.handler=NIL THEN { oBCkSimple: BOOL; oBCkLimit: CARD; [oBCkSimple, oBCkLimit] Ź C2CIntCodeUtils.IsSimpleConst[--limit--oBckApply.args.rest.first]; IF oBCkSimple THEN { oArgument: Node Ź oBckApply.args.first; WITH oArgument SELECT FROM nApply: ApplyNode => IF nApply.handler=NIL THEN { WITH nApply.proc SELECT FROM nOper: OperNode => { WITH nOper.oper SELECT FROM nCheckOp: CheckOper => { IF CheckOpSimple[nCheckOp] THEN { nBCkSimple: BOOL; nBCkLimit: CARD; [nBCkSimple, nBCkLimit] Ź C2CIntCodeUtils.IsSimpleConst[--limit--nApply.args.rest.first]; IF nBCkSimple THEN { IF oBCkLimit<=nBCkLimit THEN {oBckApply.args.first Ź nApply.args.first} ELSE {replaceBy Ź nApply} }; }; }; nArithOp: ArithOper => { --precision ok without test IF nArithOp.class.kind=unsigned AND nArithOp.select=sub THEN { WITH nApply.args.first --base of sub-- SELECT FROM bApply: ApplyNode => IF bApply.handler=NIL THEN { WITH bApply.proc SELECT FROM bOper: OperNode => WITH bOper.oper SELECT FROM bCheckOp: CheckOper => { IF CheckOpSimple[bCheckOp] THEN { nBCkSimple: BOOL; nBCkLimit: CARD; [nBCkSimple, nBCkLimit] Ź C2CIntCodeUtils.IsSimpleConst[--limit--bApply.args.rest.first]; IF nBCkSimple THEN { subSimple: BOOL; subVal: CARD; [subSimple, subVal] Ź C2CIntCodeUtils.IsSimpleConst[--sub--nApply.args.rest.first]; IF nBCkSimple AND subSimple AND oBCkLimit<=nBCkLimit AND CARD[nBCkLimit-oBCkLimit]>=subVal THEN { nApply.args.first --base of sub-- Ź bApply.args.first }; }; }; }; ENDCASE --bOper.oper-- => {}; ENDCASE --bApply.proc-- => {}; }; ENDCASE --nApply.args.first-- => {}; }; }; ENDCASE --nOper.oper-- => {}; }; ENDCASE --nApply.proc-- => {}; }; ENDCASE --oArgument-- => {}; }; }; }; CheckOpSimple: PROC [checkOp: CheckOper] RETURNS [BOOL] = { RETURN [checkOp.sense=lt AND checkOp.class.kind=unsigned AND checkOp.class.precision<=C2CTarget.bitsPerWord] }; CleanupFields: PROC [] = { <<--eliminate masking constants and bound checks>> <<--reduce frequent flags where problems are to be expected>> <<--also compute size of largest dummy>> largestDummy: INT Ź 0; idsForPtrTab: IntCodeUtils.IdTab Ź IntCodeUtils.NewIdTab[]; lhs: BOOL Ź FALSE; --used as hint only FindFields: IntCodeUtils.Visitor = { oldLhs: BOOL Ź lhs; --set on every RETURN WITH node SELECT FROM apply: ApplyNode => { <<--fix converts of mesa errors from 0 bits to 1 bit>> WITH apply.proc SELECT FROM oper: OperNode => WITH oper.oper SELECT FROM checkOp: CheckOper => { IF CheckOpSimple[checkOp] THEN node Ź SimplifyBoundsChecks[apply] }; arithOp: ArithOper => { <> IF arithOp.class.kind=unsigned AND arithOp.class.precision=BITS[CARD] AND apply.args#NIL AND apply.args.rest#NIL THEN { arg1: Node Ź apply.args.first; arg2: Node Ź apply.args.rest.first; WITH arg1 SELECT FROM carg1: IntCodeDefs.WordConstNode => { WITH arg2 SELECT FROM carg2: IntCodeDefs.WordConstNode => { fold: BOOL Ź FALSE; value: CARD; c1: CARD Ź IntCodeUtils.WordToCard[carg1.word]; c2: CARD Ź IntCodeUtils.WordToCard[carg2.word]; SELECT arithOp.select FROM add => {value Ź c1+c2; fold Ź TRUE}; sub => {value Ź c1-c2; fold Ź TRUE}; mul => {value Ź c1*c2; fold Ź TRUE}; div => IF c2#0 THEN {value Ź c1/c2; fold Ź TRUE}; mod => IF c2#0 THEN {value Ź c1 MOD c2; fold Ź TRUE}; ENDCASE; IF fold THEN node Ź IntCodeStuff.GenConst[LOOPHOLE[value], C2CTarget.bitsPerWord]; }; ENDCASE; }; ENDCASE; }; }; convert: ConvertOper => IF convert.from.precision=0 AND apply.args.first.bits=0 AND convert.to.precision>0 THEN { WITH apply.args.first SELECT FROM apply2: ApplyNode => WITH apply2.proc SELECT FROM oper2: OperNode => WITH oper2.oper SELECT FROM mesa2: MesaOper => SELECT mesa2.mesa FROM error => { apply2.bits Ź 1; convert.from.precision Ź 1; }; ENDCASE => {--?--}; ENDCASE => {--?--}; ENDCASE => {--?--}; ENDCASE => {--?--}; }; ENDCASE => {}; ENDCASE => {}; }; var: Var => { IF var.flags[frequent] THEN { IF var.bits#C2CTarget.bitsPerWord THEN var.flags[frequent] Ź FALSE; IF var.flags[addressed] THEN var.flags[frequent] Ź FALSE; IF var.flags[notRegister] THEN var.flags[frequent] Ź FALSE; IF var.flags[upLevel] THEN var.flags[frequent] Ź FALSE; IF var.flags[frequent] THEN [] Ź IntCodeUtils.Store[idsForPtrTab, var.id, $yes]; --provisionally }; WITH var.location SELECT FROM field: FieldLocation => { <<--don't do that, size may be wrong>> <> <<--field is complete record>> <> <<};>> IF var.bits>0 AND field.base.bits<=C2CTarget.bitsPerWord THEN { WITH field.base SELECT FROM var: Var => var.flags[frequent] Ź FALSE; --some code to take fields uses the address const: ConstNode => <<--return new, modified constant if possible>> WITH const SELECT FROM wordConst: WordConstNode => { <<--we've got it!>> replacementNode: Node Ź GenWordConst[MaskOut[wordConst.word, field.start, var.bits], var.bits]; lhs Ź oldLhs; RETURN [replacementNode]; --instead of field-var! }; ENDCASE => {}; apply: ApplyNode => <<--eliminate masking over bound checks if possible>> WITH apply.proc SELECT FROM oper: OperNode => WITH oper.oper SELECT FROM checkOp: CheckOper => { IF checkOp.sense=lt AND field.start+var.bits=C2CTarget.bitsPerWord THEN { isConst: BOOL; p: INT Ź0; limWord: Word; constVal: CARD Ź 0; limit: Node Ź apply.args.rest.first; [isConst, constVal] Ź C2CIntCodeUtils.IsSimpleConst[limit]; IF isConst AND constVal>0 THEN { limWord Ź IntCodeUtils.CardToWord[constVal-1]; IF ~HasLeftBitSet[limWord, field.start] THEN { <<--we've got it!>> replacementNode: Node Ź z.NEW[apply NodeRep Ź apply]; replacementNode.bits Ź var.bits; lhs Ź oldLhs; RETURN [replacementNode]; --instead of field-var! }; }; }; }; ENDCASE => {}; ENDCASE => {}; ENDCASE => {}; }; }; indexed: IndexedLocation => { <<--try to get rid of multi dimensional packed arrays>> IF var.bits WITH bvar.location SELECT FROM bindexed: IndexedLocation => IF bvar.bits IF bfield.start MOD C2CTarget.bitsPerWord # 0 THEN { IF bfield.start MOD var.bits = 0 THEN { <<--now field can be removed or changed, but>> <<--check if removing field actually helps...>> doReplace: BOOL Ź FALSE; IF bfield.base.bits<=C2CTarget.bitsPerWord AND C2CIntCodeUtils.SizeIsProvableOk[bfield.base] THEN { <> doReplace Ź TRUE; }; IF doReplace THEN { offset: Node Ź IntCodeStuff.GenConst[bfield.start/var.bits, C2CTarget.bitsPerWord]; summands: NodeList Ź IntCodeStuff.NodeListCons2[indexed.index, offset]; newIndex: ApplyNode Ź IntCodeStuff.GenApply[addition, summands, C2CTarget.bitsPerWord]; newLocation: Location Ź GenIndexedLocation[base: bfield.base, index: newIndex]; var.location Ź newLocation; lhs Ź oldLhs; RETURN [FindFields[node]]; --recurse on same node }; }; }; ENDCASE => {}; ENDCASE => {} }; indexed.base Ź FindFields[indexed.base]; lhs Ź FALSE; indexed.index Ź FindFields[indexed.index]; lhs Ź oldLhs; RETURN [node]; }; dummy: DummyLocation => largestDummy Ź MAX[largestDummy, var.bits]; deref: DerefLocation => { lhs Ź FALSE; deref.addr Ź FindFields[deref.addr]; lhs Ź oldLhs; RETURN [node]; }; ENDCASE => {}; }; assign: AssignNode => { lhs Ź TRUE; assign.lhs Ź NARROW[FindFields[assign.lhs]]; lhs Ź FALSE; assign.rhs Ź FindFields[assign.rhs]; lhs Ź oldLhs; RETURN [node]; }; ENDCASE => {}; IntCodeUtils.MapNode[node, FindFields]; lhs Ź oldLhs; RETURN [node]; }; EliminateVar: PROC [var: Var] = { IF var.flags[frequent] AND var.bits=C2CTarget.bitsPerWord THEN [] Ź IntCodeUtils.Store[idsForPtrTab, var.id, NIL]; }; EliminatePointerUsage: IntCodeUtils.Visitor = { WITH node SELECT FROM var: Var => { EliminateVar[var]; WITH var.location SELECT FROM deref: DerefLocation => { <<--avoids direct visit of addr>> IntCodeUtils.MapNode[deref.addr, EliminatePointerUsage]; RETURN [node]; }; ENDCASE => {}; }; decl: DeclNode => { <<--don't recurse on the var itself!>> [] Ź EliminatePointerUsage[decl.init]; WITH decl.init SELECT FROM oper: OperNode => WITH oper.oper SELECT FROM mesa: MesaOper => SELECT mesa.mesa FROM globalFrame => {}; --that is ok usage ENDCASE => EliminateVar[decl.var]; ENDCASE => EliminateVar[decl.var]; ENDCASE => IF decl.init#NIL THEN EliminateVar[decl.var]; RETURN [node]; --avoids direct visit of var }; ENDCASE => {}; IntCodeUtils.MapNode[node, EliminatePointerUsage]; RETURN [node]; }; C2CBasics.PutProp[$MayBeDeclaredAsPtrTab, idsForPtrTab]; C2CBasics.PutProp[$LargestDummy, NEW[INT Ź largestDummy]]; [] Ź FindFields[C2CBasics.rootNode]; [] Ź EliminatePointerUsage[C2CBasics.rootNode]; }; MayBeDeclaredAsPtr: PUBLIC PROC [var: IntCodeDefs.Var] RETURNS [BOOL Ź FALSE] = { IF var.bits#C2CTarget.bitsPerWord THEN RETURN [FALSE]; IF ~var.flags[frequent] THEN RETURN [FALSE]; WITH C2CBasics.GetProp[$MayBeDeclaredAsPtrTab] SELECT FROM tab: IntCodeUtils.IdTab => RETURN [IntCodeUtils.Fetch[tab, var.id]=$yes] ENDCASE => RETURN [FALSE]; }; END.