{$optimize 15} {---------------------------------------------------------------} { } { DAG Creation } { } { Places intermediate codes into DAGs and trees. } { } {---------------------------------------------------------------} unit DAG; interface {$segment 'cg'} {$LibPrefix '0/obj/'} uses PCommon, CGI, CGC, Gen; {---------------------------------------------------------------} procedure DAG (code: icptr); { place an op code in a DAG or tree } { } { parameters: } { code - opcode } {---------------------------------------------------------------} implementation const peepSpinRate = 20; {PeepHoleOptimize spin rate} var c_ind: iclist; {vars that can be changed by indirect stores} maxLoc: integer; {max local label number used by compiler} memberOp: icptr; {operation found by Member} optimizations: array[pcodes] of integer; {starting indexes into peeptable} peepSpin: 0..peepSpinRate; {spinner delay for PeepHoleOptimize} peepTablesInitialized: boolean; {have the peephole tables been initialized?} prsFound: boolean; {are there any pc_prs opcodes?} rescan: boolean; {redo the optimization pass?} {-- External unsigned math routines ----------------------------} function udiv (x,y: longint): longint; extern; function umod (x,y: longint): longint; extern; function umul (x,y: longint): longint; extern; {---------------------------------------------------------------} function SetsEqual (s1, s2: setPtr): boolean; { See if two sets are equal } { } { parameters: } { s1, s2 - sets to compare } { } { Returns: True if the sets are equal, else false } label 1; var i: unsigned; {loop/index variable} begin {SetsEqual} SetsEqual := false; if s1^.smax = s2^.smax then begin for i := 1 to s1^.smax do if s1^.sval[i] <> s2^.sval[i] then goto 1; SetsEqual := true; end; {if} 1: ; end; {SetsEqual} function CodesMatch (op1, op2: icptr; exact: boolean): boolean; { Check to see if the trees op1 and op2 are equivalent } { } { parameters: } { op1, op2 - trees to check } { exact - is an exact of operands match required? } { } { Returns: True if trees are equivalent, else false. } function OpsEqual (op1, op2: icptr): boolean; { See if the operands are equal } { } { parameters: } { op1, op2 - operations to check } { } { Returns: True if the operands are equivalent, else } { false. } var result: boolean; {temp result} begin {OpsEqual} result := false; case op1^.opcode of pc_cup, pc_cum, pc_cui, pc_csp, pc_tl1, pc_tl2, pc_vct, pc_pds, pc_bno: {this rule prevents optimizations from removing sensitive operations} ; pc_adi, pc_adl, pc_adr, pc_and, pc_lnd, pc_bnd, pc_bal, pc_bor, pc_blr, pc_bxr, pc_blx, pc_equ, pc_neq, pc_ior, pc_lor, pc_mpi, pc_umi, pc_mpl, pc_uml, pc_mpr, pc_int, pc_uni: begin if op1^.left = op2^.left then if op1^.right = op2^.right then result := true; if not result then if op1^.left = op2^.right then if op1^.right = op2^.left then result := true; if not result then if not exact then if CodesMatch(op1^.left, op2^.left, false) then if CodesMatch(op1^.right, op2^.right, false) then result := true; if not result then if not exact then if CodesMatch(op1^.left, op2^.right, false) then if CodesMatch(op1^.right, op2^.left, false) then result := true; end; otherwise: begin if op1^.left = op2^.left then if op1^.right = op2^.right then result := true; if not result then if not exact then if CodesMatch(op1^.left, op2^.left, false) then if CodesMatch(op1^.right, op2^.right, false) then result := true; end; end; {case} OpsEqual := result; end; {OpsEqual} function LabsEqual (l1, l2: pStringPtr): boolean; { See if the labels are equal } { } { parameters: } { l1, l2 - labels to check } { } { Returns: True if the labels are equal, else false } begin {LabsEqual} if (l1 = nil) and (l2 = nil) then LabsEqual := true else if (l1 <> nil) and (l2 <> nil) then LabsEqual := l1^ = l2^ else LabsEqual := false; end; {LabsEqual} begin {CodesMatch} CodesMatch := false; if (op1 = nil) and (op2 = nil) then CodesMatch := true else if (op1 <> nil) and (op2 <> nil) then if op1^.opcode = op2^.opcode then if op1^.q = op2^.q then if op1^.r = op2^.r then if op1^.s = op2^.s then if LabsEqual(op1^.lab, op2^.lab) then if OpsEqual(op1, op2) then if op1^.optype = op2^.optype then case op1^.optype of cgByte, cgUByte, cgWord, cgUWord: if op1^.opnd = op2^.opnd then if op1^.llab = op2^.llab then if op1^.slab = op2^.slab then CodesMatch := true; cgLong, cgULong: if op1^.lval = op2^.lval then CodesMatch := true; cgReal, cgDouble, cgComp, cgExtended: if op1^.rval = op2^.rval then CodesMatch := true; cgString: CodesMatch := op1^.str^ = op2^.str^; cgSet: CodesMatch := SetsEqual(op1^.setp, op2^.setp); cgVoid: CodesMatch := true; end; {case} end; {CodesMatch} {- Peephole Optimization ---------------------------------------} function Base (val: longint): integer; { Assuming val is a power of 2, find ln(val) base 2 } { } { parameters: } { val - value for which to find the base } { } { Returns: ln(val), base 2 } var i: integer; {base counter} begin {Base} i := 0; while not odd(val) do begin val := val >> 1; i := i+1; end; {while} Base := i; end; {Base} procedure BinOps (var op1, op2: icptr); { Make sure the operands are of the same type } { } { parameters: } { op1, op2: two pc_ldc operands } var opt1, opt2: baseTypeEnum; {temp operand types} begin {BinOps} opt1 := op1^.optype; opt2 := op2^.optype; if opt1 = cgByte then begin op1^.optype := cgWord; opt1 := cgWord; end {if} else if opt1 = cgUByte then begin op1^.optype := cgUWord; opt1 := cgUWord; end {else if} else if opt1 in [cgReal, cgDouble, cgComp] then begin op1^.optype := cgExtended; opt1 := cgExtended; end; {else if} if opt2 = cgByte then begin op2^.optype := cgWord; opt2 := cgWord; end {if} else if opt2 = cgUByte then begin op2^.optype := cgUWord; opt2 := cgUWord; end {else if} else if opt2 in [cgReal, cgDouble, cgComp] then begin op2^.optype := cgExtended; opt2 := cgExtended; end; {else if} if opt1 <> opt2 then begin case opt1 of cgWord: case opt2 of cgUWord: op1^.optype := cgUWord; cgLong, cgULong: begin op1^.lval := op1^.q; op1^.optype := opt2; end; cgExtended: begin op1^.rval := op1^.q; op1^.optype := cgExtended; end; otherwise: ; end; {case} cgUWord: case opt2 of cgWord: op2^.optype := cgUWord; cgLong, cgULong: begin op1^.lval := ord4(op1^.q) & $0000FFFF; op1^.optype := opt2; end; cgExtended: begin op1^.rval := ord4(op1^.q) & $0000FFFF; op1^.optype := cgExtended; end; otherwise: ; end; {case} cgLong: case opt2 of cgWord: begin op2^.lval := op2^.q; op2^.optype := cgLong; end; cgUWord: begin op2^.lval := ord4(op2^.q) & $0000FFFF; op2^.optype := cgLong; end; cgULong: op1^.optype := cgULong; cgExtended: begin op1^.rval := op1^.lval; op1^.optype := cgExtended; end; otherwise: ; end; {case} cgULong: case opt2 of cgWord: begin op2^.lval := op2^.q; op2^.optype := cgLong; end; cgUWord: begin op2^.lval := ord4(op2^.q) & $0000FFFF; op2^.optype := cgLong; end; cgLong: op2^.optype := cgULong; cgExtended: begin op1^.rval := op1^.lval; if op1^.rval < 0.0 then op1^.rval := 4294967296.0 + op1^.rval; op1^.optype := cgExtended; end; otherwise: ; end; {case} cgExtended: begin case opt2 of cgWord: op2^.rval := op2^.q; cgUWord: op2^.rval := ord4(op2^.q) & $0000FFFF; cgLong: op2^.rval := op2^.lval; cgULong: begin op2^.rval := op2^.lval; if op2^.rval < 0.0 then op2^.rval := 4294967296.0 + op2^.rval; end; otherwise: ; end; {case} op2^.optype := cgExtended; end; otherwise: ; end; {case} end; {if} end; {BinOps} procedure CheckLabels; { remove unused dc_lab labels } type nameTypePtr = ^nameType; {named label list element} nameType = record next: nameTypePtr; lab: pStringPtr; end; {used label array} usedArray = packed array[0..maxLabel] of boolean; var lop: icptr; {predecessor of op} op: icptr; {used to trace the opcode list} usedLabels: ^usedArray; {used numeric label array} usedNames: nameTypePtr; {used named labels list} procedure BuildLabels; { build the used label array and list } var lab: 0..maxLabel; {loop/index variable} op: icptr; {used to trace the opcode list} procedure RecordName (lab: pStringPtr); { record a named label } { } { parameters: } { lab - label name to record } var found: boolean; {was the name in the list already?} np: nameTypePtr; {name pointer} begin {RecordName} found := false; np := usedNames; while np <> nil do if np^.lab^ = lab^ then begin np := nil; found := true; end {if} else np := np^.next; if not found then begin new(np); np^.next := usedNames; usedNames := np; np^.lab := lab; end; {if} end; {RecordName} procedure CheckCup (op: icptr); { Check for labels in procedure calls } { } { parameters: } { op - label to check } begin {CheckCup} if op^.opcode = pc_cup then if op^.lab = nil then begin if op^.r <= maxLabel then usedLabels^[op^.r] := true; end {if} else RecordName(op^.lab); if op^.left <> nil then CheckCup(op^.left); if op^.right <> nil then CheckCup(op^.right); end; {CheckCup} begin {BuildLabels} new(usedLabels); {no numbered labels} for lab := 0 to maxLabel do usedLabels^[lab] := false; usedNames := nil; {no named labels} op := DAGhead; while op <> nil do begin if op^.opcode in [pc_add, pc_fjp, pc_tjp, pc_ujp] then if op^.lab = nil then begin if op^.q <= maxLabel then usedLabels^[op^.q] := true; end {if} else RecordName(op^.lab); CheckCup(op); op := op^.next; end; {while} end; {BuildLabels} procedure DisposeLabels; { dispose of the dynamic memory allocated by BuildLabels } var p1, p2: nameTypePtr; {work pointers} begin {DisposeLabels} dispose(usedLabels); p1 := usedNames; while p1 <> nil do begin p2 := p1; p1 := p2^.next; dispose(p2); end; {while} end; {DisposeLabels} function Used (q: integer; lab: pStringPtr): boolean; { see if a label is used } { } { parameters: } { q - label number to check } { lab - named label to check } { } { Returns: True if the label is used, else false. } var np: nameTypePtr; {used to trace usedNames list} begin {Used} if lab = nil then if q <= maxLabel then Used := usedLabels^[q] else Used := true else begin np := usedNames; Used := false; while np <> nil do if np^.lab^ = lab^ then begin np := nil; Used := true; end {if} else np := np^.next; end; {else} end; {Used} begin {CheckLabels} BuildLabels; {build a list of used labels} op := DAGhead; {get rid of unused labels} while op^.next <> nil do begin lop := op; op := op^.next; if op^.opcode = dc_lab then begin Spin; if op^.lab = nil then if not Used(op^.q, op^.lab) then begin lop^.next := op^.next; op := lop; rescan := true; end; {if} end; {if} end; {while} DisposeLabels; {get rid of label lists} end; {CheckLabels} procedure RemoveDeadCode (op: icptr); { remove dead code following an unconditional branch } { } { parameters: } { op - unconditional branch opcode } begin {RemoveDeadCode} while not (op^.next^.opcode in [dc_lab, dc_enp, dc_cns, dc_glb, dc_dst, dc_str, dc_pin, pc_ent, dc_loc, dc_prm, dc_fun, dc_sym]) do begin op^.next := op^.next^.next; rescan := true; end; {while} end; {RemoveDeadCode} function NoFunctions (op: icptr): boolean; { are there any function calls? } { } { parameters: } { op - operation tree to search } { } { returns: True if there are no pc_cup or pc_cui operations } { in the tree, else false. } begin {NoFunctions} if op = nil then NoFunctions := true else if op^.opcode in [pc_cup,pc_cui,pc_cum,pc_csp,pc_tl1,pc_tl2,pc_vct,pc_pds] then NoFunctions := false else NoFunctions := NoFunctions(op^.left) or NoFunctions(op^.right); end; {NoFunctions} function OneBit (val: longint): boolean; { See if there is exactly one bit set in val } { } { parameters: } { val - value to check } { } { Returns: True if exactly one bit is set, else false } begin {OneBit} if val = 0 then OneBit := false else begin while not odd(val) do val := val >> 1; OneBit := val = 1; end; {else} end; {OneBit} function TypeSize (tp: baseTypeEnum): integer; { Find the size, in bytes, of a variable } { } { parameters: } { tp - base type of the variable } begin {TypeSize} case tp of cgByte,cgUByte: TypeSize := cgByteSize; cgWord,cgUWord: TypeSize := cgWordSize; cgLong,cgULong: TypeSize := cgLongSize; cgReal: TypeSize := cgRealSize; cgDouble: TypeSize := cgDoubleSize; cgComp: TypeSize := cgCompSize; cgExtended: TypeSize := cgExtendedSize; cgString: TypeSize := cgByteSize; cgVoid,cgSet: TypeSize := cgLongSize; end; {case} end; {TypeSize} function LabelsMatch (op1, op2: icptr): boolean; { See if the labels from two instructions match } { } { parameters: } { op1, op2 - instructions to check } { } { Returns: True for match, otherwise false } begin {LabelsMatch} if (op1^.lab = nil) and (op2^.lab = nil) then LabelsMatch := op1^.q = op2^.q else if (op1^.lab <> nil) and (op2^.lab <> nil) then LabelsMatch := op1^.lab^ = op2^.lab^ else LabelsMatch := false; end; {LabelsMatch} procedure PeepHoleOptimization (var opv: icptr); { do peephole optimization on a list of opcodes } { } { parameters: } { opv - pointer to the first opcode } { } { Notes: } { 1. Many optimizations assume the children have already } { been optimized. In particular, many optimizations } { depend on pc_ldc operands being on a specific side of } { a child's expression tree. (e.g. pc_fjp and pc_equ) } var done: boolean; {optimization done test} doit: boolean; {should we do the optimization?} i,j: integer; {general work variables} lq, lval: longint; {temps for long calculations} op2,op3: icptr; {temp opcodes} op: icptr; {copy of op (for efficiency)} opcode: pcodes; {temp opcode} optype: baseTypeEnum; {temp optype} q: integer; {temp for integer calculations} rval: double; {temp for real calculations} set1,set2: setPtr; {work set pointer} fromtype, totype, firstType: record {for converting numbers to optypes} case boolean of true: (i: integer); false: (optype: baseTypeEnum); end; function IsUnsigned (op: icptr): boolean; { Check to see if the operand is unsigned } { } { parameters: } { op - opcode to check } begin {IsUnsigned} case op^.opcode of pc_abi, pc_abl, pc_equ, pc_geq, pc_grt, pc_lad, pc_lao, pc_lca, pc_lda, pc_leq, pc_les, pc_lla, pc_neq, pc_not, pc_odd, pc_odl, pc_sqi, pc_sql, pc_udi, pc_udl, pc_uim, pc_ulm, pc_umi, pc_uml, pc_usr, pc_vsr: IsUnsigned := true; pc_adi, pc_adl, pc_and, pc_ior, pc_lnd, pc_lor: IsUnsigned := IsUnsigned(op^.left) and IsUnsigned(op^.right); pc_cnv: IsUnsigned := (op^.q & $00F0 >> 4) in [ord(cgUByte), ord(cgUWord), ord(cgULong)]; pc_cop, pc_cpo, pc_cui, pc_cum, pc_cup, pc_ind, pc_ldo, pc_lod: IsUnsigned := op^.optype in [cgUByte, cgUWord, cgULong]; pc_inc: IsUnsigned := IsUnsigned(op^.left); pc_ldc: case op^.optype of cgByte, cgWord: IsUnsigned := op^.q >= 0; cgLong: IsUnsigned := op^.lval >= 0; cgUByte,cgUWord,cgULong: IsUnsigned := true; otherwise: IsUnsigned := false; end; otherwise: IsUnsigned := false; end; end; {IsUnsigned} function SideEffects (op: icptr): boolean; { Check a tree for operations that have side effects } { } { parameters: } { op - tree to check } var result: boolean; {temp result} begin {SideEffects} if op = nil then SideEffects := false else if op^.opcode in [pc_mov,pc_cop,pc_cpo,pc_sro,pc_sto,pc_str,pc_cui,pc_cup,pc_tl1, pc_tl1,pc_pds,pc_csp,pc_prs,pc_fix,pc_cum,pc_vct] then SideEffects := true else SideEffects := SideEffects(op^.left) or SideEffects(op^.right); end; {SideEffects} procedure MakeWordSet (op: icptr); { Convert the tree from set operations to equivalent word } { operations } { } { parameters: } { op - tree to convert } var c: record {conversion record} case boolean of true: (b1, b2: byte); false: (ival: integer); end; op2,op3: icptr; {temp opcodes} opcode: pcodes; {op^.opcode} begin {MakeWordSet} opcode := op^.opcode; if opcode = pc_ldc then begin op^.optype := cgUWord; c.ival := 0; if op^.setp^.smax <> 0 then begin c.b1 := ord(op^.setp^.sval[1]); if op^.setp^.smax <> 1 then c.b2 := ord(op^.setp^.sval[2]); end; {if} op^.setp := nil; op^.q := c.ival; end {if} else if opcode = pc_ldo then begin op^.optype := cgUWord; op^.q := op^.r; op^.r := 0; end {else if} else if opcode = pc_lod then begin op^.optype := cgUWord; op^.s := 0; end {else if} else if opcode = pc_sgs then begin op^.right^.q := 1; op2 := op^.left; op^.left := op^.right; op^.right := op2; op^.opcode := pc_shl; end {else if} else if opcode = pc_inn then begin MakeWordSet(op^.right); op2 := pointer(Calloc(sizeof(intermediate_code))); op2^.optype := cgUWord; op2^.opcode := pc_ldc; op2^.q := 1; op3 := pointer(Calloc(sizeof(intermediate_code))); op3^.optype := cgWord; op3^.opcode := pc_shl; op3^.left := op2; op3^.right := op^.left; op^.left := op3; op^.opcode := pc_bnd; end {else if} else if opcode = pc_dif then begin MakeWordSet(op^.left); MakeWordSet(op^.right); op2 := pointer(Calloc(sizeof(intermediate_code))); op2^.optype := cgWord; op2^.opcode := pc_bnt; op2^.left := op^.right; op^.right := op2; op^.opcode := pc_bnd; end {else if} else if opcode = pc_int then begin MakeWordSet(op^.left); MakeWordSet(op^.right); op^.opcode := pc_bnd; end {else if} else if opcode = pc_uni then begin MakeWordSet(op^.left); MakeWordSet(op^.right); op^.opcode := pc_bor; end; {else if} end; {MakeWordSet} function WordSet (op: icptr): boolean; { See if the tree consists entirely of set operations that } { can be converted to word operations } { } { parameters: } { op - tree to check } { } { Returns: True if so, false if not } var opcode: pcodes; {op^.opcode} begin {WordSet} opcode := op^.opcode; if opcode = pc_ldc then WordSet := op^.setp^.smax <= 2 else if opcode = pc_ldo then WordSet := op^.q = 2 else if opcode = pc_lod then WordSet := op^.s = 2 else if opcode in [pc_dif,pc_int,pc_uni] then WordSet := WordSet(op^.left) and WordSet(op^.right) else if opcode = pc_inn then WordSet := WordSet(op^.right) and IsUnsigned(op^.left) else if opcode = pc_sgs then if op^.right^.opcode = pc_ldc then WordSet := op^.right^.q = $8000 else WordSet := false else WordSet := false; end; {WordSet} procedure MakeLongSet (op: icptr); { Convert the tree from set operations to equivalent long } { operations } { } { parameters: } { op - tree to convert } var c: record {conversion record} case boolean of true: (b1, b2, b3, b4: byte); false: (lval: longint); end; op2,op3: icptr; {temp opcodes} opcode: pcodes; {op^.opcode} begin {MakeLongSet} opcode := op^.opcode; if opcode = pc_ldc then begin op^.optype := cgULong; c.lval := 0; if op^.setp^.smax <> 0 then begin c.b1 := ord(op^.setp^.sval[1]); if op^.setp^.smax <> 1 then begin c.b2 := ord(op^.setp^.sval[2]); if op^.setp^.smax <> 2 then begin c.b3 := ord(op^.setp^.sval[3]); if op^.setp^.smax <> 3 then c.b4 := ord(op^.setp^.sval[4]); end; {if} end; {if} end; {if} op^.setp := nil; op^.lval := c.lval; end {if} else if opcode = pc_ldo then begin op^.optype := cgULong; op^.q := op^.r; op^.r := 0; end {else if} else if opcode = pc_lod then begin op^.optype := cgULong; op^.s := 0; end {else if} else if opcode = pc_dif then begin MakeLongSet(op^.left); MakeLongSet(op^.right); op2 := pointer(Calloc(sizeof(intermediate_code))); op2^.optype := cgWord; op2^.opcode := pc_bnl; op2^.left := op^.right; op^.right := op2; op^.opcode := pc_bal; end {else if} else if opcode = pc_int then begin MakeLongSet(op^.left); MakeLongSet(op^.right); op^.opcode := pc_bal; end {else if} else if opcode = pc_uni then begin MakeLongSet(op^.left); MakeLongSet(op^.right); op^.opcode := pc_blr; end; {else if} end; {MakeLongSet} function LongSet (op: icptr): boolean; { See if the tree consists entirely of set operations that } { can be converted to long operations } { } { parameters: } { op - tree to check } { } { Returns: True if so, false if not } var opcode: pcodes; {op^.opcode} begin {LongSet} opcode := op^.opcode; if opcode = pc_ldc then LongSet := op^.setp^.smax <= 4 else if opcode = pc_ldo then LongSet := op^.q = 4 else if opcode = pc_lod then LongSet := op^.s = 4 else if opcode in [pc_dif,pc_int,pc_uni] then LongSet := LongSet(op^.left) and LongSet(op^.right) else LongSet := false; end; {LongSet} procedure JumpOptimizations (op: icptr; newOpcode: pcodes); { handle common code for jump optimizations } { } { parameters: } { op - jump opcode } { newOpcode - opcode to use if the jump sense is reversed } var done: boolean; {optimization done test} topcode: pcodes; {temp opcode} begin {JumpOptimizations} topcode := op^.left^.opcode; if topcode = pc_inn then if WordSet(op^.left) then begin MakeWordSet(op^.left); topcode := op^.left^.opcode; end; {if} if topcode = pc_not then begin op^.left := op^.left^.left; op^.opcode := newOpcode; PeepHoleOptimization(opv); end {else if} else if topcode in [pc_neq,pc_equ] then begin with op^.left^.right^ do if opcode = pc_ldc then if optype in [cgByte,cgUByte,cgWord,cgUWord] then if q = 0 then begin op^.left := op^.left^.left; if topcode = pc_equ then op^.opcode := newOpcode; end; {if} end; {else if} if op^.next^.opcode = dc_lab then if LabelsMatch(op^.next, op) then if not SideEffects(op^.left) then begin rescan := true; opv := op^.next; end; {else if} end; {JumpOptimizations} procedure RealStoreOptimizations (op, opl: icptr); { do strength reductions associated with stores of reals } { } { parameters: } { op - real store to optimize } { opl - load operand for the store operation } var disp: 0..9; {disp to the word to change} same: boolean; {are the operands the same?} op2: icptr; {new opcode} opt: icptr; {temp opcode} cnvrl: record {for stuffing a real in a long space} case boolean of true: (lval: longint); false: (rval: real); end; begin {RealStoreOptimizations} if opl^.opcode = pc_ngr then begin same := false; with opl^.left^ do if op^.opcode = pc_sro then begin if opcode = pc_ldo then if q = op^.q then if optype = op^.optype then if lab^ = op^.lab^ then same := true; end {if} else {if op^.opcode = pc_str then} if opcode = pc_lod then if q = op^.q then if r = op^.r then if optype = op^.optype then same := true; if same then begin case op^.optype of cgReal: disp := 3; cgDouble: disp := 7; cgExtended: disp := 9; cgComp: disp := 11; end; {case} opl^.left^.optype := cgWord; opl^.left^.q := opl^.left^.q + disp; op^.optype := cgWord; op^.q := op^.q + disp; op2 := pointer(Calloc(sizeof(intermediate_code))); op2^.opcode := pc_ldc; op2^.optype := cgWord; op2^.q := $0080; opl^.right := op2; opl^.opcode := pc_bxr; end {if} else if op^.optype = cgReal then begin opt := opl^.left; if opt^.opcode in [pc_ind,pc_ldo,pc_lod] then if opt^.optype = cgReal then begin opt^.optype := cgLong; op^.optype := cgLong; op2 := pointer(Calloc(sizeof(intermediate_code))); op2^.opcode := pc_ldc; op2^.optype := cgLong; op2^.lval := $80000000; opl^.right := op2; opl^.opcode := pc_blx; end; {if} end; {else if} end {if} else if op^.optype = cgReal then begin if opl^.opcode = pc_ldc then begin cnvrl.rval := opl^.rval; opl^.lval := cnvrl.lval; opl^.optype := cgLong; op^.optype := cgLong; end {if} else if opl^.opcode in [pc_ind,pc_ldo,pc_lod] then if opl^.optype = cgReal then begin opl^.optype := cgLong; op^.optype := cgLong; end; {if} end; {if} end; {RealStoreOptimizations} procedure ReplaceLoads (ldop, stop, tree: icptr); { Replace any pc_lod operations in tree that load from the } { location stored to by the pc_str operation stop by ldop } { } { parameters: } { ldop - operation to replace the pc_lods with } { stop - pc_str operation } { tree - tree to check for pc_lod operations } { } { Notes: ldop must be an instruction, not a tree } begin {ReplaceLoads} if tree^.left <> nil then ReplaceLoads(ldop, stop, tree^.left); if tree^.right <> nil then ReplaceLoads(ldop, stop, tree^.right); if tree^.opcode = pc_lod then if tree^.optype = stop^.optype then if tree^.q = stop^.q then if tree^.r = stop^.r then tree^ := ldop^; end; {ReplaceLoads} procedure ReverseChildren (op: icptr); { reverse the children of a node } { } { parameters: } { op - node for which to reverse the children } var opt: icptr; {temp opcode pointer} begin {ReverseChildren} opt := op^.right; op^.right := op^.left; op^.left := opt; end; {ReverseChildren} procedure ZeroIntermediateCode (op: icptr); { Set all fields in the record to 0, nil, etc. } { } { Parameters: } { op - intermediate code record to clear } begin {ZeroIntermediateCode} op^.q := 0; op^.r := 0; op^.s := 0; op^.lab := nil; op^.next := nil; op^.left := nil; op^.right := nil; op^.optype := cgWord; op^.opnd := 0; op^.llab := 0; op^.slab := 0; end; {ZeroIntermediateCode} begin {PeepHoleOptimization} if peepSpin = 0 then begin {spinner} peepSpin := peepSpinRate; Spin; end {if} else peepSpin := peepSpin-1; {if printSymbols then begin write('Optimize: '); WriteCode(opv); end; {debug} op := opv; {copy for efficiency} if op^.left <> nil then {optimize the children} PeepHoleOptimization(op^.left); if op^.right <> nil then PeepHoleOptimization(op^.right); case op^.opcode of {check for optimizations of this node} pc_add: begin {pc_add} if op^.next^.opcode <> pc_add then RemoveDeadCode(op); end; {case pc_add} pc_adi: begin {pc_adi} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin op^.left^.q := op^.left^.q + op^.right^.q; opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin q := op^.right^.q; if q = 0 then opv := op^.left else if q > 0 then begin op^.opcode := pc_inc; op^.q := q; op^.right := nil; end {else if} else {if q < 0 then} begin op^.opcode := pc_dec; op^.q := -q; op^.right := nil; end; {else if} end {if} else if op^.left^.opcode in [pc_inc,pc_dec] then begin if op^.right^.opcode in [pc_inc,pc_dec] then begin op2 := op^.left; if op^.left^.opcode = pc_inc then q := op^.left^.q else q := -op^.left^.q; if op^.right^.opcode = pc_inc then q := q + op^.right^.q else q := q - op^.right^.q; if q >= 0 then begin op2^.opcode := pc_inc; op2^.q := q; end {if} else begin op2^.opcode := pc_dec; op2^.q := -q; end; {else} op^.left := op^.left^.left; op^.right := op^.right^.left; op2^.left := op; opv := op2; PeepHoleOptimization(opv); end; {if} end {else if} else if CodesMatch(op^.left, op^.right, false) then begin if NoFunctions(op^.left) then begin ZeroIntermediateCode(op^.right); with op^.right^ do begin opcode := pc_ldc; q := 1; optype := cgWord; end; {with} op^.opcode := pc_shl; PeepHoleOptimization(opv); end; {if} end; {else if} end; {else} end; {case pc_adi} pc_adl: begin {pc_adl} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin op^.left^.lval := op^.left^.lval + op^.right^.lval; opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin lval := op^.right^.lval; if lval = 0 then opv := op^.left else if (lval >= 0) and (lval <= maxint) then begin op^.opcode := pc_inc; op^.optype := cgLong; op^.q := ord(lval); op^.right := nil; end {else if} else if (lval > -maxint) and (lval < 0) then begin op^.opcode := pc_dec; op^.optype := cgLong; op^.q := -ord(lval); op^.right := nil; end; {else if} end {if} else if CodesMatch(op^.left, op^.right, false) then if NoFunctions(op^.left) then begin ZeroIntermediateCode(op^.right); with op^.right^ do begin opcode := pc_ldc; lval := 1; optype := cgLong; end; {with} op^.opcode := pc_sll; end; {if} if op^.right^.opcode in [pc_lao,pc_lda,pc_ixa] then ReverseChildren(op); if op^.left^.opcode in [pc_lao,pc_lda,pc_ixa] then if op^.right^.opcode = pc_sll then begin if op^.right^.right^.opcode = pc_ldc then if (op^.right^.right^.lval & $FFFF8000) = 0 then if op^.right^.left^.opcode = pc_cnv then begin fromtype.i := (op^.right^.left^.q & $00F0) >> 4; if fromType.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin if fromType.optype = cgByte then op^.right^.left^.q := $02 else if fromType.optype = cgUByte then op^.right^.left^.q := $13 else op^.right^.left := op^.right^.left^.left; with op^.right^.right^ do begin lq := lval; lval := 0; q := long(lq).lsw; optype := cgUWord; end; {with} op^.right^.opcode := pc_shl; op^.opcode := pc_ixa; PeepHoleOptimization(opv); end; {if} end; {if} end {if} else if op^.right^.opcode = pc_cnv then begin fromtype.i := (op^.right^.q & $00F0) >> 4; if fromtype.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin if fromType.optype = cgByte then op^.right^.q := $02 else if fromType.optype = cgUByte then op^.right^.q := $13 else op^.right := op^.right^.left; op^.opcode := pc_ixa; PeepHoleOptimization(opv); end; {if} end; {else if} end; {else} end; {case pc_adl} pc_adr: begin {pc_adr} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin op^.left^.rval := op^.left^.rval + op^.right^.rval; opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin if op^.right^.rval = 0.0 then opv := op^.left; end; {if} end; {else} end; {case pc_adr} pc_and: begin {pc_and} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin op^.left^.q := ord((op^.left^.q <> 0) and (op^.right^.q <> 0)); opv := op^.left; end {if} else begin if op^.right^.q = 0 then if not SideEffects(op^.left) then opv := op^.right; end {else} end {if} else if op^.left^.opcode = pc_ldc then if op^.left^.q = 0 then opv := op^.left; end; {case pc_and} pc_bal: begin {pc_bal} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.lval := op^.left^.lval & op^.right^.lval; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.lval = 0 then opv := op^.right else if op^.right^.lval = -1 then opv := op^.left; end; {else if} end; {case pc_bal} pc_blr: begin {pc_blr} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.lval := op^.left^.lval | op^.right^.lval; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.lval = -1 then opv := op^.right else if op^.right^.lval = 0 then opv := op^.left; end; {else if} end; {case pc_blr} pc_blx: begin {pc_blx} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.lval := op^.left^.lval ! op^.right^.lval; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.lval = 0 then opv := op^.left else if op^.right^.lval = -1 then begin op^.opcode := pc_bnl; op^.right := nil; end; {else if} end; {else if} end; {case pc_blx} pc_bnd: begin {pc_bnd} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.q := op^.left^.q & op^.right^.q; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.q = 0 then opv := op^.right else if op^.right^.q = -1 then opv := op^.left; end; {else if} end; {case pc_bnd} pc_bnl: begin {pc_bnl} if op^.left^.opcode = pc_ldc then begin op^.left^.lval := op^.left^.lval ! $FFFFFFFF; opv := op^.left; end; {if} end; {case pc_bnl} pc_bno: begin {pc_bno} if op^.left^.opcode = pc_str then if op^.left^.left^.opcode in [pc_lda,pc_lao] then begin ReplaceLoads(op^.left^.left, op^.left, op^.right); opv := op^.right; end; {if} end; {case pc_bno} pc_bnt: begin {pc_bnt} if op^.left^.opcode = pc_ldc then begin op^.left^.q := op^.left^.q ! $FFFF; opv := op^.left; end; {if} end; {case pc_bnt} pc_bor: begin {pc_bor} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.q := op^.left^.q | op^.right^.q; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.q = -1 then opv := op^.right else if op^.right^.q = 0 then opv := op^.left; end; {else if} end; {case pc_bor} pc_bxr: begin {pc_bxr} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.q := op^.left^.q ! op^.right^.q; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.q = 0 then opv := op^.left else if op^.right^.q = -1 then begin op^.opcode := pc_bnt; op^.right := nil; end; {else if} end; {else if} end; {case pc_bxr} pc_cnv: begin {pc_cnv} fromtype.i := (op^.q & $00F0) >> 4; totype.i := op^.q & $000F; if op^.left^.opcode = pc_ldc then begin case fromtype.optype of cgByte,cgWord: case totype.optype of cgByte,cgUByte,cgWord,cgUWord: ; cgLong,cgULong: begin lval := op^.left^.q; op^.left^.q := 0; op^.left^.lval := lval; end; cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.q; op^.left^.q := 0; op^.left^.rval := rval; end; otherwise: ; end; {case} cgUByte,cgUWord: case totype.optype of cgByte,cgUByte,cgWord,cgUWord: ; cgLong,cgULong: begin lval := ord4(op^.left^.q) & $0000FFFF; op^.left^.q := 0; op^.left^.lval := lval; end; cgReal,cgDouble,cgComp,cgExtended: begin rval := ord4(op^.left^.q) & $0000FFFF; op^.left^.q := 0; op^.left^.rval := rval; end; otherwise: ; end; {case} cgLong: case totype.optype of cgByte,cgUByte,cgWord,cgUWord: begin q := long(op^.left^.lval).lsw; op^.left^.lval := 0; op^.left^.q := q; end; cgLong, cgULong: ; cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.lval; op^.left^.lval := 0; op^.left^.rval := rval; end; otherwise: ; end; {case} cgULong: case totype.optype of cgByte,cgUByte,cgWord,cgUWord: begin q := long(op^.left^.lval).lsw; op^.left^.lval := 0; op^.left^.q := q; end; cgLong, cgULong: ; cgReal,cgDouble,cgComp,cgExtended: begin lval := op^.left^.lval; op^.left^.lval := 0; if lval >= 0 then rval := lval else rval := (lval & $7FFFFFFF) + 2147483648.0; op^.left^.rval := rval; end; otherwise: ; end; {case} cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.rval; case totype.optype of cgByte: begin if rval < -128.0 then q := -128 else if rval > 127.0 then q := 127 else q := trunc(rval); op^.left^.rval := 0.0; op^.left^.q := q; end; cgUByte: begin if rval < 0.0 then q := 0 else if rval > 255.0 then q := 255 else q := trunc(rval); op^.left^.rval := 0.0; op^.left^.q := q; end; cgWord: begin if rval < -32768.0 then lval := -32768 else if rval > 32767.0 then lval := 32767 else lval := trunc(rval); op^.left^.rval := 0.0; op^.left^.q := long(lval).lsw; end; cgUWord: begin if rval < 0.0 then lval := 0 else if rval > 65535.0 then lval := 65535 else lval := trunc4(rval); op^.left^.rval := 0.0; op^.left^.q := long(lval).lsw; end; cgLong,cgULong: begin if totype.optype = cgULong then begin if rval < 0 then rval := 0 else if rval > 2147483647.0 then rval := rval - 4294967296.0 end; {if} if rval < -2147483648.0 then lval := $80000000 else if rval > 2147483647.0 then lval := 2147483647 else lval := trunc4(rval); op^.left^.rval := 0.0; op^.left^.lval := lval; end; cgReal,cgDouble,cgComp,cgExtended: ; otherwise: ; end; end; {case} otherwise: ; end; {case} if fromtype.optype in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble, cgComp,cgExtended] then if totype.optype in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble, cgComp,cgExtended] then begin op^.left^.optype := totype.optype; opv := op^.left; end; {if} end {if} else if op^.left^.opcode = pc_cnv then begin doit := false; firsttype.i := (op^.q & $00F0) >> 4; if fromType.optype in [cgReal,cgDouble,cgComp,cgExtended] then begin if toType.optype in [cgReal,cgDouble,cgComp,cgExtended] then doit := true; end {if} else begin if firstType.optype in [cgByte,cgWord,cgLong] then if fromType.optype in [cgByte,cgWord,cgLong] then if toType.optype in [cgByte,cgWord,cgLong] then doit := true; if firstType.optype in [cgUByte,cgUWord,cgULong] then if fromType.optype in [cgUByte,cgUWord,cgULong] then if toType.optype in [cgUByte,cgUWord,cgLong] then doit := true; if TypeSize(firstType.optype) = TypeSize(fromType.optype) then if TypeSize(firstType.optype) = TypeSize(toType.optype) then doit := true; end; {else} if doit then begin op^.q := (op^.left^.q & $00F0) | (op^.q & $000F); op^.left := op^.left^.left; PeepHoleOptimization(opv); end; {if} end {else if} else if op^.left^.opcode in [pc_lod,pc_ldo,pc_ind] then begin if fromtype.optype in [cgWord,cgUWord] then if totype.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin op^.left^.optype := totype.optype; opv := op^.left; end; {if} if fromtype.optype in [cgLong,cgULong] then if totype.optype in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong] then begin op^.left^.optype := totype.optype; opv := op^.left; end; {if} end {else if} else if op^.q in [$40,$41,$50,$51] then begin {any long type to byte type} with op^.left^ do if opcode = pc_bal then if right^.opcode = pc_ldc then if right^.lval = 255 then begin op^.left := op^.left^.left; PeepHoleOptimization(opv); end; {if} with op^.left^ do if opcode in [pc_slr,pc_vsr] then if right^.opcode = pc_ldc then if left^.opcode in [pc_lod,pc_ldo,pc_ind] then begin lq := right^.lval; if long(lq).msw = 0 then if long(lq).lsw in [8,16,24] then begin lq := lq div 8; left^.q := left^.q + long(lq).lsw; op^.left := left; PeepHoleOptimization(opv); end; {if} end; {if} end; {else if} end; {case pc_cnv} pc_csp: begin {pc_csp} if op^.q = 91 then begin {string move} op2 := op^.left^.left^.right^.left; op3 := op^.left^.right^.right^.left; if op2^.opcode = pc_ldc then if op3^.opcode = pc_ldc then if op2^.q = op3^.q then begin q := op2^.q; if q < -1 then q := 1-q; if q > 0 then begin op^.opcode := pc_mov; op^.right := op^.left^.right^.left^.left; op^.left := op^.left^.left^.left^.left; op^.q := q; op^.r := 0; PeepHoleOptimization(opv); end; {if} end; {if} end {if} else if op^.next <> nil then if op^.next^.opcode = pc_csp then if op^.next^.q = 26 then begin if op^.q in [16,19,21,29,37] then begin if op^.q = 16 then op^.q := 34 else if op^.q = 19 then op^.q := 12 else op^.q := op^.q-1; op^.next := op^.next^.next; end; {if} end {if} else if op^.next^.q = 27 then begin if op^.q in [39,42,25,31,23] then begin if op^.q = 42 then op^.q := 43 else op^.q := op^.q-1; op^.next := op^.next^.next; end; {if} end; {else if} end; {case pc_csp} pc_dec: begin {pc_dec} if op^.q = 0 then opv := op^.left else begin opcode := op^.left^.opcode; if opcode = pc_dec then begin if ord4(op^.left^.q) + ord4(op^.q) < ord4(maxint) then begin op^.q := op^.q + op^.left^.q; op^.left := op^.left^.left; end; {if} end {if} else if opcode = pc_inc then begin q := op^.q - op^.left^.q; if q < 0 then begin q := -q; op^.opcode := pc_inc; end; {if} op^.q := q; op^.left := op^.left^.left; PeepHoleOptimization(opv); end {else if} else if opcode = pc_ldc then begin if op^.optype in [cgLong, cgULong] then begin op^.left^.lval := op^.left^.lval - op^.q; opv := op^.left; end {if} else if op^.optype in [cgUByte, cgByte, cgUWord, cgWord] then begin op^.left^.q := op^.left^.q - op^.q; opv := op^.left; end; {else if} end; {else if} end; {else} end; {case pc_dec} pc_dvi: begin {pc_dvi} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin if op^.right^.q <> 0 then begin op^.left^.q := op^.left^.q div op^.right^.q; opv := op^.left; end; {if} end {if} else if op^.right^.q = 1 then opv := op^.left; end {if} else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin op^.opcode := pc_udi; PeepHoleOptimization(opv); end; {else if} end; {case pc_dvi} pc_dvl: begin {pc_dvl} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin if op^.right^.lval <> 0 then begin op^.left^.lval := op^.left^.lval div op^.right^.lval; opv := op^.left; end; {if} end {if} else if op^.right^.lval = 1 then opv := op^.left; end {if} else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin op^.opcode := pc_udl; PeepHoleOptimization(opv); end; {else if} end; {case pc_dvl} pc_dvr: begin {pc_dvr} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin if op^.right^.rval <> 0.0 then begin op^.left^.rval := op^.left^.rval/op^.right^.rval; opv := op^.left; end; {if} end {if} else if op^.right^.rval = 1.0 then opv := op^.left; end; {if} end; {case pc_dvr} pc_equ: begin {pc_equ} if op^.optype = cgSet then if WordSet(op^.left) then begin if WordSet(op^.right) then begin MakeWordSet(op^.left); MakeWordSet(op^.right); op^.optype := cgUWord; end; {if} end {if} else if LongSet(op^.left) then if LongSet(op^.right) then begin MakeLongSet(op^.left); MakeLongSet(op^.right); op^.optype := cgULong; end; {if} if IsUnsigned(op^.left) and IsUnsigned(op^.right) then if op^.optype = cgWord then op^.optype := cgUWord else if op^.optype = cgLong then op^.optype := cgULong else if op^.optype = cgByte then op^.optype := cgUByte; if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin BinOps(op^.left, op^.right); case op^.left^.optype of cgByte,cgUByte,cgWord,cgUWord: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.q = op^.right^.q); op^.left := nil; op^.right := nil; end; cgLong,cgULong: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.lval = op^.right^.lval); op^.left := nil; op^.right := nil; end; cgReal,cgDouble,cgComp,cgExtended: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.rval = op^.right^.rval); op^.left := nil; op^.right := nil; end; cgSet: begin op^.opcode := pc_ldc; op^.q := ord(SetsEqual(op^.left^.setp, op^.right^.setp)); op^.left := nil; op^.right := nil; end; cgVoid: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.pval = op^.right^.pval); op^.left := nil; op^.right := nil; end; end; {case} op^.optype := cgUWord; end {if} else if op^.right^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin if op^.right^.q <> 0 then if op^.left^.opcode in [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt] then begin opv := op^.left; opv^.next := op^.next; end; {if} end {else if} else if op^.right^.optype in [cgLong, cgULong] then begin if op^.right^.lval <> 0 then if op^.left^.opcode in [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt] then begin opv := op^.left; opv^.next := op^.next; end; {if} end; {else if} end; {if} end; {case pc_equ} pc_fjp: begin {pc_fjp} opcode := op^.left^.opcode; if opcode = pc_ldc then begin if op^.left^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin if op^.left^.q <> 0 then begin opv := op^.next; rescan := true; end {if} else begin op^.opcode := pc_ujp; op^.left := nil; PeepHoleOptimization(opv); end; {else} end {if} end {if} else if opcode = pc_and then begin op2 := op^.left; op2^.next := op^.next; op^.next := op2; op^.left := op2^.left; op2^.left := op2^.right; op2^.right := nil; op2^.opcode := pc_fjp; op2^.q := op^.q; PeepHoleOptimization(opv); end {else if} else if opcode = pc_ior then begin op2 := op^.left; op2^.next := op^.next; op^.next := op2; op^.left := op2^.left; op2^.left := op2^.right; op2^.right := nil; op2^.opcode := pc_fjp; op2^.q := op^.q; op^.opcode := pc_tjp; op3 := pointer(Calloc(sizeof(intermediate_code))); op3^.opcode := dc_lab; op3^.optype := cgWord; op3^.q := GenLabel; op3^.next := op2^.next; op2^.next := op3; op^.q := op3^.q; PeepHoleOptimization(opv); end {else if} else JumpOptimizations(op, pc_tjp); end; {case pc_fjp} pc_geq,pc_grt,pc_les: {pc_geq, pc_grt, pc_les} if IsUnsigned(op^.left) and IsUnsigned(op^.right) then if op^.optype = cgWord then op^.optype := cgUWord else if op^.optype = cgLong then op^.optype := cgULong else if op^.optype = cgByte then op^.optype := cgUByte; pc_inc: begin {pc_inc} if op^.q = 0 then opv := op^.left else begin opcode := op^.left^.opcode; if opcode = pc_inc then begin if ord4(op^.left^.q) + ord4(op^.q) < ord4(maxint) then begin op^.q := op^.q + op^.left^.q; op^.left := op^.left^.left; end; {if} end {if} else if opcode = pc_dec then begin q := op^.q - op^.left^.q; if q < 0 then begin q := -q; op^.opcode := pc_dec; end; {if} op^.q := q; op^.left := op^.left^.left; PeepHoleOptimization(opv); end {else if} else if opcode = pc_ldc then begin if op^.optype in [cgLong, cgULong] then begin op^.left^.lval := op^.left^.lval + op^.q; opv := op^.left; end {if} else if op^.optype in [cgUByte, cgByte, cgUWord, cgWord] then begin op^.left^.q := op^.left^.q + op^.q; opv := op^.left; end; {else if} end {else if} else if opcode in [pc_lao,pc_lda] then begin op^.left^.q := op^.left^.q + op^.q; opv := op^.left; end; {else if} end; {else} end; {case pc_inc} pc_ind: begin {pc_ind} if op^.optype <> cgSet then begin opcode := op^.left^.opcode; if opcode = pc_lda then begin op^.left^.opcode := pc_lod; op^.left^.optype := op^.optype; op^.left^.q := op^.left^.q + op^.q; op^.left^.r := op^.left^.s; op^.left^.s := 0; opv := op^.left; end {if} else if opcode = pc_lao then begin op^.left^.opcode := pc_ldo; op^.left^.optype := op^.optype; op^.left^.q := op^.left^.q + op^.q; opv := op^.left; end; {else if} end; {if} end; {case pc_ind} pc_int: begin {pc_int} if op^.left^.opcode = pc_ldc then if op^.right^.opcode = pc_ldc then begin if op^.left^.setp^.smax > op^.right^.setp^.smax then ReverseChildren(op); set1 := op^.left^.setp; set2 := op^.right^.setp; for i := 1 to set1^.smax do set1^.sval[i] := chr(ord(set1^.sval[i]) & ord(set2^.sval[i])); i := set1^.smax; while (i <> 1) and (ord(set1^.sval[i]) = 0) do i := i-1; set1^.smax := i; opv := op^.left; end; {if} end; {case pc_int} pc_ior: begin {pc_ior} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin op^.left^.q := ord((op^.left^.q <> 0) or (op^.right^.q <> 0)); opv := op^.left; end {if} else begin if op^.right^.q <> 0 then begin if not SideEffects(op^.left) then begin op^.right^.q := 1; opv := op^.right; end; {if} end {if} else op^.opcode := pc_neq; end {if} end {if} else if op^.left^.opcode = pc_ldc then if op^.left^.q <> 0 then begin op^.left^.q := 1; opv := op^.left; end; {if} end; {case pc_ior} pc_ixa: begin {pc_ixa} if op^.right^.opcode = pc_ldc then begin optype := op^.right^.optype; if optype in [cgUByte, cgByte, cgUWord, cgWord] then begin lval := op^.right^.q; if optype = cgUByte then lval := lval & $000000FF else if optype = cgUWord then lval := lval & $0000FFFF; done := false; if op^.left^.opcode in [pc_lao, pc_lda] then begin lq := op^.left^.q + lval; if (lq >= 0) and (lq < maxint) then begin done := true; op^.left^.q := ord(lq); opv := op^.left; end; {if} end; {if} if not done then begin op^.right^.lval := lval; op^.right^.optype := cgLong; op^.opcode := pc_adl; PeepHoleOptimization(opv); end; {if} end; {if} end {if} else if op^.left^.opcode = pc_lao then begin if op^.right^.opcode = pc_inc then begin lq := ord4(op^.right^.q) + ord4(op^.left^.q); if lq < maxint then begin op^.left^.q := ord(lq); op^.right := op^.right^.left; end; {if} PeepHoleOptimization(opv); end; {if} end {else if} else if op^.left^.opcode = pc_ixa then begin op2 := op^.left; op^.left := op^.left^.left; op2^.left := op^.right; op2^.opcode := pc_adi; op^.right := op2; end; {else if} end; {case pc_ixa} pc_leq: begin {pc_leq} if IsUnsigned(op^.left) and IsUnsigned(op^.right) then if op^.optype = cgWord then op^.optype := cgUWord else if op^.optype = cgLong then op^.optype := cgULong else if op^.optype = cgByte then op^.optype := cgUByte; if op^.optype in [cgWord,cgUWord] then if op^.right^.opcode = pc_ldc then if op^.right^.q < maxint then begin op^.right^.q := op^.right^.q + 1; op^.opcode := pc_les; end; {if} end; {case pc_lnm} pc_lnd: begin {pc_lnd} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin op^.left^.q := ord((op^.left^.lval <> 0) and (op^.right^.lval <> 0)); op^.left^.optype := cgWord; opv := op^.left; end {if} else begin if op^.right^.lval = 0 then begin if not SideEffects(op^.left) then begin with op^.right^ do begin lval := 0; optype := cgWord; q := 0; end; {with} opv := op^.right; end; {if} end {if} else op^.opcode := pc_neq; end; {if} end {if} else if op^.left^.opcode = pc_ldc then if op^.left^.lval = 0 then begin with op^.left^ do begin lval := 0; optype := cgWord; q := 0; end; {with} opv := op^.left; end; {if} end; {case pc_lnd} pc_lnm: begin {pc_lnm} if op^.next^.opcode = pc_lnm then begin opv := op^.next; rescan := true; end; {if} end; {case pc_lnm} pc_lor: begin {pc_lor} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin op^.left^.q := ord((op^.left^.lval <> 0) or (op^.right^.lval <> 0)); optype := cgWord; opv := op^.left; end {if} else begin if op^.right^.lval <> 0 then begin if not SideEffects(op^.left) then begin op^.right^.lval := 0; op^.right^.q := 1; op^.right^.optype := cgWord; opv := op^.right; end; {if} end {if} else begin op^.opcode := pc_neq; op^.optype := cgLong; end; {else} end; {if} end {if} else if op^.left^.opcode = pc_ldc then if op^.left^.lval <> 0 then begin op^.left^.lval := 0; op^.left^.q := 1; op^.left^.optype := cgWord; opv := op^.left; end; {if} end; {case pc_lor} pc_mdl: begin {pc_mdl} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then if op^.right^.lval <> 0 then begin op^.left^.lval := op^.left^.lval mod op^.right^.lval; opv := op^.left; end; {if} end {if} else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin op^.opcode := pc_ulm; PeepHoleOptimization(opv); end; {else if} end; {case pc_mdl} pc_mod: begin {pc_mod} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then if op^.right^.q <> 0 then begin op^.left^.q := op^.left^.q mod op^.right^.q; opv := op^.left; end; {if} end {if} else if IsUnsigned(op^.left) and IsUnsigned(op^.right) then begin op^.opcode := pc_uim; PeepHoleOptimization(opv); end; {else if} end; {case pc_mod} pc_mpi, pc_umi: begin {pc_mpi, pc_umi} if IsUnsigned(op^.left) and IsUnsigned(op^.right) then op^.opcode := pc_umi; if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin if op^.opcode = pc_mpi then op^.left^.q := op^.left^.q*op^.right^.q else {if op^.opcode = pc_umi then} begin lval := umul(op^.left^.q & $0000FFFF, op^.right^.q & $0000FFFF); op^.left^.q := long(lval).lsw; end; {else} opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin q := op^.right^.q; if q = 1 then opv := op^.left else if q = 0 then begin if NoFunctions(op^.left) then opv := op^.right; end {else if} else if (q = -1) and (op^.opcode = pc_mpi) then begin op^.opcode := pc_ngi; op^.right := nil; end {else if} else if OneBit(q) then begin op^.right^.q := Base(q); op^.opcode := pc_shl; PeepHoleOptimization(opv); end; {else if} end; {if} end; {else} end; {case pc_mpi, pc_umi} pc_mpl, pc_uml: begin {pc_mpl, pc_uml} if IsUnsigned(op^.left) and IsUnsigned(op^.right) then op^.opcode := pc_uml; if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin if op^.opcode = pc_mpl then op^.left^.lval := op^.left^.lval*op^.right^.lval else {if op^.opcode = pc_uml then} op^.left^.lval := umul(op^.left^.lval, op^.right^.lval); opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin lval := op^.right^.lval; if lval = 1 then opv := op^.left else if lval = 0 then begin if NoFunctions(op^.left) then opv := op^.right; end {else if} else if (lval = -1) and (op^.opcode = pc_mpl) then begin op^.opcode := pc_ngl; op^.right := nil; end {else if} else if OneBit(lval) then begin op^.right^.lval := Base(lval); op^.opcode := pc_sll; end; {else if} end; {if} end; {else} end; {case pc_mpl, pc_uml} pc_mpr: begin {pc_mpr} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin op^.left^.rval := op^.left^.rval*op^.right^.rval; opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin rval := op^.right^.rval; if rval = 1.0 then opv := op^.left else if rval = 0.0 then if NoFunctions(op^.left) then opv := op^.right; end; {if} end; {else} end; {case pc_mpr} pc_neq: begin {pc_neq} if op^.optype = cgSet then if WordSet(op^.left) then begin if WordSet(op^.right) then begin MakeWordSet(op^.left); MakeWordSet(op^.right); op^.optype := cgUWord; end; {if} end {if} else if LongSet(op^.left) then if LongSet(op^.right) then begin MakeLongSet(op^.left); MakeLongSet(op^.right); op^.optype := cgULong; end; {if} if IsUnsigned(op^.left) and IsUnsigned(op^.right) then if op^.optype = cgWord then op^.optype := cgUWord else if op^.optype = cgLong then op^.optype := cgULong else if op^.optype = cgByte then op^.optype := cgUByte; if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin BinOps(op^.left, op^.right); case op^.left^.optype of cgByte,cgUByte,cgWord,cgUWord: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.q <> op^.right^.q); op^.left := nil; op^.right := nil; end; cgLong,cgULong: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.lval <> op^.right^.lval); op^.left := nil; op^.right := nil; end; cgReal,cgDouble,cgComp,cgExtended: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.rval <> op^.right^.rval); op^.left := nil; op^.right := nil; end; cgSet: begin op^.opcode := pc_ldc; op^.q := ord(not SetsEqual(op^.left^.setp, op^.right^.setp)); op^.left := nil; op^.right := nil; end; cgVoid: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.pval <> op^.right^.pval); op^.left := nil; op^.right := nil; end; end; {case} op^.optype := cgUWord; end {if} else if op^.right^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin if op^.right^.q = 0 then if op^.left^.opcode in [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt] then begin opv := op^.left; opv^.next := op^.next; end; {if} end {else if} else if op^.right^.optype in [cgLong, cgULong] then begin if op^.right^.lval = 0 then if op^.left^.opcode in [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt] then begin opv := op^.left; opv^.next := op^.next; end; {if} end; {else if} end; {if} end; {case pc_neq} pc_ngi: begin {pc_ngi} if op^.left^.opcode = pc_ldc then begin op^.left^.q := -op^.left^.q; op^.left^.optype := cgWord; opv := op^.left; end; {if} end; {case pc_ngi} pc_ngl: begin {pc_ngl} if op^.left^.opcode = pc_ldc then begin op^.left^.lval := -op^.left^.lval; op^.left^.optype := cgLong; opv := op^.left; end; {if} end; {case pc_ngl} pc_ngr: begin {pc_ngr} if op^.left^.opcode = pc_ldc then begin op^.left^.rval := -op^.left^.rval; opv := op^.left; end; {if} end; {case pc_ngr} pc_not: begin {pc_not} opcode := op^.left^.opcode; if opcode = pc_ldc then begin if op^.left^.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin op^.left^.q := ord(op^.left^.q = 0); opv := op^.left; end {if} else if op^.left^.optype in [cgLong,cgULong] then begin q := ord(op^.left^.lval = 0); lval := 0; op^.left^.q := q; op^.left^.optype := cgWord; opv := op^.left; end; {else if} end {if} else if opcode = pc_equ then begin op^.left^.opcode := pc_neq; opv := op^.left; end {else if} else if opcode = pc_neq then begin op^.left^.opcode := pc_equ; opv := op^.left; end {else if} else if opcode = pc_geq then begin if op^.left^.optype <> cgSet then begin op^.left^.opcode := pc_les; opv := op^.left; end; {if} end {else if} else if opcode = pc_grt then begin op^.left^.opcode := pc_leq; opv := op^.left; end {else if} else if opcode = pc_les then begin op^.left^.opcode := pc_geq; opv := op^.left; end {else if} else if opcode = pc_leq then begin if op^.left^.optype <> cgSet then begin op^.left^.opcode := pc_grt; opv := op^.left; end; {if} end; {else if} end; {case pc_not} pc_ret: begin {pc_ret} RemoveDeadCode(op); end; {case pc_ret} pc_sbi: begin {pc_sbi} if op^.left^.opcode = pc_ldc then begin if op^.right^.opcode = pc_ldc then begin op^.left^.q := op^.left^.q - op^.right^.q; opv := op^.left; end {if} else if op^.left^.q = 0 then begin op^.opcode := pc_ngi; op^.left := op^.right; op^.right := nil; end; {else if} end {if} else if op^.right^.opcode = pc_ldc then begin q := op^.right^.q; if q = 0 then opv := op^.left else if (q > 0) then begin op^.opcode := pc_dec; op^.q := q; op^.right := nil; end {else if} else {if q < 0) then} begin op^.opcode := pc_inc; op^.q := -q; op^.right := nil; end; {else if} end {if} else if op^.left^.opcode in [pc_inc,pc_dec] then if op^.right^.opcode in [pc_inc,pc_dec] then begin op2 := op^.left; if op^.left^.opcode = pc_inc then q := op^.left^.q else q := -op^.left^.q; if op^.right^.opcode = pc_inc then q := q - op^.right^.q else q := q + op^.right^.q; if q >= 0 then begin op2^.opcode := pc_inc; op2^.q := q; end {if} else begin op2^.opcode := pc_dec; op2^.q := -q; end; {else} op^.left := op^.left^.left; op^.right := op^.right^.left; op2^.left := op; opv := op2; PeepHoleOptimization(opv); end; {if} end; {case pc_sbi} pc_sbl: begin {pc_sbl} if op^.left^.opcode = pc_ldc then begin if op^.right^.opcode = pc_ldc then begin op^.left^.lval := op^.left^.lval - op^.right^.lval; opv := op^.left; end {if} else if op^.left^.lval = 0 then begin op^.opcode := pc_ngl; op^.left := op^.right; op^.right := nil; end; {else if} end {if} else if op^.right^.opcode = pc_ldc then begin lval := op^.right^.lval; if lval = 0 then opv := op^.left else if (lval > 0) and (lval <= maxint) then begin op^.opcode := pc_dec; op^.q := ord(lval); op^.right := nil; op^.optype := cgLong; end {else if} else if (lval > -maxint) and (lval < 0) then begin op^.opcode := pc_inc; op^.q := -ord(lval); op^.right := nil; op^.optype := cgLong; end; {else if} end; {if} end; {case pc_sbl} pc_sbr: begin {pc_sbr} if op^.left^.opcode = pc_ldc then begin if op^.right^.opcode = pc_ldc then begin op^.left^.rval := op^.left^.rval - op^.right^.rval; opv := op^.left; end {if} else if op^.left^.rval = 0.0 then begin op^.opcode := pc_ngr; op^.left := op^.right; op^.right := nil; end; {else if} end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.rval = 0.0 then opv := op^.left; end; {if} end; {case pc_sbr} pc_sgs: begin {pc_sgs} if op^.left^.opcode = pc_ldc then if op^.right^.opcode = pc_ldc then begin set1 := pointer(Calloc(sizeof(setRecord))); q := op^.right^.q; if q = $8000 then q := op^.left^.q; set1^.smax := q div 8 + 1; for i := op^.left^.q to q do begin j := i div 8 + 1; set1^.sval[j] := chr(ord(set1^.sval[j]) | ($0001 << (i mod 8))); end; {for} op^.left := nil; op^.right := nil; op^.opcode := pc_ldc; op^.optype := cgSet; op^.setp := set1; end; {if} end; {case pc_sgs} pc_shl: begin {pc_shl} if op^.right^.opcode = pc_ldc then begin opcode := op^.left^.opcode; if opcode = pc_shl then begin if op^.left^.right^.opcode = pc_ldc then begin op^.right^.q := op^.right^.q + op^.left^.right^.q; op^.left := op^.left^.left; end; {if} end {if} else if opcode = pc_inc then begin op2 := op^.left; op^.left := op2^.left; op2^.q := op2^.q << op^.right^.q; op2^.left := op; opv := op2; PeepHoleOptimization(op2^.left); end; {else if} end; {if} end; {case pc_shl} pc_shr: {pc_shr} if IsUnsigned(op^.left) then op^.opcode := pc_usr; pc_slr: {pc_slr} if IsUnsigned(op^.left) then op^.opcode := pc_vsr; pc_sro: begin {pc_sro} if op^.optype in [cgReal,cgDouble,cgComp,cgExtended] then RealStoreOptimizations(op, op^.left) else if op^.optype = cgSet then begin if op^.q = 2 then begin if WordSet(op^.left) then begin MakeWordSet(op^.left); op^.q := op^.r; op^.r := 0; op^.optype := cgUWord; PeepHoleOptimization(opv); end; {if} end {if} else if op^.q = 4 then begin if LongSet(op^.left) then begin MakeLongSet(op^.left); op^.q := op^.r; op^.r := 0; op^.optype := cgULong; PeepHoleOptimization(opv); end; {if} end; {else if} end; {else if} end; {case pc_sro} pc_sto: begin {pc_sto} if op^.optype in [cgReal,cgDouble,cgComp,cgExtended] then RealStoreOptimizations(op, op^.right); if op^.optype <> cgSet then begin if op^.left^.opcode = pc_lao then begin op^.q := op^.left^.q; op^.lab := op^.left^.lab; op^.opcode := pc_sro; op^.left := op^.right; op^.right := nil; end {if} else if op^.left^.opcode = pc_lda then begin op^.q := op^.left^.q; op^.r := op^.left^.s; op^.p := op^.left^.p; op^.opcode := pc_str; op^.left := op^.right; op^.right := nil; end; {if} end; {if} end; {case pc_sto} pc_str: begin {pc_str} if op^.optype in [cgReal,cgDouble,cgComp,cgExtended] then RealStoreOptimizations(op, op^.left) else if op^.optype = cgSet then begin if op^.s = 2 then begin if WordSet(op^.left) then begin MakeWordSet(op^.left); op^.s := 0; op^.optype := cgUWord; PeepHoleOptimization(opv); end; {if} end {if} else if op^.s = 4 then begin if LongSet(op^.left) then begin MakeLongSet(op^.left); op^.s := 0; op^.optype := cgULong; PeepHoleOptimization(opv); end; {if} end; {else if} end; {else if} end; {case pc_str} pc_tjp: begin {pc_tjp} opcode := op^.left^.opcode; if opcode = pc_ldc then begin if op^.left^.optype in [cgByte, cgUByte, cgWord, cgUWord] then if op^.left^.q = 0 then begin opv := op^.next; rescan := true; end {if} else begin op^.opcode := pc_ujp; op^.left := nil; PeepHoleOptimization(opv); end; {else} end {if} else if opcode = pc_ior then begin op2 := op^.left; op2^.next := op^.next; op^.next := op2; op^.left := op2^.left; op2^.left := op2^.right; op2^.right := nil; op2^.opcode := pc_tjp; op2^.q := op^.q; PeepHoleOptimization(opv); end {else if} else if opcode = pc_and then begin op2 := op^.left; op2^.next := op^.next; op^.next := op2; op^.left := op2^.left; op2^.left := op2^.right; op2^.right := nil; op2^.opcode := pc_tjp; op2^.q := op^.q; op^.opcode := pc_fjp; op3 := pointer(Calloc(sizeof(intermediate_code))); op3^.opcode := dc_lab; op3^.optype := cgWord; op3^.q := GenLabel; op3^.next := op2^.next; op2^.next := op3; op^.q := op3^.q; PeepHoleOptimization(opv); end {else if} else JumpOptimizations(op, pc_fjp); end; {case pc_tjp} pc_udi: begin {pc_udi} if op^.right^.opcode = pc_ldc then begin q := op^.right^.q; if op^.left^.opcode = pc_ldc then begin if q <> 0 then begin op^.left^.q := ord(udiv(op^.left^.q & $0000FFFF, q & $0000FFFF)); opv := op^.left; end; {if} end {if} else if q = 1 then opv := op^.left else if OneBit(q) then begin op^.right^.q := Base(q); op^.opcode := pc_usr; end; {else if} end; {if} end; {case pc_udi} pc_udl: begin {pc_udl} if op^.right^.opcode = pc_ldc then begin lq := op^.right^.lval; if op^.left^.opcode = pc_ldc then begin if lq <> 0 then begin op^.left^.lval := udiv(op^.left^.lval, lq); opv := op^.left; end; {if} end {if} else if lq = 1 then opv := op^.left else if OneBit(lq) then begin op^.right^.lval := Base(lq); op^.opcode := pc_vsr; end; {else if} end; {if} end; {case pc_udl} pc_uim: begin {pc_uim} if op^.right^.opcode = pc_ldc then if op^.left^.opcode = pc_ldc then if op^.right^.q <> 0 then begin op^.left^.q := ord(umod(op^.left^.q & $0000FFFF, op^.right^.q & $0000FFFF)); opv := op^.left; end; {if} end; {case pc_uim} pc_ujp: begin {pc_ujp} RemoveDeadCode(op); if op^.next^.opcode = dc_lab then begin if LabelsMatch(op, op^.next) then begin opv := op^.next; rescan := true; end {if} else if op^.next^.next^.opcode = dc_lab then if LabelsMatch(op^.next^.next, op) then begin opv := op^.next; rescan := true; end; {if} end; {if} end; {case pc_ujp} pc_ulm: begin {pc_ulm} if op^.right^.opcode = pc_ldc then if op^.left^.opcode = pc_ldc then if op^.right^.lval <> 0 then begin op^.left^.lval := umod(op^.left^.lval, op^.right^.lval); opv := op^.left; end; {if} end; {case pc_ulm} pc_uni: begin {pc_uni} if op^.left^.opcode = pc_ldc then if op^.right^.opcode = pc_ldc then begin if op^.left^.setp^.smax < op^.right^.setp^.smax then ReverseChildren(op); set1 := op^.left^.setp; set2 := op^.right^.setp; for i := 1 to set1^.smax do set1^.sval[i] := chr(ord(set1^.sval[i]) | ord(set2^.sval[i])); opv := op^.left; end; {if} end; {case pc_uni} otherwise: ; end; {case} end; {PeepHoleOptimization} {- Common Subexpression Elimination ----------------------------} function MatchLoc (op1, op2: icptr): boolean; { See if two loads, stores or copies refer to the same } { location } { } { parameters: } { op1, op2 - operations to check } { } { Returns: True if they do, false if they don't. } begin {MatchLoc} MatchLoc := false; if (op1^.opcode in [pc_str,pc_cop,pc_lod,pc_lda]) and (op2^.opcode in [pc_str,pc_cop,pc_lod,pc_lda]) then begin if op1^.r = op2^.r then MatchLoc := true; end {if} else if (op1^.opcode in [pc_sro,pc_cpo,pc_ldo,pc_lao]) and (op2^.opcode in [pc_sro,pc_cpo,pc_ldo,pc_lao]) then if op1^.lab^ = op2^.lab^ then MatchLoc := true; end; {MatchLoc} function Member (op: icptr; list: iclist): boolean; { See if the operand of a load is referenced in a list } { } { parameters: } { op - load to check } { list - list to check } { } { Returns: True if op is in list, else false. } { } { Notes: As a side effect, this subroutine sets memberOp to } { point to any matching member; memberOp is undefined if } { there is no matching member. } begin {Member} Member := false; while list <> nil do begin if MatchLoc(op, list^.op) then begin Member := true; memberOp := list^.op; list := nil; end {if} else list := list^.next; end; {while} end; {Member} function TypeOf (op: icptr): baseTypeEnum; { find the type for the expression tree } { } { parameters: } { op - tree for which to find the type } { } { Returns: base type } var q: integer; {op^.q} begin {TypeOf} case op^.opcode of pc_ldc, pc_ldo, pc_lod, pc_dec, pc_inc, pc_ind, pc_cop, pc_cpo: TypeOf := op^.optype; pc_lad, pc_lao, pc_lca, pc_lda, pc_ixa, pc_abl, pc_udl, pc_ulm, pc_uml, pc_vsr, pc_sql: TypeOf := cgULong; pc_nop, pc_bnt, pc_ngi, pc_not, pc_adi, pc_and, pc_lnd, pc_bnd, pc_bor, pc_bxr, pc_dvi, pc_equ, pc_geq, pc_grt, pc_leq, pc_les, pc_neq, pc_ior, pc_lor, pc_mod, pc_mpi, pc_sbi, pc_shl, pc_shr, pc_rnd: TypeOf := cgWord; pc_udi, pc_uim, pc_umi, pc_usr, pc_sqi, pc_odd, pc_odl, pc_inn, pc_abi: TypeOf := cgUWord; pc_bnl, pc_ngl, pc_adl, pc_bal, pc_blr, pc_blx, pc_dvl, pc_mdl, pc_mpl, pc_sbl, pc_sll, pc_slr, pc_rn4: TypeOf := cgLong; pc_ngr, pc_adr, pc_dvr, pc_mpr, pc_sbr, pc_abr, pc_sqr, pc_at2, pc_pwr, pc_sin, pc_cos, pc_exp, pc_sqt, pc_log, pc_atn, pc_tan, pc_acs, pc_asn: TypeOf := cgExtended; pc_sgs, pc_uni, pc_dif, pc_siz: TypeOf := cgSet; pc_cnn, pc_cnv: TypeOf := baseTypeEnum(op^.q & $000F); pc_chk, pc_stk: TypeOf := TypeOf(op^.left); pc_bno: TypeOf := TypeOf(op^.right); pc_csp: begin q := op^.q; if q in [1..4,8..10,12..17,19,20..46,48..53,60, 62,66..69,71..75,84..86,91..92,96..97,100..102,115] then TypeOf := cgVoid else if q in [5,7,58..59,70,80,87..89] then TypeOf := cgWord else if q in [6,61,79,82] then TypeOf := cgExtended else if q in [11,116] then TypeOf := cgULong else if q in [76,81,83,98..99] then TypeOf := cgLong else if q in [77..78,93] then TypeOf := cgString; end; otherwise: Error(cge1); end; {case} end; {TypeOf} {$optimize 7} procedure CommonSubexpressionElimination; { Remove common subexpressions } type localPtr = ^localRecord; {list of local temp variables} localRecord = record next: localPtr; {next label in list} inUse: boolean; {is this temp already in use?} size: integer; {size of the temp area} lab: integer; {label number} end; var bb: blockPtr; {used to trace basic block lists} done: boolean; {for loop termination tests} op: icptr; {used to trace operation lists, trees} lop: icptr; {predecessor of op} temps: localPtr; {list of temp variables} procedure DisposeTemps; { dispose of the list of temp variables } var tp: localPtr; {temp pointer} begin {DisposeTemps} while temps <> nil do begin tp := temps; temps := tp^.next; dispose(tp); end; {while} end; {DisposeTemps} function GetTemp (bb: blockPtr; size: integer): integer; { Allocate a temp storage location } { } { parameters: } { bb - block in which the temp is allocated } { size - size of the temp } { } { Returns: local label number for the temp } var ip: icptr; {used to find insertion point for dc_loc} lab: integer; {label number} loc: icptr; {for dc_loc instruction} tp: localPtr; {used to trace lists, allocate new items} begin {GetTemp} lab := 0; {no label found, yet} tp := temps; {try for a temp of the exact size} while tp <> nil do begin if not tp^.inUse then if tp^.size = size then begin lab := tp^.lab; tp^.inUse := true; tp := nil; end; {if} if tp <> nil then tp := tp^.next; end; {while} if lab = 0 then begin {try for a larger temp} tp := temps; while tp <> nil do begin if not tp^.inUse then if tp^.size > size then begin lab := tp^.lab; tp^.inUse := true; tp := nil; end; {if} if tp <> nil then tp := tp^.next; end; {while} end; {if} if lab = 0 then begin {allocate a new temp} loc := pointer(Calloc(sizeof(intermediate_code))); loc^.opcode := dc_loc; loc^.optype := cgWord; maxLoc := maxLoc + 1; loc^.r := maxLoc; lab := maxLoc; loc^.q := size; if bb^.code = nil then begin loc^.next := nil; bb^.code := loc; end {if} else begin ip := bb^.code; while ip^.next <> nil do ip := ip^.next; loc^.next := nil; ip^.next := loc; end; {else} new(tp); tp^.next := temps; temps := tp; tp^.inUse := true; tp^.size := loc^.q; tp^.lab := lab; end; {if} GetTemp := lab; {return the temp label number} end; {GetTemp} procedure ResetTemps; { Mark all temps as available } var tp: localPtr; {temp pointer} begin {ResetTemps} tp := temps; while tp <> nil do begin tp^.inUse := false; tp := tp^.next; end; {while} end; {ResetTemps} procedure CheckForBlocks (op: icptr); { Scan a tree for blocked instructions } { } { parameters: } { op - tree to check } { } { Notes: Some code takes less time to execute than saving } { and storing the intermediate value. This subroutine } { identifies such patterns. } function Block (op: icptr): boolean; { See if the pattern should be blocked } { } { parameters: } { op - pattern to check } { } { Returns: True if the pattern should be blocked, else } { false. } var opcode: pcodes; {temp opcode} begin {Block} Block := false; opcode := op^.opcode; if opcode = pc_ixa then begin if op^.left^.opcode in [pc_lao,pc_lca,pc_lda] then Block := true; end {else if} else if opcode = pc_shl then begin if op^.right^.opcode = pc_ldc then if op^.right^.q = 1 then if op^.parents <= 3 then Block := true; end {else if} else if opcode in [pc_stk, pc_siz] then Block := true else if opcode = pc_cnv then if op^.q & $000F = ord(cgVoid) then Block := true; end; {Block} function Max (a, b: integer): integer; { Return the larger of two integers } { } { parameters: } { a, b - integers to check } { } { Returns: a if a > b, else b } begin {Max} if a > b then Max := a else Max := b; end; {Max} begin {CheckForBlocks} if Block(op) then begin if op^.left <> nil then {handle a blocked instruction} op^.left^.parents := op^.left^.parents + Max(op^.parents - 1, 0); if op^.right <> nil then op^.right^.parents := op^.right^.parents + Max(op^.parents - 1, 0); op^.parents := 1; end; {if} if op^.left <> nil then {check the children} CheckForBlocks(op^.left); if op^.right <> nil then CheckForBlocks(op^.right); end; {CheckForBlocks} procedure CheckTree (var op: icptr; bb: blockPtr); { check the trees used by op for common subexpressions } { } { parameters: } { op - operation to check } { bb - start of the current BASIC block } var op2: icptr; {result from Match calls} op3: icptr; {used to trace the codes in a block} function Match (var op: icptr; tree: icptr): icptr; { Check for matches to op in tree } { } { parameters: } { op - operation to check } { tree - tree to examine for matches } { } { Returns: pointer to matching node or nil if none found } var op2: icptr; {result from recursive Match calls} kill, start, stop: boolean; {used by Scan} skip: boolean; {used to see if children should be scanned} procedure Combine (var op1, op2: icptr); { Op2 is a save or copy of the same value as op1; use a copy } { for op2. } { } { parameters: } { op1 - first copy or save } { op2 - copy or save to optimize } var op3: icptr; {work pointer} begin {Combine} done := false; {force another labeling pass} op3 := op2; {remove op2 from the list} if op3^.opcode in [pc_str,pc_sro] then begin if op3^.opcode = pc_str then op3^.opcode := pc_cop else op3^.opcode := pc_cpo; op2 := op3^.next; op3^.next := nil; end {if} else op2 := op3^.left; op1^.left := op3; {place in the new location} end; {Combine} function SameTree (list, op1, op2: icptr): boolean; { Are op1 and op2 in the same expression tree? } { } { parameters: } { list - list of expression trees } { op1, op2 - operations to check } function InTree (tree, op: icptr): boolean; { See if op is in the tree } { } { parameters: } { tree - expression tree to check } { op - operatio to look for } begin {InTree} if tree = nil then InTree := false else if tree = op then InTree := true else InTree := InTree(tree^.left, op) or InTree(tree^.right, op); end; {InTree} begin {SameTree} SameTree := false; while list <> nil do if InTree(list, op1) then begin SameTree := InTree(list, op2); list := nil; end {if} else list := list^.next; end; {SameTree} procedure Scan (list, op1, op2: icptr); { Check to see if any operation between op1 and op2 kills the } { optimization } { } { parameters: } { list - instruction stream } { op1 - starting operation } { op2 - ending operation } { } { globals: } { kill - set to true if the optimization must be blocked, } { or false if it can be performed } { start - has op1 been found? (initialize to false) } { stop - has kill been set? (initialize to false) } var done: boolean; {loop termination test} begin {Scan} repeat done := true; if not start then {see if it is time to start} if list = op1 then start := true; if list^.left <> nil then {scan the children} Scan(list^.left, op1, op2); if not stop then if list^.right <> nil then Scan(list^.right, op1, op2); if start then {check for a kill or termination} if not stop then if list = op2 then begin kill := false; stop := true; end {if} else if list^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo] then begin if MatchLoc(list, op2) then begin kill := true; stop := true; end {if} end {else if} else if list^.opcode in [pc_sto,pc_cup,pc_cui,pc_tl1,pc_tl2, pc_pds,pc_csp,pc_cum,pc_vct] then if Member(op1, c_ind) then begin kill := true; stop := true; end; {if} if not stop then {scan forward in the stream} if list^.next <> nil then begin list := list^.next; done := false; end; {if} until done; end; {Scan} begin {Match} op2 := nil; {check for an exact match} skip := false; if CodesMatch(op, tree, true) then begin if op = tree then op2 := tree else begin start := false; stop := false; Scan(bb^.code, tree, op); if not kill then op2 := tree; end; {else} end {if} {check for stores of a common value} else if op^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo] then if tree^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo] then if op^.left = tree^.left then begin start := false; stop := false; Scan(bb^.code, tree, op); if not kill then if not SameTree(bb^.code, op, tree) then if (op^.left^.opcode <> pc_ldc) or (op^.left^.q <> 0) or (not (op^.left^.optype in [cgByte,cgUByte,cgWord,cgUWord])) then begin Combine(tree, op); skip := true; end; {if} end; {if} if not skip then begin {check for matches in the children} if op2 = nil then if tree^.left <> nil then op2 := Match(op, tree^.left); if op2 = nil then if tree^.right <> nil then op2 := Match(op, tree^.right); end; {if} Match := op2; end; {Match} begin {CheckTree} op^.parents := 0; {zero the parent counter} if op^.left <> nil then {check the children} CheckTree(op^.left, bb); if op^.right <> nil then CheckTree(op^.right, bb); if op^.next = nil then {look for a match to the current code} if not (op^.opcode in [pc_cup,pc_cui,pc_cum,pc_tl1,pc_tl2,pc_vct,pc_csp,pc_pds,pc_bno]) then begin op2 := nil; op3 := bb^.code; while (op2 = nil) and (op3 <> nil) do begin op2 := Match(op, op3); if op2 <> nil then if op2^.next = nil then begin op := op2; bb := nil; op3 := nil; end ;{if} if op3 <> nil then op3 := op3^.next; end; {while} end; {if} end; {CheckTree} procedure CountParents (op: icptr); { increment the parent counter for all children of this node } { } { parameters: } { op - node for which to check the children } begin {CountParents} if op^.parents = 0 then begin if op^.left <> nil then begin CountParents(op^.left); op^.left^.parents := op^.left^.parents + 1; end; {if} if op^.right <> nil then begin CountParents(op^.right); op^.right^.parents := op^.right^.parents + 1; end; {if} end; {if} end; {CountParents} procedure CreateTemps (var op: icptr; bb: blockPtr; var lop: icptr); { create temps for nodes with multiple parents } { } { parameters: } { op - node for which to create temps } { bb - current basic block } { lop - predecessor to op } var children: boolean; {does this node have children?} llab: integer; {local label number; for temp} op2, str: icptr; {new opcodes} optype: baseTypeEnum; {type of the temp variable} begin {CreateTemps} children := false; {create temps for the children} if op^.left <> nil then begin children := true; CreateTemps(op^.left, bb, lop); end; {if} if op^.right <> nil then begin children := true; CreateTemps(op^.right, bb, lop); end; {if} if children then if op^.parents > 1 then begin optype := TypeOf(op); {create a temp label} llab := GetTemp(bb, TypeSize(optype)); {make a copy of the duplicated tree} op2 := pointer(Calloc(sizeof(intermediate_code))); op2^ := op^; op^.opcode := pc_lod; {substitute a load of the temp} op^.optype := optype; op^.parents := 1; op^.r := llab; op^.q := 0; op^.left := nil; op^.right := nil; {store the temp result} str := pointer(Calloc(sizeof(intermediate_code))); str^.opcode := pc_str; str^.optype := optype; str^.r := llab; str^.q := 0; str^.left := op2; if lop = nil then begin {insert the store in the basic block} str^.next := bb^.code; bb^.code := str; end {if} else begin str^.next := lop^.next; lop^.next := str; end; {else} lop := str; end; {if} end; {CreateTemps} begin {CommonSubexpressionElimination} temps := nil; {no temps allocated, yet} repeat {identify common parts} done := true; bb := DAGblocks; while bb <> nil do begin Spin; op := bb^.code; if op <> nil then begin CheckTree(bb^.code, bb); while op^.next <> nil do begin CheckTree(op^.next, bb); if op^.next <> nil then op := op^.next; end; {while} end; {if} bb := bb^.next; end; {while} until done; bb := DAGblocks; {count the number of parents} while bb <> nil do begin op := bb^.code; Spin; while op <> nil do begin CountParents(op); op := op^.next; end; {while} bb := bb^.next; end; {while} bb := DAGblocks; {check for blocked instructions} while bb <> nil do begin op := bb^.code; Spin; while op <> nil do begin CheckForBlocks(op); op := op^.next; end; {while} bb := bb^.next; end; {while} bb := DAGblocks; {create temps for common subexpressions} while bb <> nil do begin op := bb^.code; lop := nil; ResetTemps; Spin; while op <> nil do begin if op^.opcode = pc_ent then DisposeTemps; CreateTemps(op, bb, lop); lop := op; op := op^.next; end; {while} bb := bb^.next; end; {while} DisposeTemps; {get rid of the temp variable list} end; {CommonSubexpressionElimination} {- Loop Optimizations ------------------------------------------} procedure AddOperation (op: icptr; var lp: iclist); { Add an operation to an operation list } { } { parameters: } { op - operation to add } { lp - list to add the operation to } var inList: boolean; {is op already in the list?} llp: iclist; {work pointer} begin {AddOperation} llp := lp; inList := false; while llp <> nil do if MatchLoc(llp^.op, op) then begin inList := true; llp := nil; end {if} else llp := llp^.next; if not inList then begin new(llp); llp^.next := lp; lp := llp; llp^.op := op; end; {if} end; {AddOperation} procedure DisposeBlkList (var blk: blockListPtr); { dispose of all entries in the block list } { } { parameters: } { blk - list of blocks to dispose of } var bk1, bk2: blockListPtr; {work pointers} begin {DisposeBlkList} bk1 := blk; blk := nil; while bk1 <> nil do begin bk2 := bk1; bk1 := bk2^.next; dispose(bk2); end; {while} end; {DisposeBlkList} procedure DisposeOpList (var oplist: iclist); { dispose of all entries in the list } { } { parameters: } { oplist - operation list to dispose of } var op1, op2: iclist; {work pointers} begin {DisposeOpList} op1 := oplist; oplist := nil; while op1 <> nil do begin op2 := op1; op1 := op2^.next; dispose(op2); end; {while} end; {DisposeOpList} procedure DumpLoopLists; { dispose of lists created by ReachingDefinitions and Dominators} var bb: blockPtr; {used to trace basic block list} dom: blockListPtr; {used to dispose of a dominator} begin {DumpLoopLists} bb := DAGBlocks; while bb <> nil do begin DisposeOpList(bb^.c_in); {dump the reaching definition lists} DisposeOpList(bb^.c_out); DisposeOpList(bb^.c_gen); DisposeBlkList(bb^.dom); while bb^.dom <> nil do begin {dump the dominator lists} dom := bb^.dom; bb^.dom := dom^.next; dispose(dom); end; {while} bb := bb^.next; end; {while} end; {DumpLoopLists} procedure AddLoads (jp: icptr; var lp: iclist); { Add any load addresses from the children of this } { operation } { } { parameters: } { jp - operation to check } { lp - list to add the loads to } begin {AddLoads} if jp^.opcode in [pc_lda,pc_lao,pc_lod,pc_lod] then AddOperation(jp, lp) else begin if jp^.left <> nil then AddLoads(jp^.left, lp); if jp^.right <> nil then AddLoads(jp^.right, lp); end {else} end; {AddLoads} procedure FlagIndirectUses; { Find all variables that could be changed by an indirect } { access. } var bb: blockPtr; {used to trace block list} procedure Check (op: icptr; doingInd: boolean); { Check op and its children & followers for dangerous } { references } { } { parameters: } { op - operation to check } { doingInd - are we doing a pc_ind? If so, pc_lda's } { are safe } var lDoingInd: boolean; {local doingInd} begin {Check} while op <> nil do begin if op^.opcode = pc_ind then lDoingInd := true else lDoingInd := doingInd; if op^.left <> nil then Check(op^.left, lDoingInd); if op^.right <> nil then Check(op^.right, lDoingInd); if op^.opcode in [pc_lao,pc_cpo,pc_ldo,pc_sro] then AddOperation(op, c_ind) else if op^.opcode = pc_ind then begin if op^.left^.opcode = pc_ind then AddLoads(op^.left^.left, c_ind); end {else if} else if op^.opcode = pc_csp then begin if op^.q = 1{get} then AddLoads(op^.left, c_ind); end {else if} else if op^.opcode = pc_sto then AddLoads(op^.left, c_ind) else if op^.opcode = pc_lda then if not doingInd then AddOperation(op, c_ind); op := op^.next; end; {while} end; {Check} begin {FlagIndirectUses} c_ind := nil; bb := DAGBlocks; while bb <> nil do begin Check(bb^.code, false); bb := bb^.next; end; {while} end; {FlagIndirectUses} procedure DoLoopOptimization; { Perform optimizations related to loops and data flow } type dftptr = ^dftrecord; {depth first tree edges} dftrecord = record next: dftptr; from, dest: blockPtr; end; var backEdge: dftptr; {list of back edges} dft: dftptr; {depth first tree} dft2: dftptr; {work pointer} function DFN (i: integer): blockPtr; { find the basic block with dfn index of i } { } { parameters: } { i - index to look for } { } { Returns: block pointer, or nil if there is none } var bb: blockPtr; {used to trace block list} begin {DFN} bb := DAGBlocks; DFN := nil; while bb <> nil do begin if bb^.dfn = i then begin DFN := bb; bb := nil; end else bb := bb^.next; end; {while} end; {DFN} function MemberDFNList (dfn: integer; bl: blockListPtr): boolean; { See if dfn is a member of the list bl } { } { parameters: } { dfn - block number to check } { bl - list of block numbers to check } { } { Returns: True if dfn is in bl, else false. } begin {MemberDFNList} MemberDFNList := false; while bl <> nil do if bl^.dfn = dfn then begin MemberDFNList := true; bl := nil; end {if} else bl := bl^.next; end; {MemberDFNList} function FindDAG (op: icptr): blockPtr; { Find the DAG containing label for op } { } { parameters: } { op - instruction with a label } { } { Returns: pointer to the proper basic block } var bb: blockPtr; {used to trace basic block list} begin {FindDAG} bb := DAGBlocks; FindDAG := nil; while bb <> nil do begin if bb^.code^.opcode = dc_lab then if LabelsMatch(bb^.code, op) then begin FindDAG := bb; bb := nil; end; {if} if bb <> nil then bb := bb^.next; end; {while} end; {FindDAG} procedure DepthFirstOrder; { Number the DAG for depth first order } var bb: blockPtr; {used to trace basic block lists} i: integer; {dfn index} procedure Search (bb: blockPtr); { Search this block } { } { parameters: } { bb - basic block to search } var blk: blockPtr; {work block} ndft: dftptr; {for new tree entries} op: icptr; {used to trace operation list} function NotUnconditional: boolean; { See if the block ends with something other than an } { unconditional jump } { } { Returns: True if the block ends with something other } { than pc_ujp or pc_add, else false } var op: icptr; {used to trace the list} begin {NotUnconditional} NotUnconditional := true; op := bb^.code; if op <> nil then begin while op^.next <> nil do op := op^.next; if op^.opcode in [pc_add,pc_ujp] then NotUnconditional := false; end; {if} end; {NotUnconditional} begin {Search} Spin; if bb <> nil then if not bb^.visited then begin bb^.visited := true; if NotUnconditional then if bb^.next <> nil then begin new(ndft); ndft^.next := dft; dft := ndft; ndft^.from := bb; ndft^.dest := bb^.next; Search(bb^.next); end; {if} op := bb^.code; while op <> nil do begin if op^.opcode in [pc_ujp, pc_fjp, pc_tjp, pc_add] then begin blk := FindDAG(op); new(ndft); if blk^.visited then begin ndft^.next := backEdge; backEdge := ndft; end {if} else begin ndft^.next := dft; dft := ndft; Search(blk); end; {else} ndft^.from := bb; ndft^.dest := blk; end; {if} op := op^.next; end; {while} bb^.dfn := i; i := i-1; end; {if} end; {Search} begin {DepthFirstOrder} dft := nil; backEdge := nil; i := 0; bb := DAGblocks; while bb <> nil do begin bb^.visited := false; i := i+1; bb := bb^.next; end; {while} Search(DAGBlocks); end; {DepthFirstOrder} procedure Dominators; { Find a list of dominators for each node } var bb: blockPtr; {used to trace the block list} change: boolean; {for loop termination test} i, j: integer; {loop variables} maxdfn, mindfn: integer; {max and min dfn values used} procedure Add (var dom: blockListPtr; dfn: integer); { Add dfn to the list of dominators } { } { parameters: } { dom - dominator list } { dfn - new dominator number } var dp: blockListPtr; {new node} begin {Add} new(dp); dp^.last := nil; dp^.next := dom; dom^.last := dp; dom := dp; dp^.dfn := dfn; end; {Add} procedure CheckPredecessors (bb: blockPtr; bl: dftptr); { Eliminate nodes that don't dominate a predecessor } { } { parameters: } { bb - block being checked } { bl - list of edges to check for predecessors } var dp: blockListPtr; {list of dominator numbers} tdp: blockListPtr; {used to remove a dominator entry} begin {CheckPredecessors} while bl <> nil do begin if bl^.dest = bb then begin dp := bb^.dom; while dp <> nil do if dp^.dfn <> bb^.dfn then if not MemberDFNList(dp^.dfn, bl^.from^.dom) then begin change := true; tdp := dp; if tdp^.last = nil then bb^.dom := tdp^.next else tdp^.last^.next := tdp^.next; if tdp^.next <> nil then tdp^.next^.last := tdp^.last; dp := tdp^.next; dispose(tdp); end {if} else dp := dp^.next else dp := dp^.next; end; {if} bl := bl^.next; end; {while} end; {CheckPredecessors} begin {Dominators} Spin; maxdfn := 0; {find the largest dfn} bb := DAGBlocks; while bb <> nil do begin if bb^.dfn > maxdfn then maxdfn := bb^.dfn; bb := bb^.next; end; {while} Add(DAGBlocks^.dom, DAGBlocks^.dfn); {the first node is it's own dominator} mindfn := DAGBlocks^.dfn; {assume all other nodes are dominated by every other node} for i := mindfn+1 to maxdfn do begin bb := DFN(i); if bb <> nil then for j := mindfn to maxdfn do Add(bb^.dom, j); end; {for} repeat {iterate to the true set of dominators} change := false; for i := mindfn+1 to maxdfn do begin bb := DFN(i); CheckPredecessors(bb, dft); CheckPredecessors(bb, backEdge); end; {for} until not change; end; {Dominators} procedure ReachingDefinitions; { find the list of reaching definitions for each basic block } var bb: blockPtr; {block being scanned} change: boolean; {loop termination test} i: integer; {node index number} newIn: iclist; {list of inputs} function Gen (op: icptr): iclist; { find a list of generated values } { } { parameters: } { op - list of intermediate codes to scan } { } { Returns: list of generated definitions } var gp: iclist; {list of generated definitions} indFound: boolean; {has an indirect store been found?} procedure Check (ip: icptr); { Add any result from ip to gp } { } { parameters: } { ip - instruction to check } var lc_ind: iclist; {used to trace the c_ind list} begin {Check} if ip^.left <> nil then Check(ip^.left); if ip^.right <> nil then Check(ip^.right); if ip^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo] then AddOperation(ip, gp) else if ip^.opcode in [pc_mov,pc_sto] then AddLoads(ip, gp); if not indFound then if ip^.opcode in [pc_sto,pc_cup,pc_cui,pc_tl1, pc_tl2,pc_vct,pc_csp,pc_pds,pc_cum] then begin lc_ind := c_ind; while lc_ind <> nil do begin AddOperation(lc_ind^.op, gp); lc_ind := lc_ind^.next; end; {while} indFound := true; end; {if} end; {Check} begin {Gen} indFound := false; gp := nil; while op <> nil do begin Check(op); op := op^.next; end; {while} Gen := gp; end; {Gen} function EqualSets (l1, l2: iclist): boolean; { See if two sets of stores and copies are equivalent } { } { parameters: } { l1, l2 - lists of copies and stores } { } { Returns: True if the lists are equivalent, else false } { } { Notes: The members of each list are assumed to be } { unique within that list. } var c1, c2: integer; {number of elements in the sets} l3: iclist; {used to trace the lists} matchFound: boolean; {was a match found?} begin {EqualSets} EqualSets := false; {assume they are not equal} c1 := 0; {count the elements of l1} l3 := l1; while l3 <> nil do begin c1 := c1+1; l3 := l3^.next; end; {while} c2 := 0; {count the elements of l2} l3 := l2; while l3 <> nil do begin c2 := c2+1; l3 := l3^.next; end; {while} if c1 = c2 then begin {make sure each member of l1 is in l2} EqualSets := true; while l1 <> nil do begin matchFound := false; l3 := l2; while l3 <> nil do begin if MatchLoc(l1^.op, l3^.op) then begin l3 := nil; matchFound := true; end {if} else l3 := l3^.next; end; {while} if not matchFound then begin EqualSets := false; l1 := nil; end {if} else l1 := l1^.next; end; {while} end; {if} end; {EqualSets} function Union (l1, l2: iclist): iclist; { Returns a list that is the union of two input lists } { } { parameters: } { l1, l2 - lists } { } { Returns: New, dynamically allocated list that includes } { all of the members in l1 and l2. } { } { Notes: } { 1. If there are duplicates, the member from l1 is } { returned. } { 2. It is assumed that all members of l1 and l2 are } { unique within their own list. } { 3. The original lists are not disturbed. } { 4. The caller is responsible for disposing of the } { memory used by the list. } var lp: iclist; {new list pointer} np: iclist; {new list member pointer} tp: iclist; {temp list pointer} begin {Union} lp := nil; tp := l1; while tp <> nil do begin new(np); np^.next := lp; lp := np; np^.op := tp^.op; tp := tp^.next; end; {while} while l2 <> nil do begin if not Member(l2^.op, l1) then begin new(np); np^.next := lp; lp := np; np^.op := l2^.op; end; {if} l2 := l2^.next; end; {while} Union := lp; end; {Union} function UnionOfPredecessors (bptr: blockPtr): iclist; { create a union of the outputs of predecessors to bptr } { } { parameters: } { bptr - block for which to look for predecessors } { } { Returns: Resulting set } var bp: dftptr; {used to trace edge lists} plist: iclist; {result list} tlist: iclist; {temp result list} begin {UnionOfPredecessors} plist := nil; bp := dft; while bp <> nil do begin if bp^.dest = bptr then begin tlist := Union(plist, bp^.from^.c_out); DisposeOpList(plist); plist := tlist; end; {if} bp := bp^.next; end; {while} bp := backEdge; while bp <> nil do begin if bp^.dest = bptr then begin tlist := Union(plist, bp^.from^.c_out); DisposeOpList(plist); plist := tlist; end; {if} bp := bp^.next; end; {while} UnionOfPredecessors := plist; end; {UnionOfPredecessors} begin {ReachingDefinitions} i := 1; {initialize the lists} repeat bb := DFN(i); if bb <> nil then begin bb^.c_in := nil; bb^.c_gen := Gen(bb^.code); bb^.c_out := Union(nil, bb^.c_gen); end; {if} i := i+1; until bb = nil; repeat {iterate to a solution} change := false; i := 1; repeat Spin; bb := DFN(i); if bb <> nil then begin newIn := UnionOfPredecessors(bb); if not EqualSets(bb^.c_in, newIn) then begin {IN[n] := newIn} DisposeOpList(bb^.c_in); bb^.c_in := newIn; newIn := nil; {OUT[n] := IN[n] - KILL[n] U GEN[n]} DisposeOpList(bb^.c_out); bb^.c_out := Union(bb^.c_in, nil); change := true; end; {if} DisposeOpList(newIn); end; {if} i := i+1; until bb = nil; until not change; end; {ReachingDefinitions} procedure LoopInvariantRemoval; { Remove all loop invariant computations } type loopPtr = ^loopRecord; {blocks in a list} loopRecord = record next: loopPtr; {next entry} block: blockPtr; {code block} exit: boolean; {is this a loop exit?} end; loopListPtr = ^loopListRecord; {list of loop lists} loopListRecord = record next: loopListPtr; loop: loopPtr; end; var icount: integer; {order invariant found} loops: loopListPtr; {list of loops} lp: loopPtr; {used to trace loop lists} llp: loopListPtr; {used to trace the list of loops} procedure FindLoops; { Create a list of the natural loops } var blk: blockPtr; {target block for a jump} bp: dftptr; {used to trace the back edges} lp, lp2: loopPtr; {used to reverse the list} llp: loopListPtr; {loop list header entry} llp2: loopListPtr; {used to reverse the list} op: icptr; {used to trace the opcode list} procedure Add (block: blockPtr); { Add a block to the current loop list } { } { parameters: } { block - block to add } var lp: loopPtr; {new loop entry} begin {Add} new(lp); lp^.next := llp^.loop; llp^.loop := lp; lp^.block := block; lp^.exit := false; end; {Add} function InLoop (blk: blockPtr; lp: loopPtr): boolean; { See if the block is in the loop } { } { parameters: } { blk - block to check for } { lp - loop list } { } { Returns: True if blk is in the list, else false } begin {InLoop} InLoop := false; while lp <> nil do begin if lp^.block = blk then begin lp := nil; InLoop := true; end {if} else lp := lp^.next; end; {while} end; {InLoop} procedure Insert (block: blockPtr); { Insert a block into the loop list } { } { parameters: } { block - block to add } procedure AddPredecessors (block: blockPtr; bl: dftptr); { add any predecessors to the loop } { } { parameters: } { block - block for which to check for } { predecessors } { bl - list of edges to check } begin {AddPredecessors} while bl <> nil do begin if bl^.dest = block then Insert(bl^.from); bl := bl^.next; end; {while} end; {AddPredecessors} function InLoop (block: blockPtr; lp: loopPtr): boolean; { See if a block is in the loop } { } { parameters: } { block - block to check } { lp - list of blocks in the loop } { } { Returns: True if the block is in the loop, else false } begin {InLoop} InLoop := false; while lp <> nil do if lp^.block = block then begin InLoop := true; lp := nil; end {if} else lp := lp^.next; end; {InLoop} begin {Insert} if not InLoop(block, llp^.loop) then begin Add(block); AddPredecessors(block, dft); AddPredecessors(block, backEdge); end; {if} end; {Insert} begin {FindLoops} loops := nil; bp := backEdge; {scan the back edges} while bp <> nil do begin if MemberDFNList(bp^.dest^.dfn, bp^.from^.dom) then begin new(llp); {create a new loop list entry} llp^.next := loops; loops := llp; llp^.loop := nil; Add(bp^.dest); Insert(bp^.from); lp := llp^.loop; {reverse the list} llp^.loop := nil; while lp <> nil do begin lp2 := lp; lp := lp2^.next; lp2^.next := llp^.loop; llp^.loop := lp2; end; {while} lp := llp^.loop; {mark the exits} while lp <> nil do begin op := lp^.block^.code; while op <> nil do begin if op^.opcode in [pc_ujp, pc_fjp, pc_tjp, pc_add] then begin blk := FindDAG(op); if not InLoop(blk, llp^.loop) then lp^.exit := true; if op^.opcode in [pc_fjp,pc_tjp] then if not InLoop(lp^.block^.next, llp^.loop) then lp^.exit := true; end; {if} op := op^.next; end; {while} lp := lp^.next; end; {while} end; {if} bp := bp^.next; end; {while} llp := loops; {reverse the loop list} loops := nil; while llp <> nil do begin llp2 := llp; llp := llp2^.next; llp2^.next := loops; loops := llp2; end; {while} end; {FindLoops} function MarkInvariants (lp: loopPtr): boolean; { Make a pass over the opcodes, marking those that are } { invariant. } { } { parameters: } { lp - loop to scan } { } { Returns: True if any new nodes were marked, else false. } var count: integer; {number of generating blocks} indirectStores: boolean; {does the loop contain indirect stores or function calls?} inhibit: boolean; {inhibit stores?} lp2: loopPtr; {used to trace the loop} op: icptr; {used to trace the instruction list} opcode: pcodes; {op^.opcode; for efficiency} procedure Check (op: icptr; olp: loopPtr); { See if this node or its children is invariant } { } { parameters: } { op - node to check } { olp - loop entry for the block containing the store } var invariant: boolean; {are the operands invariant?} function IndirectInhibit (op: icptr): boolean; { See if a store should be inhibited due to indirect } { accesses } { } { parameters: } { op - instruction to check } { } { Returns: True if the instruction should be inhibited, } { else false. } begin {IndirectInhibit} IndirectInhibit := false; if indirectStores then if Member(op, c_ind) then IndirectInhibit := true; end; {IndirectInhibit} function NoOtherStoresOrUses (lp, olp: loopPtr; op: icptr): boolean; { Check for invalid stores } { } { parameters: } { lp - loop to check } { olp - loop entry for the block containing the store } { op - store to check } { } { Returns: True if the store is valid, false if not. } { } { Notes: Specifically, these two rules are inforced: } { 1. No other stores to the same location appear in the } { loop. } { 2. All uses of the value in the loop can be reached } { only by the assign. } var lp2: loopPtr; {used to trace the loop list} op2: icptr; {used to trace code list} function SafeLoad (sop, lop: icptr; sbk, lbk: blockPtr): boolean; { See if a load is in a safe position } { } { parameters: } { sop - save opcode that may need to be left in loop } { lop - load operation that may inhibit the save } { sbk - block containing the save } { lbk - block containing the load } function First (op1, op2, stream: icptr): icptr; { See which operation comes first } { } { parmeters: } { op1, op2 - instructions to check } { stream - start of block containing the instructions } { } { Returns: First operation found, or nil if missing } var op: icptr; {temp opcode} begin {First} if stream = op1 then First := op1 else if stream = op2 then First := op2 else begin op := nil; if stream^.left <> nil then op := First(op1, op2, stream^.left); if op = nil then if stream^.right <> nil then op := First(op1, op2, stream^.right); if op = nil then if stream^.next <> nil then op := First(op1, op2, stream^.next); First := op; end; {else} end; {First} begin {SafeLoad} if sbk = lbk then SafeLoad := First(sop, lop, sbk^.code) = sop else SafeLoad := MemberDFNList(sbk^.dfn, lbk^.dom); end; {SafeLoad} function MatchStores (op, tree: icptr; opbk, treebk: blockPtr): boolean; { Check the tree for stores to the same location as op } { } { parameters: } { op - store to check for } { tree - operation tree to check } { opbk - block containing op } { treebk - block containing tree } { } { Returns: True if there are matching stores, else false } var result: boolean; {function result} begin {MatchStores} result := false; if tree^.opcode in [pc_str,pc_cop,pc_sro,pc_cpo] then begin if tree <> op then result := MatchLoc(op, tree); end {if} else if tree^.opcode in [pc_ldo,pc_lod] then if MatchLoc(op, tree) then result := not SafeLoad(op, tree, opbk, treebk); if not result then if tree^.left <> nil then result := MatchStores(op, tree^.left, opbk, treebk); if not result then if tree^.right <> nil then result := MatchStores(op, tree^.right, opbk, treebk); MatchStores := result; end; {MatchStores} begin {NoOtherStoresOrUses} NoOtherStoresOrUses := true; lp2 := lp; while lp2 <> nil do begin op2 := lp2^.block^.code; while op2 <> nil do if MatchStores(op, op2, olp^.block, lp2^.block) then begin op2 := nil; lp2 := nil; NoOtherStoresOrUses := false; end {if} else op2 := op2^.next; if lp2 <> nil then lp2 := lp2^.next; end; {while} end; {NoOtherStoresOrUses} function NumberOfGens (op: icptr; lp: loopPtr): integer; { Count the number of nodes that generate op } { } { parameters: } { op - instruction to check } { lp - loop to check } var count: integer; {number of generators} begin {NumberOfGens} count := 0; while lp <> nil do begin if Member(op, lp^.block^.c_gen) then count := count+1; lp := lp^.next; end; {while} NumberOfGens := count; end; {NumberOfGens} function PreviousStore (op, list: icptr): boolean; { See if the last save was invariant } { } { parameters: } { op - load operation } { list - block containing the load } { } { Returns: True if the previous store was invariant, else } { false. } var indop: icptr; {any indirect operation after strop} strop: icptr; {last matching store before op} procedure Check (lop: icptr); { Stop if this is lop; save if it is a matching store } { } { parameters: } { lop - check this operation and it's children } begin {Check} if lop^.left <> nil then Check(lop^.left); if list <> nil then if lop^.right <> nil then Check(lop^.right); if list <> nil then if lop = op then list := nil else if (lop^.opcode in [pc_str,pc_cop]) and MatchLoc(op, lop) then begin strop := lop; indop := nil; end {else if} else if op^.opcode in [pc_sto,pc_cup, pc_cui,pc_tl1,pc_tl2,pc_vct,pc_pds,pc_csp,pc_cum] then indop := op; end; {Check} function Inhibit (indop, op: icptr): boolean; { See if op should be inhibited due to indirect stores } { } { parameters: } { indop - inhibiting indirect store or nil } { op - instruction to check } begin {Inhibit} Inhibit := false; if indop <> nil then if Member(op, c_ind) then Inhibit := true; end; {Inhibit} begin {PreviousStore} indop := nil; strop := nil; while list <> nil do begin Check(list); if list <> nil then list := list^.next; end; {while} PreviousStore := false; if strop <> nil then if strop^.parents <> 0 then if not Inhibit(indop, op) then PreviousStore := true; end; {PreviousStore} begin {Check} if op^.parents = 0 then begin invariant := true; if op^.left <> nil then begin Check(op^.left, olp); if op^.left^.parents = 0 then invariant := false; end; {if} if op^.right <> nil then begin Check(op^.right, olp); if op^.right^.parents = 0 then invariant := false; end; {if} if invariant then begin opcode := op^.opcode; if opcode in [pc_adi,pc_adl,pc_adr,pc_and,pc_lnd,pc_bnd,pc_bal,pc_bnt, pc_bnl,pc_bor,pc_blr,pc_bxr,pc_blx,pc_bno,pc_dec,pc_dvi, pc_udi,pc_dvl,pc_udl,pc_dvr,pc_equ,pc_neq,pc_grt,pc_les, pc_geq,pc_leq,pc_inc,pc_ind,pc_ior,pc_lor,pc_ixa,pc_lad, pc_lca,pc_lda,pc_ldc,pc_mod,pc_uim,pc_mdl,pc_ulm,pc_mpi, pc_umi,pc_mpl,pc_uml,pc_mpr,pc_ngi,pc_ngl,pc_ngr,pc_not, pc_sbi,pc_sbl,pc_sbr,pc_shl,pc_sll,pc_shr,pc_usr,pc_slr, pc_vsr,pc_chk,pc_abi,pc_abr,pc_abl,pc_sqi,pc_sql,pc_sqr, pc_rnd,pc_rn4,pc_odd,pc_odl,pc_at2,pc_sgs,pc_uni,pc_pwr, pc_int,pc_dif,pc_inn,pc_sin,pc_cos,pc_exp,pc_sqt,pc_log, pc_atn,pc_tan,pc_acs,pc_asn,pc_abl] then begin op^.parents := icount; icount := icount+1; end {if} else if opcode = pc_cnv then begin if op^.q & $000F <> ord(cgVoid) then begin op^.parents := icount; icount := icount+1; end; {if} end {else if} else if opcode in [pc_sro,pc_sto,pc_str,pc_cop,pc_cpo] then begin if not inhibit then if not IndirectInhibit(op) then if NoOtherStoresOrUses(lp, olp, op) then begin op^.parents := icount; icount := icount+1; end; {if} end {else if} else if opcode in [pc_lao,pc_ldo,pc_lod] then begin {invariant if there is an immediately preceeding invariant store} if PreviousStore(op, lp2^.block^.code) then begin op^.parents := icount; icount := icount+1; end {if} else if not Member(op, lp2^.block^.c_gen) then begin {invariant if there are no generators in the loop} count := NumberOfGens(op, lp); if count = 0 then begin op^.parents := icount; icount := icount+1; end {if} else if count = 1 then begin {invariant if there is one generator AND the generator} {is not in the current block AND no reaching } {definitions for the loop AND generating statement is } {invariant } if memberOp^.parents <> 0 then if not Member(op, lp^.block^.c_in) then begin op^.parents := icount; icount := icount+1; end; {if} end; {else if} end; {else} end {else if} end; {if} if op^.parents <> 0 then MarkInvariants := true; end; {if} end; {Check} function CheckForIndirectStores (lp: loopPtr): boolean; { See if there are any indirect stores or function calls in } { the loop } { } { parameters: } { lp - loop to check } { } { Returns: True if there are indirect stores or function } { calls, else false. } function CheckOps (op: icptr): boolean; { Check this operation list } { } { parameters: } { op - operation list to check } { } { Returns: True if an indirect store or function call is } { found, else false. } var result: boolean; {value to return} begin {CheckOps} result := false; while op <> nil do begin if op^.opcode in [pc_sto,pc_cup,pc_cui, pc_tl1,pc_tl2,pc_vct,pc_pds,pc_csp,pc_mov,pc_cum] then begin result := true; op := nil; end {if} else begin if op^.left <> nil then result := CheckOps(op^.left); if not result then if op^.right <> nil then result := CheckOps(op^.right); if result then op := nil; end; {if} if op <> nil then op := op^.next; end; {while} CheckOps := result; end; {CheckOps} begin {CheckForIndirectStores} CheckForIndirectStores := false; while lp <> nil do if CheckOps(lp^.block^.code) then begin CheckForIndirectStores := true; lp := nil; end {if} else lp := lp^.next; end; {CheckForIndirectStores} function DominatesExits (dfn: integer; lp: loopPtr): boolean; { See if this block dominates all loop exits } { } { parameters: } { dfn - block that must dominate exits } { lp - loop list } { } { Returns: True if the block dominates all exits, else false. } var dom: blockListPtr; {used to trace dominator list} begin {DominatesExits} DominatesExits := true; while lp <> nil do begin if lp^.exit then begin dom := lp^.block^.dom; while dom <> nil do if dom^.dfn = dfn then dom := nil else begin dom := dom^.next; if dom = nil then begin lp := nil; DominatesExits := false; end; {if} end; {else} end; {if} if lp <> nil then lp := lp^.next; end; {while} end; {DominatesExits} begin {MarkInvariants} MarkInvariants := false; lp2 := lp; while lp2 <> nil do begin inhibit := not DominatesExits(lp2^.block^.dfn, lp); indirectStores := CheckForIndirectStores(lp); op := lp2^.block^.code; while op <> nil do begin Check(op, lp2); op := op^.next; end; {while} lp2 := lp2^.next; end; {while} end; {MarkInvariants} procedure RemoveInvariants (llp: loopListPtr); { Remove loop invariant calculations } { } { parameters: } { llp - pointer to the loop entry to process } var icount, oldIcount: integer; {invariant order counters} nhp: blockPtr; {new loop hedaer pointer} op1, op2, op3: icptr; {used to reverse the code list} procedure CreateHeader; { Create the new loop header } { } { Notes: As a side effect, CreateHeader sets nhp to point to } { the new loop header. } var lp: loopPtr; {new loop list entry} ohp: blockPtr; {old loop hedaer pointer} begin {CreateHeader} nhp := pointer(Calloc(sizeof(block))); {create the new block} ohp := llp^.loop^.block; {insert it in the block list} nhp^.last := ohp^.last; if nhp^.last <> nil then nhp^.last^.next := nhp; nhp^.next := ohp; ohp^.last := nhp; new(lp); {add it to the loop list} lp^.next := llp^.loop; llp^.loop := lp; lp^.block := nhp; lp^.exit := false; end; {CreateHeader} function FindInvariant (ic: integer): integer; { Find the next invariant calculation } { } { parameters: } { ic - base count; the new count must exceed this } { } { Returns: count for the invariant record to remove } var lp: loopPtr; {used to trace loop list} op: icptr; {used to trace code list} nic: integer; {lowest count > ic} procedure Check (op: icptr); { See if op or its children represent a newer invariant } { calculation than the one numbered nic } { } { parameters: } { op - instruction to check } { } { Notes: Rejecting pc_bno here is rather odd, but it allows } { expressions _containing_ pc_bno to be removed without } { messing up pc_tri operations by allowing pc_bno to be } { removed as the top level of an expression. } begin {Check} if op^.parents = 0 then begin if op^.left <> nil then Check(op^.left); if op^.right <> nil then Check(op^.right); end {if} else begin if op^.parents < nic then if op^.parents > ic then if op^.opcode <> pc_bno then nic := op^.parents; end; {else} end; {Check} begin {FindInvariant} nic := maxint; lp := llp^.loop; while (lp <> nil) and (nic <> ic+1) do begin op := lp^.block^.code; while op <> nil do begin Check(op); op := op^.next; end; {while} lp := lp^.next; end; {while} FindInvariant := nic; end; {FindInvariant} procedure RemoveInvariant (ic: integer); { Move the invariant calculation to the header } { } { parameters: } { ic - index number for instruction to remove } var done: boolean; {loop termination test} lp: loopPtr; {used to trace loop list} op: icptr; {used to trace code list} procedure Check (op: icptr); { See if a child of op is the target instruction to move } { (If so, move it.) } { } { parameters: } { op - instruction to check } procedure Remove (var op: icptr); { Move a calculation to the loop header } { } { parameters: } { op - invariant calculation to move } var loc, op2, str: icptr; {new opcodes} optype: baseTypeEnum; {type of the temp variable} begin {Remove} if (op^.left <> nil) or (op^.right <> nil) then begin optype := TypeOf(op); {create a temp label} loc := pointer(Calloc(sizeof(intermediate_code))); loc^.opcode := dc_loc; loc^.optype := cgWord; maxLoc := maxLoc + 1; loc^.r := maxLoc; loc^.q := TypeSize(optype); loc^.next := nhp^.code; nhp^.code := loc; {make a copy of the tree} op2 := pointer(Malloc(sizeof(intermediate_code))); op2^ := op^; op^.opcode := pc_lod; {substitute a load of the temp} op^.optype := optype; op^.r := loc^.r; op^.q := 0; op^.left := nil; op^.right := nil; {store the temp result} str := pointer(Calloc(sizeof(intermediate_code))); str^.opcode := pc_str; str^.optype := optype; str^.r := loc^.r; str^.q := 0; str^.left := op2; str^.next := loc^.next; {insert the store in the basic block} loc^.next := str; end; {if} done := true; end; {Remove} begin {Check} if op^.left <> nil then begin if op^.left^.parents = ic then Remove(op^.left); if not done then Check(op^.left); end; {if} if not done then if op^.right <> nil then begin if op^.right^.parents = ic then Remove(op^.right); if not done then Check(op^.right); end; {if} end; {Check} procedure RemoveTop (var op: icptr); { Move a top-level instruction to the header } { } { parameters: } { op - top level instruction to remove } var op2: icptr; {temp operation} begin {RemoveTop} op2 := op; op := op^.next; op2^.next := nhp^.code; nhp^.code := op2; end; {RemoveTop} begin {RemoveInvariant} lp := llp^.loop; done := false; while not done do begin op := lp^.block^.code; if op <> nil then if op^.parents = ic then begin RemoveTop(lp^.block^.code); done := true; end {if} else begin Check(op); while (op^.next <> nil) and (not done) do begin if op^.next^.parents = ic then begin RemoveTop(op^.next); done := true; end {if} else Check(op^.next); if op^.next <> nil then op := op^.next; end; {while} end; {else} lp := lp^.next; if lp = nil then done := true; end; {while} end; {RemoveInvariant} begin {RemoveInvariants} CreateHeader; {create a loop header block} icount := 0; {find & remove all invariants} repeat oldIcount := icount; icount := FindInvariant (icount); if icount <> maxint then RemoveInvariant(icount); until icount = maxint; op1 := nhp^.code; {reverse the new code list} op2 := nil; while op1 <> nil do begin op3 := op1; op1 := op1^.next; op3^.next := op2; op2 := op3; end; {while} nhp^.code := op2; end; {RemoveInvariants} procedure ZeroParents (lp: loopPtr); { Zero the parents field in all nodes } { } { parameters: } { lp - loop for which to zero the parents } var op: icptr; {used to trace the opcode list} procedure Zero (op: icptr); { Zero the parents field for this node and its } { children. } { } { parameters: } { op - node to zero } begin {Zero} op^.parents := 0; if op^.left <> nil then Zero(op^.left); if op^.right <> nil then Zero(op^.right); end; {Zero} begin {ZeroParents} while lp <> nil do begin op := lp^.block^.code; while op <> nil do begin Zero(op); op := op^.next; end; {while} lp := lp^.next; end; {while} end; {ZeroParents} begin {LoopInvariantRemoval} Spin; FindLoops; {find a list of natural loops} llp := loops; {scan the loops...} icount := 1; while llp <> nil do begin Spin; ZeroParents(llp^.loop); {set the parents field to zero} while MarkInvariants(llp^.loop) do {mark the loop invariant computations} ; if icount <> 1 then RemoveInvariants(llp); {remove loop invariant calculations} llp := llp^.next; end; {while} while loops <> nil do begin {dispose of the loop lists} while loops^.loop <> nil do begin lp := loops^.loop; loops^.loop := lp^.next; dispose(lp); end; {while} llp := loops; loops := llp^.next; dispose(llp); end; {while} end; {LoopInvariantRemoval} function RemoveDeadNodes: boolean; { Checks for and removes unreachable nodes } { } { Returns: True if there were dead nodes, else false } var bb, bb2: blockPtr; {used to trace basic block lists} begin {RemoveDeadNodes} RemoveDeadNodes := false; bb := DAGblocks; bb2 := bb^.next; while bb2 <> nil do if not bb2^.visited then begin RemoveDeadNodes := true; bb2 := bb2^.next; bb^.next := bb2; end {if} else begin bb := bb2; bb2 := bb2^.next; end; {else} end; {RemoveDeadNodes} begin {DoLoopOptimization} repeat DepthFirstOrder; {create the depth first tree} until not RemoveDeadNodes; ReachingDefinitions; {find reaching definitions} Dominators; {find the lists of dominators} LoopInvariantRemoval; {remove loop invariant computations} while dft <> nil do begin {dispose of the depth first tree} dft2 := dft; dft := dft2^.next; dispose(dft2); end; {while} while backEdge <> nil do begin {dispose of the back edge list} dft2 := backEdge; backEdge := dft2^.next; dispose(dft2); end; {while} end; {DoLoopOptimization} {---------------------------------------------------------------} procedure DAG {code: icptr}; { place an op code in a DAG or tree } { } { parameters: } { code - opcode } var temp: icptr; {temp node} procedure Generate; { generate the code for the current procedure } var op: icptr; {temp opcode pointers} procedure BasicBlocks; { Break the code up into basic blocks } var blast: blockPtr; {last block pointer} bp: blockPtr; {current block pointer} cb: icptr; {last code in block pointer} cp: icptr; {current code pointer} begin {BasicBlocks} cp := DAGhead; DAGblocks := nil; if cp <> nil then begin bp := pointer(Calloc(sizeof(block))); DAGblocks := bp; blast := bp; bp^.code := cp; cb := cp; cp := cp^.next; cb^.next := nil; while cp <> nil do {labels start a new block} if cp^.opcode = dc_lab then begin Spin; bp := pointer(Calloc(sizeof(block))); bp^.last := blast; blast^.next := bp; blast := bp; bp^.code := cp; cb := cp; cp := cp^.next; cb^.next := nil; end {if} {conditionals are followed by a new block} else if cp^.opcode in [pc_fjp, pc_tjp, pc_ujp, pc_ret, pc_xjp] then begin Spin; while cp^.next^.opcode = pc_add do begin cb^.next := cp; cb := cp; cp := cp^.next; cb^.next := nil; end; {while} cb^.next := cp; cb := cp; cp := cp^.next; cb^.next := nil; bp := pointer(Calloc(sizeof(block))); bp^.last := blast; blast^.next := bp; blast := bp; bp^.code := cp; cb := cp; cp := cp^.next; cb^.next := nil; end {else if} else begin {all other statements get added to a block} cb^.next := cp; cb := cp; cp := cp^.next; cb^.next := nil; end; {else} end; {if} end; {BasicBlocks} begin {Generate} if peepHole then begin {peephole optimization} peepSpin := 0; repeat rescan := false; PeepHoleOptimization(DAGhead); op := DAGHead; while op^.next <> nil do begin PeepHoleOptimization(op^.next); op := op^.next; end; {while} CheckLabels; until not rescan; end; {if} BasicBlocks; {build the basic blocks} if (commonSubexpression or loopOptimizations) and (not prsFound) then FlagIndirectUses; {create a list of all indirect uses} if commonSubexpression and {common sub-expression removal} (not prsFound) then CommonSubexpressionElimination; if loopOptimizations and {loop optimizations} (not prsFound) then DoLoopOptimization; { if printSymbols then {debug} { PrintBlocks(@'DAG: ', DAGblocks); {debug} if (commonSubexpression or loopOptimizations) and (not prsFound) then DisposeOpList(c_ind); {dispose of indirect use list} Gen(DAGblocks); {generate native code} if loopOptimizations and {dump and dynamic space} (not prsFound) then DumpLoopLists; DAGhead := nil; {reset the DAG pointers} end; {Generate} procedure Push (code: icptr); { place a node on the operation stack } { } { parameters: } { code - node } begin {Push} code^.next := DAGhead; DAGhead := code; end; {Push} function Pop: icptr; { pop a node from the operation stack } { } { returns: node pointer or nil } var node: icptr; {node poped} tn: icptr; {temp node} begin {Pop} node := DAGhead; if node = nil then Error(cge1) else begin DAGhead := node^.next; node^.next := nil; end; {else} if node^.opcode = dc_loc then begin tn := node; node := Pop; Push(tn); end; {if} Pop := node; end; {Pop} procedure Reverse; { Reverse the operation stack } var list, temp: icptr; {work pointers} begin {Reverse} list := nil; while DAGhead <> nil do begin temp := DAGhead; DAGhead := temp^.next; temp^.next := list; list := temp; end; {while} DAGhead := list; end; {Reverse} begin {DAG} case code^.opcode of pc_abi, pc_abl, pc_abr, pc_acs, pc_asn, pc_atn, pc_bnl, pc_bnt, pc_chk, pc_cos, pc_cnv, pc_csp, pc_cum, pc_cup, pc_dec, pc_exp, pc_fjp, pc_inc, pc_ind, pc_log, pc_ngi, pc_ngl, pc_ngr, pc_not, pc_odd, pc_odl, pc_pds, pc_rnd, pc_rn4, pc_sin, pc_siz, pc_sqi, pc_sql, pc_sqr, pc_sqt, pc_sro, pc_stk, pc_str, pc_tan, pc_tjp, pc_tl1, pc_tl2, pc_vct, pc_xjp: begin code^.left := Pop; Push(code); end; pc_adi, pc_adl, pc_adr, pc_and, pc_at2, pc_bal, pc_blr, pc_blx, pc_bnd, pc_bno, pc_bor, pc_bxr, pc_cui, pc_dif, pc_dvi, pc_dvl, pc_dvr, pc_equ, pc_geq, pc_grt, pc_inn, pc_int, pc_ior, pc_ixa, pc_leq, pc_les, pc_mdl, pc_mod, pc_mov, pc_mpi, pc_mpl, pc_mpr, pc_neq, pc_pwr, pc_sbi, pc_sbl, pc_sbr, pc_sgs, pc_shl, pc_shr, pc_sll, pc_slr, pc_sto, pc_udi, pc_udl, pc_uim, pc_ulm, pc_umi, pc_uml, pc_uni, pc_usr, pc_vsr: begin code^.right := Pop; code^.left := Pop; Push(code); end; dc_dst, dc_glb, dc_lab, dc_pin, dc_sym, pc_add, pc_ent, pc_fix, pc_lad, pc_lao, pc_lca, pc_lda, pc_ldc, pc_ldo, pc_lla, pc_lnm, pc_lod, pc_lsl, pc_nam, pc_nop, pc_ret, pc_ujp: Push(code); pc_prs: begin Push(code); prsFound := true; end; pc_cnn: begin code^.opcode := pc_cnv; temp := Pop; code^.left := Pop; Push(code); Push(temp); end; dc_fun, dc_loc: begin Push(code); if code^.r > maxLoc then maxLoc := code^.r; end; dc_prm: begin Push(code); if code^.s > maxLoc then maxLoc := code^.s; end; dc_str: begin Push(code); maxLoc := 0; prsFound := false; end; dc_enp: begin Push(code); Reverse; Generate; end; otherwise: Error(cge1); {invalid opcode} end; {case} end; {DAG} end. {$append 'dag.asm'}