From ec1407bdae7fef104c0af6340f155d45ff276bb2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Jul 2009 22:27:42 -0500 Subject: [PATCH 01/81] compiler.cfg.dcn: starting work on deconcatenatization pass to replace compiler.cfg.stack-analysis --- basis/compiler/cfg/dcn/dcn-tests.factor | 394 ++++++++++++++++++ basis/compiler/cfg/dcn/dcn.factor | 30 ++ basis/compiler/cfg/dcn/global/global.factor | 202 +++++++++ basis/compiler/cfg/dcn/height/height.factor | 82 ++++ basis/compiler/cfg/dcn/local/local.factor | 73 ++++ basis/compiler/cfg/dcn/rewrite/rewrite.factor | 10 + 6 files changed, 791 insertions(+) create mode 100644 basis/compiler/cfg/dcn/dcn-tests.factor create mode 100644 basis/compiler/cfg/dcn/dcn.factor create mode 100644 basis/compiler/cfg/dcn/global/global.factor create mode 100644 basis/compiler/cfg/dcn/height/height.factor create mode 100644 basis/compiler/cfg/dcn/local/local.factor create mode 100644 basis/compiler/cfg/dcn/rewrite/rewrite.factor diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor new file mode 100644 index 0000000000..997dcb160d --- /dev/null +++ b/basis/compiler/cfg/dcn/dcn-tests.factor @@ -0,0 +1,394 @@ +IN: compiler.cfg.dcn.tests +USING: tools.test kernel accessors namespaces assocs +cpu.architecture vectors sequences +compiler.cfg +compiler.cfg.debugger +compiler.cfg.registers +compiler.cfg.predecessors +compiler.cfg.instructions +compiler.cfg.dcn.height +compiler.cfg.dcn.local +compiler.cfg.dcn.local.private +compiler.cfg.dcn.global +compiler.cfg.dcn.global.private +compiler.cfg.dcn.rewrite ; + +: test-local-dcn ( insns -- insns' ) + swap >>instructions + [ local-analysis ] keep + instructions>> ; + +[ + V{ + T{ ##copy f V int-regs 1 V int-regs 0 } + T{ ##copy f V int-regs 3 V int-regs 2 } + T{ ##copy f V int-regs 5 V int-regs 4 } + } +] [ + V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 0 } + T{ ##peek f V int-regs 2 D 1 } + T{ ##peek f V int-regs 3 D 1 } + T{ ##replace f V int-regs 2 D 1 } + T{ ##replace f V int-regs 4 D 2 } + T{ ##peek f V int-regs 5 D 2 } + T{ ##replace f V int-regs 5 D 2 } + T{ ##replace f V int-regs 6 D 0 } + } test-local-dcn +] unit-test + +[ + H{ + { V int-regs 1 V int-regs 0 } + { V int-regs 3 V int-regs 2 } + { V int-regs 5 V int-regs 4 } + } +] [ + copies get +] unit-test + +[ + H{ + { D 0 V int-regs 0 } + { D 1 V int-regs 2 } + } +] [ reads-locations get ] unit-test + +[ + H{ + { D 0 V int-regs 6 } + { D 2 V int-regs 4 } + } +] [ writes-locations get ] unit-test + +: test-global-dcn ( -- ) + cfg new 0 get >>entry + compute-predecessors + [ compute-heights ] + [ compute-local-sets ] + [ compute-global-sets ] tri ; + +V{ T{ ##return } } 0 test-bb + +[ ] [ test-global-dcn ] unit-test + +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##replace f V int-regs 1 D 1 } +} 1 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 2 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 1vector >>successors drop + +[ t ] [ 0 get kill-block? ] unit-test +[ t ] [ 2 get kill-block? ] unit-test + +[ ] [ test-global-dcn ] unit-test + +[ t ] [ D 0 1 get peek-in key? ] unit-test + +[ f ] [ D 0 0 get peek-in key? ] unit-test + +[ t ] [ D 0 1 get avail-out key? ] unit-test + +[ f ] [ D 0 0 get avail-out key? ] unit-test + +[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test + +[ { } ] [ 1 get 2 get inserting-peeks ] unit-test + +[ { } ] [ 0 get 1 get inserting-replaces ] unit-test + +[ { D 1 } ] [ 1 get 2 get inserting-replaces ] unit-test + +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##branch } +} 1 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 3 test-bb + +V{ + T{ ##peek f V int-regs 1 D 0 } + T{ ##peek f V int-regs 2 D 1 } + T{ ##replace f V int-regs 2 D 0 } + T{ ##branch } +} 4 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 5 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 4 get V{ } 2sequence >>successors drop +2 get 3 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop + +[ ] [ test-global-dcn ] unit-test + +[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test +[ { } ] [ 0 get 1 get inserting-replaces ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks ] unit-test +[ { } ] [ 1 get 2 get inserting-replaces ] unit-test +[ { } ] [ 1 get 3 get inserting-peeks ] unit-test +[ { } ] [ 1 get 3 get inserting-replaces ] unit-test +[ { D 1 } ] [ 2 get 4 get inserting-peeks ] unit-test +[ { } ] [ 2 get 4 get inserting-replaces ] unit-test +[ { } ] [ 4 get 5 get inserting-peeks ] unit-test +[ { D 0 } ] [ 4 get 5 get inserting-replaces ] unit-test + +[ t ] [ D 0 1 get peek-out key? ] unit-test +[ f ] [ D 1 1 get peek-out key? ] unit-test + +[ t ] [ D 1 4 get peek-in key? ] unit-test +[ f ] [ D 1 4 get avail-in key? ] unit-test +[ t ] [ D 1 4 get avail-out key? ] unit-test + +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##peek f V int-regs 1 D 1 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace f V int-regs 2 D 1 } + T{ ##peek f V int-regs 4 D 2 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace f V int-regs 3 D 1 } + T{ ##branch } +} 4 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 5 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop + +[ ] [ test-global-dcn ] unit-test + +[ t ] [ D 1 4 get avail-in key? ] unit-test +[ f ] [ D 2 4 get avail-in key? ] unit-test +[ t ] [ D 1 2 get peek-in key? ] unit-test +[ f ] [ D 1 3 get peek-in key? ] unit-test + +[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test +[ { } ] [ 0 get 1 get inserting-replaces ] unit-test +[ { D 1 } ] [ 1 get 2 get inserting-peeks ] unit-test +[ { } ] [ 1 get 2 get inserting-replaces ] unit-test +[ { D 2 } ] [ 1 get 3 get inserting-peeks ] unit-test +[ { } ] [ 1 get 3 get inserting-replaces ] unit-test +[ { } ] [ 3 get 4 get inserting-peeks ] unit-test +[ { } ] [ 2 get 4 get inserting-replaces ] unit-test +[ { } ] [ 3 get 4 get inserting-replaces ] unit-test +[ { D 1 } ] [ 4 get 5 get inserting-replaces ] unit-test + +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##branch } +} 2 test-bb + +V{ + T{ ##call f drop } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##peek f V int-regs 1 D 0 } + T{ ##return } +} 4 test-bb + +[ t ] [ 0 get kill-block? ] unit-test +[ t ] [ 3 get kill-block? ] unit-test + +0 get 1 get 1vector >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop + +[ ] [ test-global-dcn ] unit-test + +[ t ] [ D 0 2 get avail-out key? ] unit-test +[ f ] [ D 0 3 get peek-out key? ] unit-test +[ f ] [ D 0 3 get avail-out key? ] unit-test +[ f ] [ D 0 4 get avail-in key? ] unit-test + +[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks ] unit-test +[ { } ] [ 1 get 3 get inserting-peeks ] unit-test +[ { } ] [ 2 get 4 get inserting-peeks ] unit-test +[ { D 0 } ] [ 3 get 4 get inserting-peeks ] unit-test + +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 1 test-bb + +V{ T{ ##return } } 2 test-bb + +V{ T{ ##branch } } 3 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +3 get 1 get 1vector >>successors drop + +[ ] [ test-global-dcn ] unit-test + +[ t ] [ D 0 1 get avail-out key? ] unit-test + +[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks ] unit-test +[ { } ] [ 1 get 3 get inserting-peeks ] unit-test +[ { } ] [ 3 get 1 get inserting-peeks ] unit-test + +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##branch } +} 1 test-bb + +V{ + T{ ##call f drop } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##branch } +} 3 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 4 test-bb + +V{ + T{ ##peek f V int-regs 1 D 0 } + T{ ##branch } +} 5 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 6 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop +5 get 6 get 1vector >>successors drop + +[ ] [ test-global-dcn ] unit-test + +[ { } ] [ 0 get 1 get inserting-peeks ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks ] unit-test +[ { } ] [ 3 get 4 get inserting-peeks ] unit-test +[ { D 0 } ] [ 2 get 4 get inserting-peeks ] unit-test +[ { D 0 } ] [ 1 get 3 get inserting-peeks ] unit-test +[ { } ] [ 4 get 5 get inserting-peeks ] unit-test +[ { } ] [ 5 get 6 get inserting-peeks ] unit-test + +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##branch } +} 1 test-bb + +V{ + T{ ##replace f V int-regs 1 D 0 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##peek f V int-regs 2 D 0 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 4 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 5 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop + +[ ] [ test-global-dcn ] unit-test + +[ { } ] [ 1 get 2 get inserting-peeks ] unit-test +[ { } ] [ 1 get 2 get inserting-replaces ] unit-test +[ { D 0 } ] [ 1 get 3 get inserting-peeks ] unit-test +[ { } ] [ 1 get 3 get inserting-replaces ] unit-test +[ { } ] [ 2 get 4 get inserting-peeks ] unit-test +[ { D 0 } ] [ 2 get 4 get inserting-replaces ] unit-test +[ { } ] [ 3 get 4 get inserting-peeks ] unit-test +[ { } ] [ 3 get 4 get inserting-replaces ] unit-test +[ { } ] [ 4 get 5 get inserting-peeks ] unit-test +[ { } ] [ 4 get 5 get inserting-replaces ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/dcn.factor b/basis/compiler/cfg/dcn/dcn.factor new file mode 100644 index 0000000000..f6cd5ec617 --- /dev/null +++ b/basis/compiler/cfg/dcn/dcn.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: ; +IN: compiler.cfg.dcn + +! "DeConcatenatizatioN" -- dataflow analysis to recover registers +! from stack locations. + +! Local sets: +! - P(b): locations that block b peeks before replacing +! - R(b): locations that block b replaces +! - A(b): P(b) \/ R(b) -- locations that are available in registers at the end of b + +! Global sets: +! - P_out(b) = /\ P_in(sux) for sux in successors(b) +! - P_in(b) = (P_out(b) - R(b)) \/ P(b) +! +! - R_in(b) = R_out(b) \/ R(b) +! - R_out(b) = \/ R_in(sux) for sux in successors(b) +! +! - A_in(b) = /\ A_out(pred) for pred in predecessors(b) +! - A_out(b) = A_in(b) \/ P(b) \/ R(b) + +! On every edge [b --> sux], insert a replace for each location in +! R_out(b) - R_in(sux) + +! On every edge [pred --> b], insert a peek for each location in +! P_in(b) - (P_out(pred) \/ A_out(pred)) + +! Locations are height-normalized. \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/global/global.factor b/basis/compiler/cfg/dcn/global/global.factor new file mode 100644 index 0000000000..2c3d563afc --- /dev/null +++ b/basis/compiler/cfg/dcn/global/global.factor @@ -0,0 +1,202 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs deques dlists fry kernel namespaces sequences +combinators combinators.short-circuit compiler.cfg.instructions +compiler.cfg.dcn.local compiler.cfg.rpo compiler.cfg ; +IN: compiler.cfg.dcn.global + +> { + [ length 2 = ] + [ first kill-vreg-insn? ] + } 1&& ; + +: assoc-refine ( seq -- assoc ) + [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ; + +SYMBOL: work-list + +: add-to-work-list ( basic-blocks -- ) + work-list get '[ _ push-front ] each ; + +! Peek analysis. Peek-in is the set of all locations anticipated at +! the start of a basic block. +SYMBOLS: peek-ins peek-outs ; + +PRIVATE> + +: peek-in ( bb -- assoc ) peek-ins get at ; +: peek-out ( bb -- assoc ) peek-outs get at ; + +> peek-ins get '[ _ at ] map assoc-refine ; + +M: kill-block compute-peek-out drop f ; + +: update-peek-out ( bb -- ? ) + [ compute-peek-out ] keep peek-outs get maybe-set-at ; + +: peek-step ( bb -- ) + dup update-peek-out [ + dup update-peek-in + [ predecessors>> add-to-work-list ] [ drop ] if + ] [ drop ] if ; + +: compute-peek-sets ( cfg -- ) + H{ } clone peek-ins set + H{ } clone peek-outs set + post-order add-to-work-list work-list get [ peek-step ] slurp-deque ; + +! Replace analysis. Replace-in is the set of all locations which +! will be overwritten at some point after the start of a basic block. +SYMBOLS: replace-ins replace-outs ; + +PRIVATE> + +: replace-in ( bb -- assoc ) replace-ins get at ; +: replace-out ( bb -- assoc ) replace-outs get at ; + +> replace-outs get '[ _ at ] map assoc-refine ; + +M: kill-block compute-replace-in drop f ; + +: update-replace-in ( bb -- ? ) + [ compute-replace-in ] keep replace-ins get maybe-set-at ; + +GENERIC: compute-replace-out ( bb -- assoc ) + +M: basic-block compute-replace-out + [ replace-in ] [ replace ] bi assoc-union ; + +M: kill-block compute-replace-out drop f ; + +: update-replace-out ( bb -- ? ) + [ compute-replace-out ] keep replace-outs get maybe-set-at ; + +: replace-step ( bb -- ) + dup update-replace-in [ + dup update-replace-out + [ successors>> add-to-work-list ] [ drop ] if + ] [ drop ] if ; + +: compute-replace-sets ( cfg -- ) + H{ } clone replace-ins set + H{ } clone replace-outs set + reverse-post-order add-to-work-list work-list get [ replace-step ] slurp-deque ; + +! Availability analysis. Avail-out is the set of all locations +! in registers at the end of a basic block. +SYMBOLS: avail-ins avail-outs ; + +PRIVATE> + +: avail-in ( bb -- assoc ) avail-ins get at ; +: avail-out ( bb -- assoc ) avail-outs get at ; + +> avail-outs get '[ _ at ] map assoc-refine ; + +M: kill-block compute-avail-in drop f ; + +: update-avail-in ( bb -- ? ) + [ compute-avail-in ] keep avail-ins get maybe-set-at ; + +GENERIC: compute-avail-out ( bb -- assoc ) + +M: basic-block compute-avail-out + [ avail-in ] [ peek ] [ replace ] tri assoc-union assoc-union ; + +M: kill-block compute-avail-out drop f ; + +: update-avail-out ( bb -- ? ) + [ compute-avail-out ] keep avail-outs get maybe-set-at ; + +: avail-step ( bb -- ) + dup update-avail-in [ + dup update-avail-out + [ successors>> add-to-work-list ] [ drop ] if + ] [ drop ] if ; + +: compute-avail-sets ( cfg -- ) + H{ } clone avail-ins set + H{ } clone avail-outs set + reverse-post-order add-to-work-list work-list get [ avail-step ] slurp-deque ; + +! Kill analysis. Kill-in is the set of all locations +! which are going to be overwritten. +SYMBOLS: kill-ins kill-outs ; + +PRIVATE> + +: kill-in ( bb -- assoc ) kill-ins get at ; +: kill-out ( bb -- assoc ) kill-outs get at ; + +> kill-ins get '[ _ at ] map assoc-refine ; + +M: kill-block compute-kill-out drop f ; + +: update-kill-out ( bb -- ? ) + [ compute-kill-out ] keep kill-outs get maybe-set-at ; + +: kill-step ( bb -- ) + dup update-kill-out [ + dup update-kill-in + [ predecessors>> add-to-work-list ] [ drop ] if + ] [ drop ] if ; + +: compute-kill-sets ( cfg -- ) + H{ } clone kill-ins set + H{ } clone kill-outs set + post-order add-to-work-list work-list get [ kill-step ] slurp-deque ; + +PRIVATE> + +! Main word +: compute-global-sets ( cfg -- ) + work-list set + { + [ compute-peek-sets ] + [ compute-replace-sets ] + [ compute-avail-sets ] + [ compute-kill-sets ] + } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/height/height.factor b/basis/compiler/cfg/dcn/height/height.factor new file mode 100644 index 0000000000..2c799a28e7 --- /dev/null +++ b/basis/compiler/cfg/dcn/height/height.factor @@ -0,0 +1,82 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs accessors sequences kernel math locals fry +compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.registers ; +IN: compiler.cfg.dcn.height + +! Compute block in-height and out-height sets. These are relative to the +! stack height from the start of the procedure. + +> ; + +! XXX +! M: ##call ds-height-change height>> ; + +M: ##call ds-height-change drop 0 ; + +M: ##alien-invoke ds-height-change height>> ; + +M: ##alien-indirect ds-height-change height>> ; + +GENERIC: rs-height-change ( insn -- n ) + +M: insn rs-height-change drop 0 ; + +M: ##inc-r rs-height-change n>> ; + +:: compute-in-height ( bb in out -- ) + bb predecessors>> [ out at ] map-find drop 0 or + bb in set-at ; + +:: compute-out-height ( bb in out quot -- ) + bb instructions>> + bb in at + [ quot call + ] reduce + bb out set-at ; inline + +:: compute-height ( bb in out quot -- ) + bb in get out get + [ compute-in-height ] + [ quot compute-out-height ] 3bi ; inline + +: compute-ds-height ( bb -- ) + in-ds-heights out-ds-heights [ ds-height-change ] compute-height ; + +: compute-rs-height ( bb -- ) + in-rs-heights out-rs-heights [ rs-height-change ] compute-height ; + +PRIVATE> + +: compute-heights ( cfg -- ) + H{ } clone in-ds-heights set + H{ } clone out-ds-heights set + H{ } clone in-rs-heights set + H{ } clone out-rs-heights set + [ + [ compute-rs-height ] + [ compute-ds-height ] bi + ] each-basic-block ; + +GENERIC# translate-in-loc 1 ( loc bb -- loc' ) + +M: ds-loc translate-in-loc n>> in-ds-heights get at + ; +M: rs-loc translate-in-loc n>> in-rs-heights get at + ; + +GENERIC# translate-out-loc 1 ( loc bb -- loc' ) + +M: ds-loc translate-out-loc n>> out-ds-heights get at + ; +M: rs-loc translate-out-loc n>> out-rs-heights get at + ; + +: translate-in-set ( assoc bb -- assoc' ) + '[ [ _ translate-in-loc ] dip ] assoc-map ; + +: translate-out-set ( assoc bb -- assoc' ) + '[ [ _ translate-out-loc ] dip ] assoc-map ; diff --git a/basis/compiler/cfg/dcn/local/local.factor b/basis/compiler/cfg/dcn/local/local.factor new file mode 100644 index 0000000000..4a63fdbdc0 --- /dev/null +++ b/basis/compiler/cfg/dcn/local/local.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel make +namespaces sequences +compiler.cfg.rpo +compiler.cfg.instructions ; +IN: compiler.cfg.dcn.local + +vreg ( loc -- vreg ) + dup writes-locations get at + [ ] [ reads-locations get at ] ?if ; + +GENERIC: visit ( insn -- ) + +M: insn visit , ; + +M: ##peek visit + ! If location is in a register already, copy existing + ! register to destination. Otherwise, associate the + ! location with the register. + [ dst>> ] [ loc>> ] bi dup loc>vreg + [ [ record-copy ] [ ##copy ] 2bi ] + [ reads-locations get set-at ] + ?if ; + +M: ##replace visit + ! If location already contains the same value, do nothing. + ! Otherwise, associate the location with the register. + [ src>> resolve-copy ] [ loc>> ] bi 2dup loc>vreg = + [ 2drop ] [ writes-locations get set-at ] if ; + +M: ##copy visit + ! Not needed at this point because IR doesn't have ##copy + ! on input to dcn pass, but in the future it might. + [ dst>> ] [ src>> resolve-copy ] bi record-copy ; + +: local-analysis ( bb -- ) + ! Removes all ##peek and ##replace from the basic block. + ! Conceptually, moves all ##peeks to the start + ! (reads-locations assoc) and all ##replaces to the end + ! (writes-locations assoc). + H{ } clone copies set + H{ } clone reads-locations set + H{ } clone writes-locations set + [ [ [ visit ] each ] V{ } make ] change-instructions drop ; + +SYMBOLS: peeks replaces ; + +: visit-block ( bb -- ) + [ local-analysis ] + [ [ reads-locations get ] dip peeks get set-at ] + [ [ writes-locations get ] dip replaces get set-at ] + tri ; + +PRIVATE> + +: peek ( bb -- assoc ) peeks get at ; +: replace ( bb -- assoc ) replaces get at ; + +: compute-local-sets ( cfg -- ) + H{ } clone peeks set + H{ } clone replaces set + [ visit-block ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/rewrite/rewrite.factor b/basis/compiler/cfg/dcn/rewrite/rewrite.factor new file mode 100644 index 0000000000..2d95f0f3e0 --- /dev/null +++ b/basis/compiler/cfg/dcn/rewrite/rewrite.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs kernel compiler.cfg.dcn.global ; +IN: compiler.cfg.dcn.rewrite + +: inserting-peeks ( from to -- seq ) + peek-in swap [ peek-out ] [ avail-out ] bi assoc-union assoc-diff keys ; + +: inserting-replaces ( from to -- seq ) + [ replace-out ] [ kill-in ] bi* assoc-diff keys ; \ No newline at end of file From 605b37a9496665b28fee8b14e6977255b27d33ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 18 Jul 2009 23:08:53 -0500 Subject: [PATCH 02/81] compiler.cfg.builder: annotate calls with height changes, once again --- basis/compiler/cfg/builder/builder.factor | 15 +++++++++------ basis/compiler/cfg/dcn/height/height.factor | 10 +++++----- .../compiler/cfg/instructions/instructions.factor | 2 +- .../compiler/cfg/intrinsics/fixnum/fixnum.factor | 2 +- basis/compiler/cfg/utilities/utilities.factor | 5 ++++- 5 files changed, 20 insertions(+), 14 deletions(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 2eff8b9e28..30c15b787f 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -63,15 +63,18 @@ GENERIC: emit-node ( node -- ) basic-block get successors>> push basic-block off ; -: emit-call ( word -- ) - dup loops get key? - [ loops get at emit-loop-call ] +: emit-call ( word height -- ) + over loops get key? + [ drop loops get at emit-loop-call ] [ ##call ##branch begin-basic-block ] if ; ! #recursive +: recursive-height ( #recursive -- n ) + [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ; + : emit-recursive ( #recursive -- ) - [ label>> id>> emit-call ] + [ [ label>> id>> ] [ recursive-height ] bi emit-call ] [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ; : remember-loop ( label -- ) @@ -133,10 +136,10 @@ M: #dispatch emit-node ! #call M: #call emit-node dup word>> dup "intrinsic" word-prop - [ emit-intrinsic ] [ nip emit-call ] if ; + [ emit-intrinsic ] [ swap call-height emit-call ] if ; ! #call-recursive -M: #call-recursive emit-node label>> id>> emit-call ; +M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ; ! #push M: #push emit-node diff --git a/basis/compiler/cfg/dcn/height/height.factor b/basis/compiler/cfg/dcn/height/height.factor index 2c799a28e7..ec505d81f2 100644 --- a/basis/compiler/cfg/dcn/height/height.factor +++ b/basis/compiler/cfg/dcn/height/height.factor @@ -17,14 +17,14 @@ M: insn ds-height-change drop 0 ; M: ##inc-d ds-height-change n>> ; -! XXX -! M: ##call ds-height-change height>> ; +M: ##call ds-height-change height>> ; -M: ##call ds-height-change drop 0 ; +: alien-node-height ( node -- ) + params>> [ out-d>> length ] [ in-d>> length ] bi - ; -M: ##alien-invoke ds-height-change height>> ; +M: ##alien-invoke ds-height-change alien-node-height ; -M: ##alien-indirect ds-height-change height>> ; +M: ##alien-indirect ds-height-change alien-node-height ; GENERIC: rs-height-change ( insn -- n ) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index d1b7592aaf..dc656d61fa 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -53,7 +53,7 @@ INSN: ##inc-r { n integer } ; ! Subroutine calls INSN: ##stack-frame stack-frame ; -INSN: ##call word ; +INSN: ##call word { height integer } ; INSN: ##jump word ; INSN: ##return ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 5dc04d47e1..cfc07624fe 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -65,7 +65,7 @@ IN: compiler.cfg.intrinsics.fixnum [ -2 ##inc-d ds-push ] with-branch ; : emit-overflow-case ( word -- final-bb ) - [ ##call ] with-branch ; + [ -1 ##call ] with-branch ; : emit-fixnum-overflow-op ( quot word -- ) [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 9cb8bf26f9..32da1a5d06 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -33,8 +33,11 @@ IN: compiler.cfg.utilities building off basic-block off ; +: call-height ( #call -- n ) + [ out-d>> length ] [ in-d>> length ] bi - ; + : emit-primitive ( node -- ) - word>> ##call ##branch begin-basic-block ; + [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ; : with-branch ( quot -- final-bb ) [ From 0a95ddd1056154c40a34f8ea0df95c4195d42809 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Jul 2009 19:45:23 -0500 Subject: [PATCH 03/81] compiler.cfg.dcn: Implement height tracking --- basis/compiler/cfg/dcn/dcn-tests.factor | 73 +++++++++++++------ basis/compiler/cfg/dcn/global/global.factor | 9 +-- basis/compiler/cfg/dcn/height/height.factor | 10 +-- basis/compiler/cfg/dcn/local/local.factor | 42 ++++++++--- basis/compiler/cfg/utilities/utilities.factor | 6 ++ 5 files changed, 98 insertions(+), 42 deletions(-) diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor index 997dcb160d..40cfaae8f8 100644 --- a/basis/compiler/cfg/dcn/dcn-tests.factor +++ b/basis/compiler/cfg/dcn/dcn-tests.factor @@ -23,18 +23,20 @@ compiler.cfg.dcn.rewrite ; T{ ##copy f V int-regs 1 V int-regs 0 } T{ ##copy f V int-regs 3 V int-regs 2 } T{ ##copy f V int-regs 5 V int-regs 4 } + T{ ##inc-d f -1 } } ] [ V{ T{ ##peek f V int-regs 0 D 0 } T{ ##peek f V int-regs 1 D 0 } - T{ ##peek f V int-regs 2 D 1 } - T{ ##peek f V int-regs 3 D 1 } - T{ ##replace f V int-regs 2 D 1 } - T{ ##replace f V int-regs 4 D 2 } - T{ ##peek f V int-regs 5 D 2 } - T{ ##replace f V int-regs 5 D 2 } - T{ ##replace f V int-regs 6 D 0 } + T{ ##inc-d f -1 } + T{ ##peek f V int-regs 2 D 0 } + T{ ##peek f V int-regs 3 D 0 } + T{ ##replace f V int-regs 2 D 0 } + T{ ##replace f V int-regs 4 D 1 } + T{ ##peek f V int-regs 5 D 1 } + T{ ##replace f V int-regs 5 D 1 } + T{ ##replace f V int-regs 6 D -1 } } test-local-dcn ] unit-test @@ -79,8 +81,9 @@ V{ } 0 test-bb V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##replace f V int-regs 1 D 1 } + T{ ##inc-d f 1 } + T{ ##peek f V int-regs 0 D 1 } + T{ ##replace f V int-regs 1 D 2 } } 1 test-bb V{ @@ -117,12 +120,36 @@ V{ T{ ##branch } } 0 test-bb +V{ + T{ ##peek f V int-regs 0 D 1 } +} 1 test-bb + +V{ + T{ ##inc-d f -1 } + T{ ##peek f V int-regs 0 D 0 } +} 2 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 1vector >>successors drop + +[ ] [ test-global-dcn ] unit-test + +[ t ] [ D 1 2 get peek-in key? ] unit-test +[ { D 1 } ] [ 0 get 1 get inserting-peeks ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks ] unit-test + +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + V{ T{ ##branch } } 1 test-bb V{ - T{ ##peek f V int-regs 0 D 0 } + T{ ##inc-d f 1 } + T{ ##peek f V int-regs 0 D 1 } T{ ##branch } } 2 test-bb @@ -134,7 +161,8 @@ V{ V{ T{ ##peek f V int-regs 1 D 0 } T{ ##peek f V int-regs 2 D 1 } - T{ ##replace f V int-regs 2 D 0 } + T{ ##inc-d f 1 } + T{ ##replace f V int-regs 2 D 1 } T{ ##branch } } 4 test-bb @@ -180,17 +208,19 @@ V{ V{ T{ ##peek f V int-regs 1 D 1 } + T{ ##inc-d f -1 } T{ ##branch } } 2 test-bb V{ T{ ##replace f V int-regs 2 D 1 } - T{ ##peek f V int-regs 4 D 2 } + T{ ##inc-d f -1 } + T{ ##peek f V int-regs 4 D 1 } T{ ##branch } } 3 test-bb V{ - T{ ##replace f V int-regs 3 D 1 } + T{ ##replace f V int-regs 3 D 0 } T{ ##branch } } 4 test-bb @@ -229,16 +259,17 @@ V{ } 0 test-bb V{ - T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 0 D 1 } T{ ##branch } } 1 test-bb V{ + T{ ##inc-d f -1 } T{ ##branch } } 2 test-bb V{ - T{ ##call f drop } + T{ ##call f drop -1 } T{ ##branch } } 3 test-bb @@ -257,16 +288,16 @@ V{ [ ] [ test-global-dcn ] unit-test -[ t ] [ D 0 2 get avail-out key? ] unit-test -[ f ] [ D 0 3 get peek-out key? ] unit-test -[ f ] [ D 0 3 get avail-out key? ] unit-test -[ f ] [ D 0 4 get avail-in key? ] unit-test +[ t ] [ D 1 2 get avail-out key? ] unit-test +[ f ] [ D 1 3 get peek-out key? ] unit-test +[ f ] [ D 1 3 get avail-out key? ] unit-test +[ f ] [ D 1 4 get avail-in key? ] unit-test -[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test +[ { D 1 } ] [ 0 get 1 get inserting-peeks ] unit-test [ { } ] [ 1 get 2 get inserting-peeks ] unit-test [ { } ] [ 1 get 3 get inserting-peeks ] unit-test [ { } ] [ 2 get 4 get inserting-peeks ] unit-test -[ { D 0 } ] [ 3 get 4 get inserting-peeks ] unit-test +[ { D 1 } ] [ 3 get 4 get inserting-peeks ] unit-test V{ T{ ##prologue } diff --git a/basis/compiler/cfg/dcn/global/global.factor b/basis/compiler/cfg/dcn/global/global.factor index 2c3d563afc..d644ed8703 100644 --- a/basis/compiler/cfg/dcn/global/global.factor +++ b/basis/compiler/cfg/dcn/global/global.factor @@ -2,17 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs deques dlists fry kernel namespaces sequences combinators combinators.short-circuit compiler.cfg.instructions -compiler.cfg.dcn.local compiler.cfg.rpo compiler.cfg ; +compiler.cfg.dcn.local compiler.cfg.rpo compiler.cfg.utilities +compiler.cfg ; IN: compiler.cfg.dcn.global > { - [ length 2 = ] - [ first kill-vreg-insn? ] - } 1&& ; - : assoc-refine ( seq -- assoc ) [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ; diff --git a/basis/compiler/cfg/dcn/height/height.factor b/basis/compiler/cfg/dcn/height/height.factor index ec505d81f2..e38e2db233 100644 --- a/basis/compiler/cfg/dcn/height/height.factor +++ b/basis/compiler/cfg/dcn/height/height.factor @@ -19,7 +19,7 @@ M: ##inc-d ds-height-change n>> ; M: ##call ds-height-change height>> ; -: alien-node-height ( node -- ) +: alien-node-height ( node -- n ) params>> [ out-d>> length ] [ in-d>> length ] bi - ; M: ##alien-invoke ds-height-change alien-node-height ; @@ -67,13 +67,13 @@ PRIVATE> GENERIC# translate-in-loc 1 ( loc bb -- loc' ) -M: ds-loc translate-in-loc n>> in-ds-heights get at + ; -M: rs-loc translate-in-loc n>> in-rs-heights get at + ; +M: ds-loc translate-in-loc [ n>> ] [ in-ds-heights get at ] bi* - ; +M: rs-loc translate-in-loc [ n>> ] [ in-rs-heights get at ] bi* - ; GENERIC# translate-out-loc 1 ( loc bb -- loc' ) -M: ds-loc translate-out-loc n>> out-ds-heights get at + ; -M: rs-loc translate-out-loc n>> out-rs-heights get at + ; +M: ds-loc translate-out-loc [ n>> ] [ out-ds-heights get at ] bi* + ; +M: rs-loc translate-out-loc [ n>> ] [ out-rs-heights get at ] bi* + ; : translate-in-set ( assoc bb -- assoc' ) '[ [ _ translate-in-loc ] dip ] assoc-map ; diff --git a/basis/compiler/cfg/dcn/local/local.factor b/basis/compiler/cfg/dcn/local/local.factor index 4a63fdbdc0..7a34adfb04 100644 --- a/basis/compiler/cfg/dcn/local/local.factor +++ b/basis/compiler/cfg/dcn/local/local.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel make -namespaces sequences -compiler.cfg.rpo -compiler.cfg.instructions ; +USING: accessors assocs kernel make namespaces sequences math +compiler.cfg.rpo compiler.cfg.registers compiler.cfg.instructions +compiler.cfg.dcn.height ; IN: compiler.cfg.dcn.local > ds-height get - ; + +M: rs-loc translate-loc n>> rs-height get - ; + GENERIC: visit ( insn -- ) M: insn visit , ; +M: ##inc-d visit n>> ds-height [ + ] change ; + +M: ##inc-r visit n>> rs-height [ + ] change ; + M: ##peek visit ! If location is in a register already, copy existing ! register to destination. Otherwise, associate the ! location with the register. - [ dst>> ] [ loc>> ] bi dup loc>vreg + [ dst>> ] [ loc>> translate-loc ] bi dup loc>vreg [ [ record-copy ] [ ##copy ] 2bi ] [ reads-locations get set-at ] ?if ; @@ -36,7 +49,7 @@ M: ##peek visit M: ##replace visit ! If location already contains the same value, do nothing. ! Otherwise, associate the location with the register. - [ src>> resolve-copy ] [ loc>> ] bi 2dup loc>vreg = + [ src>> resolve-copy ] [ loc>> translate-loc ] bi 2dup loc>vreg = [ 2drop ] [ writes-locations get set-at ] if ; M: ##copy visit @@ -44,22 +57,33 @@ M: ##copy visit ! on input to dcn pass, but in the future it might. [ dst>> ] [ src>> resolve-copy ] bi record-copy ; +: insert-height-changes ( -- ) + ds-height get dup 0 = [ drop ] [ ##inc-d ] if + rs-height get dup 0 = [ drop ] [ ##inc-r ] if ; + : local-analysis ( bb -- ) ! Removes all ##peek and ##replace from the basic block. ! Conceptually, moves all ##peeks to the start ! (reads-locations assoc) and all ##replaces to the end ! (writes-locations assoc). + 0 ds-height set + 0 rs-height set H{ } clone copies set H{ } clone reads-locations set H{ } clone writes-locations set - [ [ [ visit ] each ] V{ } make ] change-instructions drop ; + [ + [ + [ visit ] each + insert-height-changes + ] V{ } make + ] change-instructions drop ; SYMBOLS: peeks replaces ; : visit-block ( bb -- ) [ local-analysis ] - [ [ reads-locations get ] dip peeks get set-at ] - [ [ writes-locations get ] dip replaces get set-at ] + [ [ reads-locations get ] dip [ translate-in-set ] keep peeks get set-at ] + [ [ writes-locations get ] dip [ translate-in-set ] keep replaces get set-at ] tri ; PRIVATE> diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 32da1a5d06..6edc883af4 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -51,6 +51,12 @@ IN: compiler.cfg.utilities begin-basic-block basic-block get '[ [ _ swap successors>> push ] when* ] each ; +PREDICATE: kill-block < basic-block + instructions>> { + [ length 2 = ] + [ first kill-vreg-insn? ] + } 1&& ; + : back-edge? ( from to -- ? ) [ number>> ] bi@ >= ; From fdef772d67ffcaa3006d8d56702c97c2d64bd21a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Jul 2009 20:12:04 -0500 Subject: [PATCH 04/81] compiler.cfg: if a block has an instruction that kills values it must be the only instruction in the block --- .../cfg/block-joining/block-joining.factor | 10 +--- .../build-stack-frame.factor | 12 +++-- .../compiler/cfg/builder/builder-tests.factor | 15 +++--- basis/compiler/cfg/builder/builder.factor | 17 ++++--- basis/compiler/cfg/checker/checker.factor | 46 +++++++++++++------ basis/compiler/cfg/dcn/dcn-tests.factor | 1 + basis/compiler/cfg/def-use/def-use.factor | 16 +------ .../cfg/instructions/instructions.factor | 28 ++++++----- .../cfg/stack-analysis/stack-analysis.factor | 11 ++--- basis/compiler/cfg/utilities/utilities.factor | 7 ++- 10 files changed, 90 insertions(+), 73 deletions(-) diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor index 982f0866e6..b4c7223435 100644 --- a/basis/compiler/cfg/block-joining/block-joining.factor +++ b/basis/compiler/cfg/block-joining/block-joining.factor @@ -8,20 +8,14 @@ IN: compiler.cfg.block-joining ! Joining blocks that are not calls and are connected by a single CFG edge. ! Predecessors must be recomputed after this. Also this pass does not ! update ##phi nodes and should therefore only run before stack analysis. - -: kill-vreg-block? ( bb -- ? ) - instructions>> { - [ length 2 >= ] - [ penultimate kill-vreg-insn? ] - } 1&& ; - : predecessor ( bb -- pred ) predecessors>> first ; inline : join-block? ( bb -- ? ) { + [ kill-block? not ] [ predecessors>> length 1 = ] - [ predecessor kill-vreg-block? not ] + [ predecessor kill-block? not ] [ predecessor successors>> length 1 = ] [ [ predecessor ] keep back-edge? not ] } 1&& ; diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index 71798da6fc..76b10dda01 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -13,10 +13,16 @@ SYMBOL: spill-counts GENERIC: compute-stack-frame* ( insn -- ) : request-stack-frame ( stack-frame -- ) + frame-required? on stack-frame [ max-stack-frame ] change ; -M: ##stack-frame compute-stack-frame* - frame-required? on +M: ##alien-invoke compute-stack-frame* + stack-frame>> request-stack-frame ; + +M: ##alien-indirect compute-stack-frame* + stack-frame>> request-stack-frame ; + +M: ##alien-callback compute-stack-frame* stack-frame>> request-stack-frame ; M: ##call compute-stack-frame* @@ -45,8 +51,6 @@ M: insn compute-stack-frame* GENERIC: insert-pro/epilogues* ( insn -- ) -M: ##stack-frame insert-pro/epilogues* drop ; - M: ##prologue insert-pro/epilogues* drop frame-required? get [ stack-frame get _prologue ] when ; diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 4a481a09d8..90e42912a1 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -1,12 +1,13 @@ IN: compiler.cfg.builder.tests -USING: tools.test kernel sequences -words sequences.private fry prettyprint alien alien.accessors -math.private compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays -kernel.private math ; +USING: tools.test kernel sequences words sequences.private fry +prettyprint alien alien.accessors math.private compiler.tree.builder +compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger +compiler.cfg.predecessors compiler.cfg.checker arrays locals +byte-arrays kernel.private math slots.private ; ! Just ensure that various CFGs build correctly. -: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ; +: unit-test-cfg ( quot -- ) + '[ _ test-cfg [ compute-predecessors check-cfg ] each ] [ ] swap unit-test ; { [ ] @@ -49,6 +50,8 @@ kernel.private math ; [ "int" f "malloc" { "int" } alien-invoke ] [ "int" { "int" } "cdecl" alien-indirect ] [ "int" { "int" } "cdecl" [ ] alien-callback ] + [ swap - + * ] + [ swap slot ] } [ unit-test-cfg ] each diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 30c15b787f..e3c502e66e 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -63,10 +63,15 @@ GENERIC: emit-node ( node -- ) basic-block get successors>> push basic-block off ; +: emit-trivial-block ( quot -- ) + basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless + call + ##branch begin-basic-block ; inline + : emit-call ( word height -- ) over loops get key? [ drop loops get at emit-loop-call ] - [ ##call ##branch begin-basic-block ] + [ [ ##call ] emit-trivial-block ] if ; ! #recursive @@ -157,7 +162,7 @@ M: #shuffle emit-node ! #return M: #return emit-node - drop ##epilogue ##return ; + drop ##branch begin-basic-block ##epilogue ##return ; M: #return-recursive emit-node label>> id>> loops get key? @@ -181,12 +186,10 @@ M: #terminate emit-node drop ##no-tco basic-block off ; [ return>> return-size >>return ] [ alien-parameters parameter-sizes drop >>params ] bi ; -: alien-stack-frame ( params -- ) - ##stack-frame ; - : emit-alien-node ( node quot -- ) - [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi - ##branch begin-basic-block ; inline + [ + [ params>> dup ] dip call + ] emit-trivial-block ; inline M: #alien-invoke emit-node [ ##alien-invoke ] emit-alien-node ; diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 49ea775600..f9f5211c9c 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -1,34 +1,51 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel compiler.cfg.instructions compiler.cfg.rpo -compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness -combinators.short-circuit accessors math sequences sets assocs ; +USING: kernel combinators.short-circuit accessors math sequences sets +assocs compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use +compiler.cfg.linearization compiler.cfg.liveness +compiler.cfg.utilities ; IN: compiler.cfg.checker -ERROR: last-insn-not-a-jump insn ; +ERROR: bad-kill-block bb ; + +: check-kill-block ( bb -- ) + dup instructions>> first2 + swap ##epilogue? [ [ ##return? ] [ ##callback-return? ] bi or ] [ ##branch? ] if + [ drop ] [ bad-kill-block ] if ; + +ERROR: last-insn-not-a-jump bb ; : check-last-instruction ( bb -- ) - last dup { + dup instructions>> last { [ ##branch? ] [ ##dispatch? ] [ ##conditional-branch? ] [ ##compare-imm-branch? ] - [ ##return? ] - [ ##callback-return? ] - [ ##jump? ] [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] [ ##no-tco? ] } 1|| [ drop ] [ last-insn-not-a-jump ] if ; -ERROR: bad-loop-entry ; +ERROR: bad-loop-entry bb ; : check-loop-entry ( bb -- ) - dup length 2 >= [ + dup instructions>> dup length 2 >= [ 2 head* [ ##loop-entry? ] any? - [ bad-loop-entry ] when - ] [ drop ] if ; + [ bad-loop-entry ] [ drop ] if + ] [ 2drop ] if ; + +ERROR: bad-kill-insn bb ; + +: check-kill-instructions ( bb -- ) + dup instructions>> [ kill-vreg-insn? ] any? + [ bad-kill-insn ] [ drop ] if ; + +: check-normal-block ( bb -- ) + [ check-loop-entry ] + [ check-last-instruction ] + [ check-kill-instructions ] + tri ; ERROR: bad-successors ; @@ -37,10 +54,9 @@ ERROR: bad-successors ; [ bad-successors ] unless ; : check-basic-block ( bb -- ) - [ instructions>> check-last-instruction ] - [ instructions>> check-loop-entry ] + [ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ] [ check-successors ] - tri ; + bi ; ERROR: bad-live-in ; diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor index 40cfaae8f8..29ed81082a 100644 --- a/basis/compiler/cfg/dcn/dcn-tests.factor +++ b/basis/compiler/cfg/dcn/dcn-tests.factor @@ -2,6 +2,7 @@ IN: compiler.cfg.dcn.tests USING: tools.test kernel accessors namespaces assocs cpu.architecture vectors sequences compiler.cfg +compiler.cfg.utilities compiler.cfg.debugger compiler.cfg.registers compiler.cfg.predecessors diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index c8a9d1861b..2aa55df911 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -9,6 +9,7 @@ GENERIC: uses-vregs ( insn -- seq ) M: ##flushable defs-vregs dst>> 1array ; M: ##fixnum-overflow defs-vregs dst>> 1array ; +M: _fixnum-overflow defs-vregs dst>> 1array ; M: insn defs-vregs drop f ; M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ; @@ -47,18 +48,3 @@ M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; M: _dispatch uses-vregs src>> 1array ; M: insn uses-vregs drop f ; - -! Instructions that use vregs -UNION: vreg-insn -##flushable -##write-barrier -##dispatch -##effect -##fixnum-overflow -##conditional-branch -##compare-imm-branch -##phi -##gc -_conditional-branch -_compare-imm-branch -_dispatch ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index dc656d61fa..43d92c9ccc 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -52,7 +52,6 @@ INSN: ##inc-d { n integer } ; INSN: ##inc-r { n integer } ; ! Subroutine calls -INSN: ##stack-frame stack-frame ; INSN: ##call word { height integer } ; INSN: ##jump word ; INSN: ##return ; @@ -160,9 +159,9 @@ INSN: ##write-barrier < ##effect card# table ; INSN: ##alien-global < ##flushable symbol library ; ! FFI -INSN: ##alien-invoke params ; -INSN: ##alien-indirect params ; -INSN: ##alien-callback params ; +INSN: ##alien-invoke params stack-frame ; +INSN: ##alien-indirect params stack-frame ; +INSN: ##alien-callback params stack-frame ; INSN: ##callback-return params ; ! Instructions used by CFG IR only. @@ -230,16 +229,23 @@ INSN: _reload dst class n ; INSN: _copy dst src class ; INSN: _spill-counts counts ; -! Instructions that poison the stack state -UNION: poison-insn - ##jump - ##return - ##callback-return ; +! Instructions that use vregs +UNION: vreg-insn + ##flushable + ##write-barrier + ##dispatch + ##effect + ##fixnum-overflow + ##conditional-branch + ##compare-imm-branch + ##phi + ##gc + _conditional-branch + _compare-imm-branch + _dispatch ; ! Instructions that kill all live vregs UNION: kill-vreg-insn - poison-insn - ##stack-frame ##call ##prologue ##epilogue diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index cf15c0a312..ec34c96a24 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -26,19 +26,14 @@ SYMBOL: global-optimization? [ 2drop ] [ state get untranslate-loc ##replace ] if ] each ; -ERROR: poisoned-state state ; - : sync-state ( -- ) state get { - [ dup poisoned?>> [ poisoned-state ] [ drop ] if ] [ ds-height>> save-ds-height ] [ rs-height>> save-rs-height ] [ save-changed-locs ] [ clear-state ] } cleave ; -: poison-state ( -- ) state get t >>poisoned? drop ; - ! Abstract interpretation GENERIC: visit ( insn -- ) @@ -87,7 +82,11 @@ M: ##replace visit M: ##copy visit [ call-next-method ] [ record-copy ] bi ; -M: poison-insn visit call-next-method poison-state ; +M: ##jump visit sync-state , ; + +M: ##return visit sync-state , ; + +M: ##callback-return visit sync-state , ; M: kill-vreg-insn visit sync-state , ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 6edc883af4..c3d3e47485 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -33,11 +33,16 @@ IN: compiler.cfg.utilities building off basic-block off ; +: emit-trivial-block ( quot -- ) + basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless + call + ##branch begin-basic-block ; inline + : call-height ( #call -- n ) [ out-d>> length ] [ in-d>> length ] bi - ; : emit-primitive ( node -- ) - [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ; + [ [ word>> ] [ call-height ] bi ##call ] emit-trivial-block ; : with-branch ( quot -- final-bb ) [ From e16acae2f5c2e1eaf58be88180dea14aa56922ac Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Jul 2009 01:24:19 -0500 Subject: [PATCH 05/81] compiler.cfg.dcn: flesh out rewrite pass --- basis/compiler/cfg/dcn/dcn-tests.factor | 183 +++++++++++++----- basis/compiler/cfg/dcn/dcn.factor | 18 +- basis/compiler/cfg/dcn/height/height.factor | 28 +-- basis/compiler/cfg/dcn/local/local.factor | 4 +- basis/compiler/cfg/dcn/rewrite/rewrite.factor | 67 ++++++- 5 files changed, 225 insertions(+), 75 deletions(-) diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor index 29ed81082a..585b44364e 100644 --- a/basis/compiler/cfg/dcn/dcn-tests.factor +++ b/basis/compiler/cfg/dcn/dcn-tests.factor @@ -108,13 +108,13 @@ V{ [ f ] [ D 0 0 get avail-out key? ] unit-test -[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test +[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test -[ { } ] [ 0 get 1 get inserting-replaces ] unit-test +[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test -[ { D 1 } ] [ 1 get 2 get inserting-replaces ] unit-test +[ { D 2 } ] [ 1 get 2 get inserting-replaces keys ] unit-test V{ T{ ##prologue } @@ -136,8 +136,8 @@ V{ [ ] [ test-global-dcn ] unit-test [ t ] [ D 1 2 get peek-in key? ] unit-test -[ { D 1 } ] [ 0 get 1 get inserting-peeks ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks ] unit-test +[ { D 1 } ] [ 0 get 1 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test V{ T{ ##prologue } @@ -179,16 +179,21 @@ V{ [ ] [ test-global-dcn ] unit-test -[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test -[ { } ] [ 0 get 1 get inserting-replaces ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces ] unit-test -[ { D 1 } ] [ 2 get 4 get inserting-peeks ] unit-test -[ { } ] [ 2 get 4 get inserting-replaces ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks ] unit-test -[ { D 0 } ] [ 4 get 5 get inserting-replaces ] unit-test +[ f ] [ D 0 1 get avail-out key? ] unit-test +[ f ] [ D 1 1 get avail-out key? ] unit-test +[ t ] [ D 0 4 get peek-in key? ] unit-test +[ t ] [ D 1 4 get peek-in key? ] unit-test + +[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test +[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test +[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test +[ { D 1 } ] [ 1 get 4 get inserting-peeks keys ] unit-test +[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test +[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test +[ { D 1 } ] [ 4 get 5 get inserting-replaces keys ] unit-test [ t ] [ D 0 1 get peek-out key? ] unit-test [ f ] [ D 1 1 get peek-out key? ] unit-test @@ -243,16 +248,16 @@ V{ [ t ] [ D 1 2 get peek-in key? ] unit-test [ f ] [ D 1 3 get peek-in key? ] unit-test -[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test -[ { } ] [ 0 get 1 get inserting-replaces ] unit-test -[ { D 1 } ] [ 1 get 2 get inserting-peeks ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces ] unit-test -[ { D 2 } ] [ 1 get 3 get inserting-peeks ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks ] unit-test -[ { } ] [ 2 get 4 get inserting-replaces ] unit-test -[ { } ] [ 3 get 4 get inserting-replaces ] unit-test -[ { D 1 } ] [ 4 get 5 get inserting-replaces ] unit-test +[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test +[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test +[ { D 1 } ] [ 1 get 2 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test +[ { D 2 } ] [ 1 get 3 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test +[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test +[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test +[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test +[ { D 0 } ] [ 4 get 5 get inserting-replaces keys ] unit-test V{ T{ ##prologue } @@ -294,11 +299,11 @@ V{ [ f ] [ D 1 3 get avail-out key? ] unit-test [ f ] [ D 1 4 get avail-in key? ] unit-test -[ { D 1 } ] [ 0 get 1 get inserting-peeks ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks ] unit-test -[ { } ] [ 2 get 4 get inserting-peeks ] unit-test -[ { D 1 } ] [ 3 get 4 get inserting-peeks ] unit-test +[ { D 1 } ] [ 0 get 1 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test +[ { } ] [ 2 get 4 get inserting-peeks keys ] unit-test +[ { D 0 } ] [ 3 get 4 get inserting-peeks keys ] unit-test V{ T{ ##prologue } @@ -322,10 +327,10 @@ V{ T{ ##branch } } 3 test-bb [ t ] [ D 0 1 get avail-out key? ] unit-test -[ { D 0 } ] [ 0 get 1 get inserting-peeks ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks ] unit-test -[ { } ] [ 3 get 1 get inserting-peeks ] unit-test +[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test +[ { } ] [ 3 get 1 get inserting-peeks keys ] unit-test V{ T{ ##prologue } @@ -369,13 +374,13 @@ V{ [ ] [ test-global-dcn ] unit-test -[ { } ] [ 0 get 1 get inserting-peeks ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks ] unit-test -[ { D 0 } ] [ 2 get 4 get inserting-peeks ] unit-test -[ { D 0 } ] [ 1 get 3 get inserting-peeks ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks ] unit-test -[ { } ] [ 5 get 6 get inserting-peeks ] unit-test +[ { } ] [ 0 get 1 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test +[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test +[ { D 0 } ] [ 2 get 4 get inserting-peeks keys ] unit-test +[ { D 0 } ] [ 1 get 3 get inserting-peeks keys ] unit-test +[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test +[ { } ] [ 5 get 6 get inserting-peeks keys ] unit-test V{ T{ ##prologue } @@ -414,13 +419,87 @@ V{ [ ] [ test-global-dcn ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces ] unit-test -[ { D 0 } ] [ 1 get 3 get inserting-peeks ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces ] unit-test -[ { } ] [ 2 get 4 get inserting-peeks ] unit-test -[ { D 0 } ] [ 2 get 4 get inserting-replaces ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks ] unit-test -[ { } ] [ 3 get 4 get inserting-replaces ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks ] unit-test -[ { } ] [ 4 get 5 get inserting-replaces ] unit-test \ No newline at end of file +[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test +[ { D 0 } ] [ 1 get 3 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test +[ { } ] [ 2 get 4 get inserting-peeks keys ] unit-test +[ { D 0 } ] [ 2 get 4 get inserting-replaces keys ] unit-test +[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test +[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test +[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test +[ { } ] [ 4 get 5 get inserting-replaces keys ] unit-test + +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##branch } +} 1 test-bb + +V{ + T{ ##replace f V int-regs 1 D 0 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace f V int-regs 2 D 0 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##branch } +} 4 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 5 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop + +[ ] [ test-global-dcn ] unit-test + +[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test + +[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test + +[ { D 0 } ] [ 4 get 5 get inserting-replaces keys ] unit-test + +! Dead replace elimination +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##replace f V int-regs 1 D 0 } + T{ ##replace f V int-regs 0 D 1 } +} 1 test-bb + +V{ + T{ ##inc-d f -2 } +} 2 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 3 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 1vector >>successors drop +2 get 3 get 1vector >>successors drop + +[ ] [ test-global-dcn ] unit-test + +[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test +[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test +[ { } ] [ 2 get 3 get inserting-replaces keys ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/dcn.factor b/basis/compiler/cfg/dcn/dcn.factor index f6cd5ec617..e2e52b30d5 100644 --- a/basis/compiler/cfg/dcn/dcn.factor +++ b/basis/compiler/cfg/dcn/dcn.factor @@ -1,6 +1,11 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ; +USING: combinators +compiler.cfg +compiler.cfg.dcn.height +compiler.cfg.dcn.local +compiler.cfg.dcn.global +compiler.cfg.dcn.rewrite ; IN: compiler.cfg.dcn ! "DeConcatenatizatioN" -- dataflow analysis to recover registers @@ -27,4 +32,13 @@ IN: compiler.cfg.dcn ! On every edge [pred --> b], insert a peek for each location in ! P_in(b) - (P_out(pred) \/ A_out(pred)) -! Locations are height-normalized. \ No newline at end of file +! Locations are height-normalized. + +: deconcatenatize ( cfg -- cfg' ) + { + [ compute-heights ] + [ compute-local-sets ] + [ compute-global-sets ] + [ rewrite ] + [ cfg-changed ] + } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/height/height.factor b/basis/compiler/cfg/dcn/height/height.factor index e38e2db233..189bccfecc 100644 --- a/basis/compiler/cfg/dcn/height/height.factor +++ b/basis/compiler/cfg/dcn/height/height.factor @@ -53,6 +53,16 @@ M: ##inc-r rs-height-change n>> ; : compute-rs-height ( bb -- ) in-rs-heights out-rs-heights [ rs-height-change ] compute-height ; +GENERIC# translate-loc 1 ( loc bb -- loc' ) + +M: ds-loc translate-loc [ n>> ] [ in-ds-heights get at ] bi* - ; +M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - ; + +GENERIC# untranslate-loc 1 ( loc bb -- loc' ) + +M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + ; +M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + ; + PRIVATE> : compute-heights ( cfg -- ) @@ -65,18 +75,8 @@ PRIVATE> [ compute-ds-height ] bi ] each-basic-block ; -GENERIC# translate-in-loc 1 ( loc bb -- loc' ) +: translate-locs ( assoc bb -- assoc' ) + '[ [ _ translate-loc ] dip ] assoc-map ; -M: ds-loc translate-in-loc [ n>> ] [ in-ds-heights get at ] bi* - ; -M: rs-loc translate-in-loc [ n>> ] [ in-rs-heights get at ] bi* - ; - -GENERIC# translate-out-loc 1 ( loc bb -- loc' ) - -M: ds-loc translate-out-loc [ n>> ] [ out-ds-heights get at ] bi* + ; -M: rs-loc translate-out-loc [ n>> ] [ out-rs-heights get at ] bi* + ; - -: translate-in-set ( assoc bb -- assoc' ) - '[ [ _ translate-in-loc ] dip ] assoc-map ; - -: translate-out-set ( assoc bb -- assoc' ) - '[ [ _ translate-out-loc ] dip ] assoc-map ; +: untranslate-locs ( assoc bb -- assoc' ) + '[ [ _ untranslate-loc ] dip ] assoc-map ; diff --git a/basis/compiler/cfg/dcn/local/local.factor b/basis/compiler/cfg/dcn/local/local.factor index 7a34adfb04..90b67401eb 100644 --- a/basis/compiler/cfg/dcn/local/local.factor +++ b/basis/compiler/cfg/dcn/local/local.factor @@ -82,8 +82,8 @@ SYMBOLS: peeks replaces ; : visit-block ( bb -- ) [ local-analysis ] - [ [ reads-locations get ] dip [ translate-in-set ] keep peeks get set-at ] - [ [ writes-locations get ] dip [ translate-in-set ] keep replaces get set-at ] + [ [ reads-locations get ] dip [ translate-locs ] keep peeks get set-at ] + [ [ writes-locations get ] dip [ translate-locs ] keep replaces get set-at ] tri ; PRIVATE> diff --git a/basis/compiler/cfg/dcn/rewrite/rewrite.factor b/basis/compiler/cfg/dcn/rewrite/rewrite.factor index 2d95f0f3e0..4952a256de 100644 --- a/basis/compiler/cfg/dcn/rewrite/rewrite.factor +++ b/basis/compiler/cfg/dcn/rewrite/rewrite.factor @@ -1,10 +1,67 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs kernel compiler.cfg.dcn.global ; +USING: namespaces assocs kernel fry accessors sequences make math +combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions +compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.dcn.local +compiler.cfg.dcn.global compiler.cfg.dcn.height ; IN: compiler.cfg.dcn.rewrite -: inserting-peeks ( from to -- seq ) - peek-in swap [ peek-out ] [ avail-out ] bi assoc-union assoc-diff keys ; +! This pass inserts peeks, replaces, and copies. All stack locations +! are loaded to canonical vregs, with a 1-1 mapping from location to +! vreg. SSA is reconstructed afterwards. -: inserting-replaces ( from to -- seq ) - [ replace-out ] [ kill-in ] bi* assoc-diff keys ; \ No newline at end of file +: inserting-peeks ( from to -- assoc ) + [ + peek-in swap [ peek-out ] [ avail-out ] bi + assoc-union assoc-diff + ] keep untranslate-locs ; + +: inserting-replaces ( from to -- assoc ) + [ + [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi* + assoc-union assoc-diff + ] keep + untranslate-locs + [ drop n>> 0 >= ] assoc-filter ; + +SYMBOL: locs>vregs + +: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ; + +: each-insertion ( assoc quot: ( vreg loc -- ) -- ) + '[ drop [ loc>vreg ] keep @ ] assoc-each ; inline + +: visit-edge ( from to -- ) + 2dup [ + [ inserting-peeks [ ##peek ] each-insertion ] + [ inserting-replaces [ ##replace ] each-insertion ] 2bi + ] V{ } make + [ 2drop ] [ insert-basic-block ] if-empty ; + +: visit-edges ( bb -- ) + [ predecessors>> ] keep '[ _ visit-edge ] each ; + +: insert-in-copies ( bb -- ) + peek [ swap loc>vreg ##copy ] assoc-each ; + +: insert-out-copies ( bb -- ) + replace [ swap loc>vreg swap ##copy ] assoc-each ; + +: rewrite-instructions ( bb -- ) + [ + [ + { + [ insert-in-copies ] + [ instructions>> but-last-slice % ] + [ insert-out-copies ] + [ instructions>> last , ] + } cleave + ] V{ } make + ] keep (>>instructions) ; + +: visit-block ( bb -- ) + [ visit-edges ] [ rewrite-instructions ] bi ; + +: rewrite ( cfg -- ) + H{ } clone locs>vregs set + [ visit-block ] each-basic-block ; \ No newline at end of file From 802b4ffdf53f6d9a02ac374cc877da7b6dd03a9e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Jul 2009 17:46:09 -0500 Subject: [PATCH 06/81] compiler.cfg.dcn: remove stores to stack locations above top of stack (these are never read again) --- basis/compiler/cfg/dcn/rewrite/rewrite.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/dcn/rewrite/rewrite.factor b/basis/compiler/cfg/dcn/rewrite/rewrite.factor index 4952a256de..4a578dc098 100644 --- a/basis/compiler/cfg/dcn/rewrite/rewrite.factor +++ b/basis/compiler/cfg/dcn/rewrite/rewrite.factor @@ -16,13 +16,14 @@ IN: compiler.cfg.dcn.rewrite assoc-union assoc-diff ] keep untranslate-locs ; +: remove-dead-stores ( assoc -- assoc' ) + [ drop n>> 0 >= ] assoc-filter ; + : inserting-replaces ( from to -- assoc ) [ [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi* assoc-union assoc-diff - ] keep - untranslate-locs - [ drop n>> 0 >= ] assoc-filter ; + ] keep untranslate-locs remove-dead-stores ; SYMBOL: locs>vregs From e49de006c41e71e863e5e5e63f641e1059a0a05f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 21 Jul 2009 22:24:50 -0500 Subject: [PATCH 07/81] compiler.cfg.dcn: Fixing various bugs, hook up with optimizer --- basis/compiler/cfg/dcn/dcn-tests.factor | 248 +++++++++++++----- basis/compiler/cfg/dcn/height/height.factor | 20 +- basis/compiler/cfg/dcn/local/local.factor | 16 +- basis/compiler/cfg/dcn/rewrite/rewrite.factor | 31 ++- basis/compiler/cfg/optimizer/optimizer.factor | 16 +- 5 files changed, 232 insertions(+), 99 deletions(-) diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor index 585b44364e..43a66a8012 100644 --- a/basis/compiler/cfg/dcn/dcn-tests.factor +++ b/basis/compiler/cfg/dcn/dcn-tests.factor @@ -1,12 +1,14 @@ IN: compiler.cfg.dcn.tests -USING: tools.test kernel accessors namespaces assocs -cpu.architecture vectors sequences +USING: tools.test kernel accessors namespaces assocs math +cpu.architecture vectors sequences classes compiler.cfg compiler.cfg.utilities compiler.cfg.debugger compiler.cfg.registers compiler.cfg.predecessors compiler.cfg.instructions +compiler.cfg.checker +compiler.cfg.dcn compiler.cfg.dcn.height compiler.cfg.dcn.local compiler.cfg.dcn.local.private @@ -19,12 +21,19 @@ compiler.cfg.dcn.rewrite ; [ local-analysis ] keep instructions>> ; +: inserting-peeks' ( from to -- assoc ) + [ inserting-peeks ] keep untranslate-locs keys ; + +: inserting-replaces' ( from to -- assoc ) + [ inserting-replaces ] keep untranslate-locs remove-dead-stores keys ; + [ V{ T{ ##copy f V int-regs 1 V int-regs 0 } T{ ##copy f V int-regs 3 V int-regs 2 } T{ ##copy f V int-regs 5 V int-regs 4 } T{ ##inc-d f -1 } + T{ ##branch } } ] [ V{ @@ -38,6 +47,7 @@ compiler.cfg.dcn.rewrite ; T{ ##peek f V int-regs 5 D 1 } T{ ##replace f V int-regs 5 D 1 } T{ ##replace f V int-regs 6 D -1 } + T{ ##branch } } test-local-dcn ] unit-test @@ -68,11 +78,10 @@ compiler.cfg.dcn.rewrite ; : test-global-dcn ( -- ) cfg new 0 get >>entry compute-predecessors - [ compute-heights ] - [ compute-local-sets ] - [ compute-global-sets ] tri ; + deconcatenatize + check-cfg ; -V{ T{ ##return } } 0 test-bb +V{ T{ ##epilogue } T{ ##return } } 0 test-bb [ ] [ test-global-dcn ] unit-test @@ -84,7 +93,9 @@ V{ V{ T{ ##inc-d f 1 } T{ ##peek f V int-regs 0 D 1 } + T{ ##load-immediate f V int-regs 1 100 } T{ ##replace f V int-regs 1 D 2 } + T{ ##branch } } 1 test-bb V{ @@ -108,13 +119,13 @@ V{ [ f ] [ D 0 0 get avail-out key? ] unit-test -[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test +[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test +[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test -[ { D 2 } ] [ 1 get 2 get inserting-replaces keys ] unit-test +[ { D 2 } ] [ 1 get 2 get inserting-replaces' ] unit-test V{ T{ ##prologue } @@ -123,21 +134,29 @@ V{ V{ T{ ##peek f V int-regs 0 D 1 } + T{ ##branch } } 1 test-bb V{ T{ ##inc-d f -1 } T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } } 2 test-bb +V{ + T{ ##epilogue } + T{ ##return } +} 3 test-bb + 0 get 1 get 1vector >>successors drop 1 get 2 get 1vector >>successors drop +2 get 3 get 1vector >>successors drop [ ] [ test-global-dcn ] unit-test [ t ] [ D 1 2 get peek-in key? ] unit-test -[ { D 1 } ] [ 0 get 1 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test +[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test V{ T{ ##prologue } @@ -184,16 +203,16 @@ V{ [ t ] [ D 0 4 get peek-in key? ] unit-test [ t ] [ D 1 4 get peek-in key? ] unit-test -[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test -[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test -[ { D 1 } ] [ 1 get 4 get inserting-peeks keys ] unit-test -[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test -[ { D 1 } ] [ 4 get 5 get inserting-replaces keys ] unit-test +[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test +[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test +[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test +[ { D 1 } ] [ 1 get 4 get inserting-peeks' ] unit-test +[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test +[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test +[ { D 1 } ] [ 4 get 5 get inserting-replaces' ] unit-test [ t ] [ D 0 1 get peek-out key? ] unit-test [ f ] [ D 1 1 get peek-out key? ] unit-test @@ -219,6 +238,7 @@ V{ } 2 test-bb V{ + T{ ##load-immediate f V int-regs 2 100 } T{ ##replace f V int-regs 2 D 1 } T{ ##inc-d f -1 } T{ ##peek f V int-regs 4 D 1 } @@ -226,6 +246,7 @@ V{ } 3 test-bb V{ + T{ ##load-immediate f V int-regs 3 100 } T{ ##replace f V int-regs 3 D 0 } T{ ##branch } } 4 test-bb @@ -248,16 +269,16 @@ V{ [ t ] [ D 1 2 get peek-in key? ] unit-test [ f ] [ D 1 3 get peek-in key? ] unit-test -[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test -[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test -[ { D 1 } ] [ 1 get 2 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test -[ { D 2 } ] [ 1 get 3 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test -[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test -[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test -[ { D 0 } ] [ 4 get 5 get inserting-replaces keys ] unit-test +[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test +[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test +[ { D 1 } ] [ 1 get 2 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test +[ { D 2 } ] [ 1 get 3 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test +[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test +[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test +[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test +[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test V{ T{ ##prologue } @@ -281,9 +302,14 @@ V{ V{ T{ ##peek f V int-regs 1 D 0 } - T{ ##return } + T{ ##branch } } 4 test-bb +V{ + T{ ##epilogue } + T{ ##return } +} 5 test-bb + [ t ] [ 0 get kill-block? ] unit-test [ t ] [ 3 get kill-block? ] unit-test @@ -291,6 +317,7 @@ V{ 1 get 2 get 3 get V{ } 2sequence >>successors drop 2 get 4 get 1vector >>successors drop 3 get 4 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop [ ] [ test-global-dcn ] unit-test @@ -299,11 +326,11 @@ V{ [ f ] [ D 1 3 get avail-out key? ] unit-test [ f ] [ D 1 4 get avail-in key? ] unit-test -[ { D 1 } ] [ 0 get 1 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test -[ { } ] [ 2 get 4 get inserting-peeks keys ] unit-test -[ { D 0 } ] [ 3 get 4 get inserting-peeks keys ] unit-test +[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test +[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test +[ { D 0 } ] [ 3 get 4 get inserting-peeks' ] unit-test V{ T{ ##prologue } @@ -315,7 +342,7 @@ V{ T{ ##branch } } 1 test-bb -V{ T{ ##return } } 2 test-bb +V{ T{ ##epilogue } T{ ##return } } 2 test-bb V{ T{ ##branch } } 3 test-bb @@ -327,10 +354,10 @@ V{ T{ ##branch } } 3 test-bb [ t ] [ D 0 1 get avail-out key? ] unit-test -[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test -[ { } ] [ 3 get 1 get inserting-peeks keys ] unit-test +[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test +[ { } ] [ 3 get 1 get inserting-peeks' ] unit-test V{ T{ ##prologue } @@ -374,13 +401,13 @@ V{ [ ] [ test-global-dcn ] unit-test -[ { } ] [ 0 get 1 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test -[ { D 0 } ] [ 2 get 4 get inserting-peeks keys ] unit-test -[ { D 0 } ] [ 1 get 3 get inserting-peeks keys ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test -[ { } ] [ 5 get 6 get inserting-peeks keys ] unit-test +[ { } ] [ 0 get 1 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test +[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test +[ { D 0 } ] [ 2 get 4 get inserting-peeks' ] unit-test +[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test +[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test +[ { } ] [ 5 get 6 get inserting-peeks' ] unit-test V{ T{ ##prologue } @@ -392,6 +419,7 @@ V{ } 1 test-bb V{ + T{ ##load-immediate f V int-regs 1 100 } T{ ##replace f V int-regs 1 D 0 } T{ ##branch } } 2 test-bb @@ -419,16 +447,16 @@ V{ [ ] [ test-global-dcn ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test -[ { D 0 } ] [ 1 get 3 get inserting-peeks keys ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test -[ { } ] [ 2 get 4 get inserting-peeks keys ] unit-test -[ { D 0 } ] [ 2 get 4 get inserting-replaces keys ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test -[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test -[ { } ] [ 4 get 5 get inserting-replaces keys ] unit-test +[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test +[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test +[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test +[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test +[ { D 0 } ] [ 2 get 4 get inserting-replaces' ] unit-test +[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test +[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test +[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test +[ { } ] [ 4 get 5 get inserting-replaces' ] unit-test V{ T{ ##prologue } @@ -440,11 +468,13 @@ V{ } 1 test-bb V{ + T{ ##load-immediate f V int-regs 1 100 } T{ ##replace f V int-regs 1 D 0 } T{ ##branch } } 2 test-bb V{ + T{ ##load-immediate f V int-regs 2 100 } T{ ##replace f V int-regs 2 D 0 } T{ ##branch } } 3 test-bb @@ -466,11 +496,11 @@ V{ [ ] [ test-global-dcn ] unit-test -[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test +[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test -[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test +[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test -[ { D 0 } ] [ 4 get 5 get inserting-replaces keys ] unit-test +[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test ! Dead replace elimination V{ @@ -483,10 +513,12 @@ V{ T{ ##peek f V int-regs 1 D 1 } T{ ##replace f V int-regs 1 D 0 } T{ ##replace f V int-regs 0 D 1 } + T{ ##branch } } 1 test-bb V{ T{ ##inc-d f -2 } + T{ ##branch } } 2 test-bb V{ @@ -500,6 +532,90 @@ V{ [ ] [ test-global-dcn ] unit-test -[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test -[ { } ] [ 2 get 3 get inserting-replaces keys ] unit-test \ No newline at end of file +[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test +[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test +[ { } ] [ 2 get 3 get inserting-replaces' ] unit-test + +! More dead replace elimination tests +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek { dst V int-regs 10 } { loc D 0 } } + T{ ##inc-d { n -1 } } + T{ ##inc-r { n 1 } } + T{ ##replace { src V int-regs 10 } { loc R 0 } } + T{ ##peek { dst V int-regs 12 } { loc R 0 } } + T{ ##inc-r { n -1 } } + T{ ##inc-d { n 1 } } + T{ ##replace { src V int-regs 12 } { loc D 0 } } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 2 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 1vector >>successors drop + +[ ] [ test-global-dcn ] unit-test + +[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test + +! Check that retain stack usage works +V{ + T{ ##prologue } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##inc-d f -1 } + T{ ##inc-r f 1 } + T{ ##replace f V int-regs 0 R 0 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##call f + -1 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##peek f V int-regs 0 R 0 } + T{ ##inc-r f -1 } + T{ ##inc-d f 1 } + T{ ##replace f V int-regs 0 D 0 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##epilogue } + T{ ##return } +} 4 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 1vector >>successors drop +2 get 3 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop + +[ ] [ test-global-dcn ] unit-test + +[ ##replace D 0 ] [ + 3 get successors>> first instructions>> first + [ class ] [ loc>> ] bi +] unit-test + +[ ##replace R 0 ] [ + 1 get successors>> first instructions>> first + [ class ] [ loc>> ] bi +] unit-test + +[ ##peek R 0 ] [ + 2 get successors>> first instructions>> first + [ class ] [ loc>> ] bi +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/height/height.factor b/basis/compiler/cfg/dcn/height/height.factor index 189bccfecc..1a59ddcb35 100644 --- a/basis/compiler/cfg/dcn/height/height.factor +++ b/basis/compiler/cfg/dcn/height/height.factor @@ -53,16 +53,6 @@ M: ##inc-r rs-height-change n>> ; : compute-rs-height ( bb -- ) in-rs-heights out-rs-heights [ rs-height-change ] compute-height ; -GENERIC# translate-loc 1 ( loc bb -- loc' ) - -M: ds-loc translate-loc [ n>> ] [ in-ds-heights get at ] bi* - ; -M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - ; - -GENERIC# untranslate-loc 1 ( loc bb -- loc' ) - -M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + ; -M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + ; - PRIVATE> : compute-heights ( cfg -- ) @@ -75,8 +65,18 @@ PRIVATE> [ compute-ds-height ] bi ] each-basic-block ; +GENERIC# translate-loc 1 ( loc bb -- loc' ) + +M: ds-loc translate-loc [ n>> ] [ in-ds-heights get at ] bi* - ; +M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - ; + : translate-locs ( assoc bb -- assoc' ) '[ [ _ translate-loc ] dip ] assoc-map ; +GENERIC# untranslate-loc 1 ( loc bb -- loc' ) + +M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + ; +M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + ; + : untranslate-locs ( assoc bb -- assoc' ) '[ [ _ untranslate-loc ] dip ] assoc-map ; diff --git a/basis/compiler/cfg/dcn/local/local.factor b/basis/compiler/cfg/dcn/local/local.factor index 90b67401eb..3ed543f868 100644 --- a/basis/compiler/cfg/dcn/local/local.factor +++ b/basis/compiler/cfg/dcn/local/local.factor @@ -61,20 +61,24 @@ M: ##copy visit ds-height get dup 0 = [ drop ] [ ##inc-d ] if rs-height get dup 0 = [ drop ] [ ##inc-r ] if ; +: init-local-analysis ( -- ) + 0 ds-height set + 0 rs-height set + H{ } clone copies set + H{ } clone reads-locations set + H{ } clone writes-locations set ; + : local-analysis ( bb -- ) ! Removes all ##peek and ##replace from the basic block. ! Conceptually, moves all ##peeks to the start ! (reads-locations assoc) and all ##replaces to the end ! (writes-locations assoc). - 0 ds-height set - 0 rs-height set - H{ } clone copies set - H{ } clone reads-locations set - H{ } clone writes-locations set + init-local-analysis [ [ - [ visit ] each + unclip-last-slice [ [ visit ] each ] dip insert-height-changes + , ] V{ } make ] change-instructions drop ; diff --git a/basis/compiler/cfg/dcn/rewrite/rewrite.factor b/basis/compiler/cfg/dcn/rewrite/rewrite.factor index 4a578dc098..e91aa248e6 100644 --- a/basis/compiler/cfg/dcn/rewrite/rewrite.factor +++ b/basis/compiler/cfg/dcn/rewrite/rewrite.factor @@ -11,32 +11,35 @@ IN: compiler.cfg.dcn.rewrite ! vreg. SSA is reconstructed afterwards. : inserting-peeks ( from to -- assoc ) - [ - peek-in swap [ peek-out ] [ avail-out ] bi - assoc-union assoc-diff - ] keep untranslate-locs ; + peek-in swap [ peek-out ] [ avail-out ] bi + assoc-union assoc-diff ; : remove-dead-stores ( assoc -- assoc' ) [ drop n>> 0 >= ] assoc-filter ; : inserting-replaces ( from to -- assoc ) - [ - [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi* - assoc-union assoc-diff - ] keep untranslate-locs remove-dead-stores ; + [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi* + assoc-union assoc-diff ; SYMBOL: locs>vregs : loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ; -: each-insertion ( assoc quot: ( vreg loc -- ) -- ) - '[ drop [ loc>vreg ] keep @ ] assoc-each ; inline +: each-insertion ( assoc bb quot: ( vreg loc -- ) -- ) + '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline + +ERROR: bad-peek dst loc ; + +: insert-peeks ( from to -- ) + [ inserting-peeks ] keep + [ dup n>> 0 < [ bad-peek ] [ ##peek ] if ] each-insertion ; + +: insert-replaces ( from to -- ) + [ inserting-replaces ] keep + [ dup n>> 0 < [ 2drop ] [ ##replace ] if ] each-insertion ; : visit-edge ( from to -- ) - 2dup [ - [ inserting-peeks [ ##peek ] each-insertion ] - [ inserting-replaces [ ##replace ] each-insertion ] 2bi - ] V{ } make + 2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make [ 2drop ] [ insert-basic-block ] if-empty ; : visit-edges ( bb -- ) diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 1af0fcbc53..faaaccff61 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -5,6 +5,9 @@ compiler.cfg.tco compiler.cfg.predecessors compiler.cfg.useless-conditionals compiler.cfg.stack-analysis +compiler.cfg.dcn +compiler.cfg.dominance +compiler.cfg.ssa compiler.cfg.branch-splitting compiler.cfg.block-joining compiler.cfg.alias-analysis @@ -24,17 +27,24 @@ SYMBOL: check-optimizer? dup check-cfg ] when ; +SYMBOL: new-optimizer? + : optimize-cfg ( cfg -- cfg' ) ! Note that compute-predecessors has to be called several times. ! The passes that need this document it. [ optimize-tail-calls - delete-useless-conditionals + new-optimizer? get [ delete-useless-conditionals ] unless compute-predecessors - split-branches + new-optimizer? get [ split-branches ] unless + new-optimizer? get [ + deconcatenatize + compute-dominance + construct-ssa + ] when join-blocks compute-predecessors - stack-analysis + new-optimizer? get [ stack-analysis ] unless compute-liveness alias-analysis value-numbering From b869e1250c391a0713c542e19ecfaa857397cdc5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 00:52:25 -0500 Subject: [PATCH 08/81] compiler.cfg.stack-analysis: Out with the old, in with the new --- basis/compiler/cfg/optimizer/optimizer.factor | 16 +- basis/compiler/cfg/stack-analysis/authors.txt | 1 - .../stack-analysis/merge/merge-tests.factor | 104 --------- .../cfg/stack-analysis/merge/merge.factor | 117 ---------- .../stack-analysis-tests.factor | 204 ------------------ .../cfg/stack-analysis/stack-analysis.factor | 124 ----------- .../cfg/stack-analysis/state/state.factor | 53 ----- 7 files changed, 5 insertions(+), 614 deletions(-) delete mode 100644 basis/compiler/cfg/stack-analysis/authors.txt delete mode 100644 basis/compiler/cfg/stack-analysis/merge/merge-tests.factor delete mode 100644 basis/compiler/cfg/stack-analysis/merge/merge.factor delete mode 100644 basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor delete mode 100644 basis/compiler/cfg/stack-analysis/stack-analysis.factor delete mode 100644 basis/compiler/cfg/stack-analysis/state/state.factor diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index faaaccff61..ac6dcbc503 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -4,7 +4,6 @@ USING: kernel sequences accessors combinators namespaces compiler.cfg.tco compiler.cfg.predecessors compiler.cfg.useless-conditionals -compiler.cfg.stack-analysis compiler.cfg.dcn compiler.cfg.dominance compiler.cfg.ssa @@ -27,24 +26,19 @@ SYMBOL: check-optimizer? dup check-cfg ] when ; -SYMBOL: new-optimizer? - : optimize-cfg ( cfg -- cfg' ) ! Note that compute-predecessors has to be called several times. ! The passes that need this document it. [ optimize-tail-calls - new-optimizer? get [ delete-useless-conditionals ] unless + delete-useless-conditionals compute-predecessors - new-optimizer? get [ split-branches ] unless - new-optimizer? get [ - deconcatenatize - compute-dominance - construct-ssa - ] when + split-branches join-blocks compute-predecessors - new-optimizer? get [ stack-analysis ] unless + deconcatenatize + compute-dominance + construct-ssa compute-liveness alias-analysis value-numbering diff --git a/basis/compiler/cfg/stack-analysis/authors.txt b/basis/compiler/cfg/stack-analysis/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/compiler/cfg/stack-analysis/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor deleted file mode 100644 index 5883777861..0000000000 --- a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor +++ /dev/null @@ -1,104 +0,0 @@ -IN: compiler.cfg.stack-analysis.merge.tests -USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors - compiler.cfg.instructions compiler.cfg.stack-analysis.state -compiler.cfg.utilities compiler.cfg compiler.cfg.registers -compiler.cfg.debugger cpu.architecture make assocs namespaces -sequences kernel classes ; - -[ - { D 0 } - { V int-regs 0 V int-regs 1 } -] [ - - - V{ T{ ##branch } } >>instructions dup 1 set - V{ T{ ##branch } } >>instructions dup 2 set 2array - - H{ { D 0 V int-regs 0 } } >>locs>vregs - H{ { D 0 V int-regs 1 } } >>locs>vregs 2array - - H{ } clone added-instructions set - V{ } clone added-phis set - merge-locs locs>vregs>> keys added-phis get values first -] unit-test - -[ - { D 0 } - ##peek -] [ - - - V{ T{ ##branch } } >>instructions dup 1 set - V{ T{ ##branch } } >>instructions dup 2 set 2array - - - H{ { D 0 V int-regs 1 } } >>locs>vregs 2array - - H{ } clone added-instructions set - V{ } clone added-phis set - [ merge-locs locs>vregs>> keys ] { } make drop - 1 get added-instructions get at first class -] unit-test - -[ - 0 ##inc-d -] [ - - - V{ T{ ##branch } } >>instructions dup 1 set - V{ T{ ##branch } } >>instructions dup 2 set 2array - - H{ } clone added-instructions set - V{ } clone added-phis set - - -1 >>ds-height - 2array - - [ merge-ds-heights ds-height>> ] { } make drop - 1 get added-instructions get at first class -] unit-test - -[ - 0 - { D 0 } - { 1 1 } -] [ - - - V{ T{ ##branch } } >>instructions - V{ T{ ##branch } } >>instructions 2array - - H{ } clone added-instructions set - V{ } clone added-phis set - - [ - -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs - H{ { D 0 V int-regs 1 } } >>locs>vregs 2array - - [ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop - ] keep - [ instructions>> length ] map -] unit-test - -[ - -1 - { D -1 } - { 1 1 } -] [ - - - V{ T{ ##branch } } >>instructions - V{ T{ ##branch } } >>instructions 2array - - H{ } clone added-instructions set - V{ } clone added-phis set - - [ - -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs - -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array - - [ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop - [ ds-height>> ] [ locs>vregs>> keys ] bi - ] keep - [ instructions>> length ] map -] unit-test diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor deleted file mode 100644 index a53fd7494e..0000000000 --- a/basis/compiler/cfg/stack-analysis/merge/merge.factor +++ /dev/null @@ -1,117 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel assocs sequences accessors fry combinators grouping sets -arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats -compiler.cfg.instructions compiler.cfg.stack-analysis.state -compiler.cfg.registers compiler.cfg.utilities cpu.architecture ; -IN: compiler.cfg.stack-analysis.merge - -: initial-state ( bb states -- state ) 2drop ; - -: single-predecessor ( bb states -- state ) nip first clone ; - -: save-ds-height ( n -- ) - dup 0 = [ drop ] [ ##inc-d ] if ; - -: merge-ds-heights ( state predecessors states -- state ) - [ ds-height>> ] map dup all-equal? - [ nip first >>ds-height ] - [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ; - -: save-rs-height ( n -- ) - dup 0 = [ drop ] [ ##inc-r ] if ; - -: merge-rs-heights ( state predecessors states -- state ) - [ rs-height>> ] map dup all-equal? - [ nip first >>rs-height ] - [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ; - -: assoc-map-keys ( assoc quot -- assoc' ) - '[ _ dip ] assoc-map ; inline - -: translate-locs ( assoc state -- assoc' ) - '[ _ translate-loc ] assoc-map-keys ; - -: untranslate-locs ( assoc state -- assoc' ) - '[ _ untranslate-loc ] assoc-map-keys ; - -: collect-locs ( loc-maps states -- assoc ) - ! assoc maps locs to sequences - [ untranslate-locs ] 2map - [ [ keys ] map concat prune ] keep - '[ dup _ [ at ] with map ] H{ } map>assoc ; - -: insert-peek ( predecessor loc state -- vreg ) - '[ _ _ translate-loc ^^peek ] add-instructions ; - -SYMBOL: added-phis - -: add-phi-later ( inputs -- vreg ) - [ int-regs next-vreg dup ] dip 2array added-phis get push ; - -: merge-loc ( predecessors vregs loc state -- vreg ) - ! Insert a ##phi in the current block where the input - ! is the vreg storing loc from each predecessor block - '[ [ ] [ _ _ insert-peek ] ?if ] 2map - dup all-equal? [ first ] [ add-phi-later ] if ; - -:: merge-locs ( state predecessors states -- state ) - states [ locs>vregs>> ] map states collect-locs - [| key value | - key - predecessors value key state merge-loc - ] assoc-map - state translate-locs - state (>>locs>vregs) - state ; - -: merge-actual-loc ( vregs -- vreg/f ) - dup all-equal? [ first ] [ drop f ] if ; - -:: merge-actual-locs ( state states -- state ) - states [ actual-locs>vregs>> ] map states collect-locs - [ merge-actual-loc ] assoc-map [ nip ] assoc-filter - state translate-locs - state (>>actual-locs>vregs) - state ; - -: merge-changed-locs ( state states -- state ) - [ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine - over translate-locs - >>changed-locs ; - -:: insert-phis ( bb -- ) - bb predecessors>> :> predecessors - [ - added-phis get [| dst inputs | - dst predecessors inputs zip ##phi - ] assoc-each - ] V{ } make bb instructions>> over push-all - bb (>>instructions) ; - -:: multiple-predecessors ( bb states -- state ) - states [ not ] any? [ - - bb add-to-work-list - ] [ - [ - H{ } clone added-instructions set - V{ } clone added-phis set - bb predecessors>> :> predecessors - state new - predecessors states merge-ds-heights - predecessors states merge-rs-heights - predecessors states merge-locs - states merge-actual-locs - states merge-changed-locs - bb insert-basic-blocks - bb insert-phis - ] with-scope - ] if ; - -: merge-states ( bb states -- state ) - dup length { - { 0 [ initial-state ] } - { 1 [ single-predecessor ] } - [ drop multiple-predecessors ] - } case ; diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor deleted file mode 100644 index 9fbf7acf78..0000000000 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ /dev/null @@ -1,204 +0,0 @@ -USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization -compiler.cfg.predecessors compiler.cfg.stack-analysis -compiler.cfg.instructions sequences kernel tools.test accessors -sequences.private alien math combinators.private compiler.cfg -compiler.cfg.checker compiler.cfg.rpo -compiler.cfg.dce compiler.cfg.registers -sets namespaces arrays cpu.architecture ; -IN: compiler.cfg.stack-analysis.tests - -! Fundamental invariant: a basic block should not load or store a value more than once -: test-stack-analysis ( quot -- cfg ) - dup cfg? [ test-cfg first ] unless - compute-predecessors - stack-analysis - dup check-cfg ; - -: linearize ( cfg -- mr ) - flatten-cfg instructions>> ; - -[ ] [ [ ] test-stack-analysis drop ] unit-test - -! Only peek once -[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test - -! Redundant replace is redundant -[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test -[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Replace required here -[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test -[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Only one replace, at the end -[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test - -! Do we support the full language? -[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test -[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test -[ ] [ - [ "int" { "int" "int" } "cdecl" [ + ] alien-callback ] - test-cfg second test-stack-analysis drop -] unit-test - -! Test loops -[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test -[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test - -! Make sure that peeks are inserted in the right place -[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test - -! This should be a total no-op -[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Don't insert inc-d/inc-r; that's wrong! -[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test - -! Bug in height tracking -[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test -[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test -[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test - -! Bugs with code that throws -[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test -[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test -[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test -[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test - -! Make sure the replace stores a value with the right height -[ ] [ - [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize - [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi -] unit-test - -! translate-loc was the wrong way round -[ ] [ - [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize - [ [ ##load-immediate? ] count 2 assert= ] - [ [ ##peek? ] count 1 assert= ] - [ [ ##replace? ] count 3 assert= ] - tri -] unit-test - -[ ] [ - [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize - [ [ ##load-immediate? ] count 2 assert= ] - [ [ ##peek? ] count 1 assert= ] - [ [ ##replace? ] count 1 assert= ] - tri -] unit-test - -! Sync before a back-edge, not after -! ##peeks should be inserted before a ##loop-entry -! Don't optimize out the constants -[ t ] [ - [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize - [ ##load-immediate? ] any? -] unit-test - -! Correct height tracking -[ t ] [ - [ pick [ ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code - reverse-post-order 4 swap nth - instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi* - 2array { D 1 D 0 } set= -] unit-test - -[ D 1 ] [ - V{ T{ ##branch } } 0 test-bb - - V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb - - V{ - T{ ##peek f V int-regs 1 D 2 } - T{ ##inc-d f -1 } - T{ ##branch } - } 2 test-bb - - V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb - - V{ T{ ##return } } 4 test-bb - - test-diamond - - cfg new 0 get >>entry - compute-predecessors - stack-analysis - drop - - 3 get successors>> first instructions>> first loc>> -] unit-test - -! Do inserted ##peeks reference the correct stack location if -! an ##inc-d/r was also inserted? -[ D 0 ] [ - V{ T{ ##branch } } 0 test-bb - - V{ T{ ##branch } } 1 test-bb - - V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##branch } - } 2 test-bb - - V{ - T{ ##call f \ + -1 } - T{ ##inc-d f 1 } - T{ ##branch } - } 3 test-bb - - V{ T{ ##return } } 4 test-bb - - test-diamond - - cfg new 0 get >>entry - compute-predecessors - stack-analysis - drop - - 3 get successors>> first instructions>> [ ##peek? ] find nip loc>> -] unit-test - -! Missing ##replace -[ t ] [ - [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis - reverse-post-order last - instructions>> [ ##replace? ] filter [ loc>> ] map - { D 0 D 1 D 2 } set= -] unit-test - -! Inserted ##peeks reference the wrong stack location -[ t ] [ - [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis - eliminate-dead-code reverse-post-order 4 swap nth - instructions>> [ ##peek? ] filter [ loc>> ] map - { D 0 D 1 } set= -] unit-test - -[ D 0 ] [ - V{ T{ ##branch } } 0 test-bb - - V{ T{ ##branch } } 1 test-bb - - V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##inc-d f 1 } - T{ ##branch } - } 2 test-bb - - V{ - T{ ##inc-d f 1 } - T{ ##branch } - } 3 test-bb - - V{ T{ ##return } } 4 test-bb - - test-diamond - - cfg new 0 get >>entry - compute-predecessors - stack-analysis - drop - - 3 get successors>> first instructions>> [ ##peek? ] find nip loc>> -] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor deleted file mode 100644 index ec34c96a24..0000000000 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ /dev/null @@ -1,124 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel namespaces math sequences fry grouping -sets make combinators dlists deques -compiler.cfg -compiler.cfg.copy-prop -compiler.cfg.def-use -compiler.cfg.instructions -compiler.cfg.registers -compiler.cfg.rpo -compiler.cfg.hats -compiler.cfg.stack-analysis.state -compiler.cfg.stack-analysis.merge -compiler.cfg.utilities ; -IN: compiler.cfg.stack-analysis - -SYMBOL: global-optimization? - -: redundant-replace? ( vreg loc -- ? ) - dup state get untranslate-loc n>> 0 < - [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ; - -: save-changed-locs ( state -- ) - [ changed-locs>> keys ] [ locs>vregs>> ] bi '[ - dup _ at swap 2dup redundant-replace? - [ 2drop ] [ state get untranslate-loc ##replace ] if - ] each ; - -: sync-state ( -- ) - state get { - [ ds-height>> save-ds-height ] - [ rs-height>> save-rs-height ] - [ save-changed-locs ] - [ clear-state ] - } cleave ; - -! Abstract interpretation -GENERIC: visit ( insn -- ) - -M: ##inc-d visit - n>> state get [ + ] change-ds-height drop ; - -M: ##inc-r visit - n>> state get [ + ] change-rs-height drop ; - -! Instructions which don't have any effect on the stack -UNION: neutral-insn - ##effect - ##flushable - ##no-tco ; - -M: neutral-insn visit , ; - -UNION: sync-if-back-edge - ##branch - ##conditional-branch - ##compare-imm-branch - ##dispatch - ##loop-entry - ##fixnum-overflow ; - -: sync-state? ( -- ? ) - basic-block get successors>> - [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ; - -M: sync-if-back-edge visit - global-optimization? get [ sync-state? [ sync-state ] when ] unless - , ; - -: eliminate-peek ( dst src -- ) - ! the requested stack location is already in 'src' - [ ##copy ] [ swap copies get set-at ] 2bi ; - -M: ##peek visit - [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg - [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ; - -M: ##replace visit - [ src>> resolve ] [ loc>> state get translate-loc ] bi - record-replace ; - -M: ##copy visit - [ call-next-method ] [ record-copy ] bi ; - -M: ##jump visit sync-state , ; - -M: ##return visit sync-state , ; - -M: ##callback-return visit sync-state , ; - -M: kill-vreg-insn visit sync-state , ; - -! Maps basic-blocks to states -SYMBOL: state-out - -: block-in-state ( bb -- states ) - dup predecessors>> state-out get '[ _ at ] map merge-states ; - -: set-block-out-state ( state bb -- ) - [ clone ] dip state-out get set-at ; - -: visit-block ( bb -- ) - ! block-in-state may add phi nodes at the start of the basic block - ! so we wrap the whole thing with a 'make' - [ - dup basic-block set - dup block-in-state - state [ - [ instructions>> [ visit ] each ] - [ [ state get ] dip set-block-out-state ] - [ ] - tri - ] with-variable - ] V{ } make >>instructions drop ; - -: stack-analysis ( cfg -- cfg' ) - [ - work-list set - H{ } clone copies set - H{ } clone state-out set - dup [ visit-block ] each-basic-block - global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when - cfg-changed - ] with-scope ; diff --git a/basis/compiler/cfg/stack-analysis/state/state.factor b/basis/compiler/cfg/stack-analysis/state/state.factor deleted file mode 100644 index 25fa249853..0000000000 --- a/basis/compiler/cfg/stack-analysis/state/state.factor +++ /dev/null @@ -1,53 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces assocs sets math deques -compiler.cfg.registers ; -IN: compiler.cfg.stack-analysis.state - -TUPLE: state -locs>vregs actual-locs>vregs changed-locs -{ ds-height integer } -{ rs-height integer } -poisoned? ; - -: ( -- state ) - state new - H{ } clone >>locs>vregs - H{ } clone >>actual-locs>vregs - H{ } clone >>changed-locs - 0 >>ds-height - 0 >>rs-height ; - -M: state clone - call-next-method - [ clone ] change-locs>vregs - [ clone ] change-actual-locs>vregs - [ clone ] change-changed-locs ; - -: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ; - -: record-peek ( dst loc -- ) - state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ; - -: changed-loc ( loc -- ) - state get changed-locs>> conjoin ; - -: record-replace ( src loc -- ) - dup changed-loc state get locs>vregs>> set-at ; - -: clear-state ( state -- ) - 0 >>ds-height 0 >>rs-height - [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri - [ clear-assoc ] tri@ ; - -GENERIC# translate-loc 1 ( loc state -- loc' ) -M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - ; -M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - ; - -GENERIC# untranslate-loc 1 ( loc state -- loc' ) -M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + ; -M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + ; - -SYMBOL: work-list - -: add-to-work-list ( bb -- ) work-list get push-front ; From b39b0dd393b437f3f7e9ac541d900770143552bc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 02:05:40 -0500 Subject: [PATCH 09/81] compiler.cfg.dcn.global: redo using compiler.cfg.dataflow-analysis --- basis/compiler/cfg/dcn/global/global.factor | 175 ++------------------ 1 file changed, 10 insertions(+), 165 deletions(-) diff --git a/basis/compiler/cfg/dcn/global/global.factor b/basis/compiler/cfg/dcn/global/global.factor index d644ed8703..44f8af24cc 100644 --- a/basis/compiler/cfg/dcn/global/global.factor +++ b/basis/compiler/cfg/dcn/global/global.factor @@ -1,194 +1,39 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs deques dlists fry kernel namespaces sequences -combinators combinators.short-circuit compiler.cfg.instructions -compiler.cfg.dcn.local compiler.cfg.rpo compiler.cfg.utilities -compiler.cfg ; +USING: assocs kernel combinators compiler.cfg.dataflow-analysis +compiler.cfg.dcn.local ; IN: compiler.cfg.dcn.global - -: peek-in ( bb -- assoc ) peek-ins get at ; -: peek-out ( bb -- assoc ) peek-outs get at ; - -> peek-ins get '[ _ at ] map assoc-refine ; - -M: kill-block compute-peek-out drop f ; - -: update-peek-out ( bb -- ? ) - [ compute-peek-out ] keep peek-outs get maybe-set-at ; - -: peek-step ( bb -- ) - dup update-peek-out [ - dup update-peek-in - [ predecessors>> add-to-work-list ] [ drop ] if - ] [ drop ] if ; - -: compute-peek-sets ( cfg -- ) - H{ } clone peek-ins set - H{ } clone peek-outs set - post-order add-to-work-list work-list get [ peek-step ] slurp-deque ; +M: peek-analysis transfer-set drop [ replace assoc-diff ] keep peek assoc-union ; ! Replace analysis. Replace-in is the set of all locations which ! will be overwritten at some point after the start of a basic block. -SYMBOLS: replace-ins replace-outs ; +FORWARD-ANALYSIS: replace -PRIVATE> - -: replace-in ( bb -- assoc ) replace-ins get at ; -: replace-out ( bb -- assoc ) replace-outs get at ; - -> replace-outs get '[ _ at ] map assoc-refine ; - -M: kill-block compute-replace-in drop f ; - -: update-replace-in ( bb -- ? ) - [ compute-replace-in ] keep replace-ins get maybe-set-at ; - -GENERIC: compute-replace-out ( bb -- assoc ) - -M: basic-block compute-replace-out - [ replace-in ] [ replace ] bi assoc-union ; - -M: kill-block compute-replace-out drop f ; - -: update-replace-out ( bb -- ? ) - [ compute-replace-out ] keep replace-outs get maybe-set-at ; - -: replace-step ( bb -- ) - dup update-replace-in [ - dup update-replace-out - [ successors>> add-to-work-list ] [ drop ] if - ] [ drop ] if ; - -: compute-replace-sets ( cfg -- ) - H{ } clone replace-ins set - H{ } clone replace-outs set - reverse-post-order add-to-work-list work-list get [ replace-step ] slurp-deque ; +M: replace-analysis transfer-set drop replace assoc-union ; ! Availability analysis. Avail-out is the set of all locations ! in registers at the end of a basic block. -SYMBOLS: avail-ins avail-outs ; +FORWARD-ANALYSIS: avail -PRIVATE> - -: avail-in ( bb -- assoc ) avail-ins get at ; -: avail-out ( bb -- assoc ) avail-outs get at ; - -> avail-outs get '[ _ at ] map assoc-refine ; - -M: kill-block compute-avail-in drop f ; - -: update-avail-in ( bb -- ? ) - [ compute-avail-in ] keep avail-ins get maybe-set-at ; - -GENERIC: compute-avail-out ( bb -- assoc ) - -M: basic-block compute-avail-out - [ avail-in ] [ peek ] [ replace ] tri assoc-union assoc-union ; - -M: kill-block compute-avail-out drop f ; - -: update-avail-out ( bb -- ? ) - [ compute-avail-out ] keep avail-outs get maybe-set-at ; - -: avail-step ( bb -- ) - dup update-avail-in [ - dup update-avail-out - [ successors>> add-to-work-list ] [ drop ] if - ] [ drop ] if ; - -: compute-avail-sets ( cfg -- ) - H{ } clone avail-ins set - H{ } clone avail-outs set - reverse-post-order add-to-work-list work-list get [ avail-step ] slurp-deque ; +M: avail-analysis transfer-set drop [ peek ] [ replace ] bi assoc-union assoc-union ; ! Kill analysis. Kill-in is the set of all locations ! which are going to be overwritten. -SYMBOLS: kill-ins kill-outs ; +BACKWARD-ANALYSIS: kill -PRIVATE> - -: kill-in ( bb -- assoc ) kill-ins get at ; -: kill-out ( bb -- assoc ) kill-outs get at ; - -> kill-ins get '[ _ at ] map assoc-refine ; - -M: kill-block compute-kill-out drop f ; - -: update-kill-out ( bb -- ? ) - [ compute-kill-out ] keep kill-outs get maybe-set-at ; - -: kill-step ( bb -- ) - dup update-kill-out [ - dup update-kill-in - [ predecessors>> add-to-work-list ] [ drop ] if - ] [ drop ] if ; - -: compute-kill-sets ( cfg -- ) - H{ } clone kill-ins set - H{ } clone kill-outs set - post-order add-to-work-list work-list get [ kill-step ] slurp-deque ; +M: kill-analysis transfer-set drop replace assoc-union ; PRIVATE> ! Main word : compute-global-sets ( cfg -- ) - work-list set { [ compute-peek-sets ] [ compute-replace-sets ] From 1e5ce413647e9bddbe8b031dacc45fe17d570347 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 03:26:27 -0500 Subject: [PATCH 10/81] Fix bootstrap --- basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor | 4 ++-- basis/compiler/cfg/dcn/dcn-tests.factor | 1 - basis/compiler/cfg/dcn/global/global.factor | 4 ---- 3 files changed, 2 insertions(+), 7 deletions(-) diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor index c38f43da8a..975adfa6cb 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -20,7 +20,7 @@ MIXIN: dataflow-analysis GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) -! M: kill-block compute-in-set 3drop f ; +M: kill-block compute-in-set 3drop f ; M:: basic-block compute-in-set ( bb out-sets dfa -- set ) bb dfa predecessors [ out-sets at ] map dfa join-sets ; @@ -31,7 +31,7 @@ M:: basic-block compute-in-set ( bb out-sets dfa -- set ) GENERIC# compute-out-set 2 ( bb out-sets dfa -- set ) -! M: kill-block compute-out-set 3drop f ; +M: kill-block compute-out-set 3drop f ; M:: basic-block compute-out-set ( bb in-sets dfa -- set ) bb in-sets at bb dfa transfer-set ; diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor index 43a66a8012..3dfaa665aa 100644 --- a/basis/compiler/cfg/dcn/dcn-tests.factor +++ b/basis/compiler/cfg/dcn/dcn-tests.factor @@ -13,7 +13,6 @@ compiler.cfg.dcn.height compiler.cfg.dcn.local compiler.cfg.dcn.local.private compiler.cfg.dcn.global -compiler.cfg.dcn.global.private compiler.cfg.dcn.rewrite ; : test-local-dcn ( insns -- insns' ) diff --git a/basis/compiler/cfg/dcn/global/global.factor b/basis/compiler/cfg/dcn/global/global.factor index 44f8af24cc..21a795151a 100644 --- a/basis/compiler/cfg/dcn/global/global.factor +++ b/basis/compiler/cfg/dcn/global/global.factor @@ -4,8 +4,6 @@ USING: assocs kernel combinators compiler.cfg.dataflow-analysis compiler.cfg.dcn.local ; IN: compiler.cfg.dcn.global - - ! Main word : compute-global-sets ( cfg -- ) { From 44bcd258f6721b631b8e4c5ac567a38cb1e7d02a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 06:05:17 -0500 Subject: [PATCH 11/81] Insert _loop-entry in linearization pass instead of in CFG builder, so that optimizations don't have to worry about it --- basis/compiler/cfg/builder/builder.factor | 1 - basis/compiler/cfg/checker/checker.factor | 20 +++++++------------ .../cfg/instructions/instructions.factor | 3 +-- .../cfg/linearization/linearization.factor | 15 +++++++++----- .../cfg/optimizer/optimizer-tests.factor | 12 +++++------ basis/compiler/cfg/optimizer/optimizer.factor | 2 -- basis/compiler/codegen/codegen.factor | 2 +- 7 files changed, 25 insertions(+), 30 deletions(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index e3c502e66e..48162156c8 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -86,7 +86,6 @@ GENERIC: emit-node ( node -- ) basic-block get swap loops get set-at ; : emit-loop ( node -- ) - ##loop-entry ##branch begin-basic-block [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ; diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 60b8ed4118..f4738c675c 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -2,14 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities -combinators.short-circuit accessors math sequences sets assocs ; +compiler.cfg.mr combinators.short-circuit accessors math sequences +sets assocs ; IN: compiler.cfg.checker ERROR: bad-kill-block bb ; : check-kill-block ( bb -- ) dup instructions>> first2 - swap ##epilogue? [ [ ##return? ] [ ##callback-return? ] bi or ] [ ##branch? ] if + swap ##epilogue? [ + { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1|| + ] [ ##branch? ] if [ drop ] [ bad-kill-block ] if ; ERROR: last-insn-not-a-jump bb ; @@ -26,14 +29,6 @@ ERROR: last-insn-not-a-jump bb ; [ ##no-tco? ] } 1|| [ drop ] [ last-insn-not-a-jump ] if ; -ERROR: bad-loop-entry bb ; - -: check-loop-entry ( bb -- ) - dup instructions>> dup length 2 >= [ - 2 head* [ ##loop-entry? ] any? - [ bad-loop-entry ] [ drop ] if - ] [ 2drop ] if ; - ERROR: bad-kill-insn bb ; : check-kill-instructions ( bb -- ) @@ -41,10 +36,9 @@ ERROR: bad-kill-insn bb ; [ bad-kill-insn ] [ drop ] if ; : check-normal-block ( bb -- ) - [ check-loop-entry ] [ check-last-instruction ] [ check-kill-instructions ] - tri ; + bi ; ERROR: bad-successors ; @@ -70,5 +64,5 @@ ERROR: undefined-values uses defs ; : check-cfg ( cfg -- ) [ [ check-basic-block ] each-basic-block ] - [ flatten-cfg check-mr ] + [ build-mr check-mr ] bi ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 43d92c9ccc..2496b29ae2 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -170,8 +170,6 @@ INSN: ##epilogue ; INSN: ##branch ; -INSN: ##loop-entry ; - INSN: ##phi < ##pure inputs ; ! Conditionals @@ -201,6 +199,7 @@ INSN: _epilogue stack-frame ; INSN: _label id ; INSN: _branch label ; +INSN: _loop-entry ; INSN: _dispatch src temp ; INSN: _dispatch-label label ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index c62d4b0208..1f00913b1e 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -6,7 +6,8 @@ compiler.cfg compiler.cfg.rpo compiler.cfg.comparisons compiler.cfg.stack-frame -compiler.cfg.instructions ; +compiler.cfg.instructions +compiler.cfg.utilities ; IN: compiler.cfg.linearization ! Convert CFG IR to machine IR. @@ -24,7 +25,11 @@ M: insn linearize-insn , drop ; #! don't need to branch. [ number>> ] bi@ 1 - = ; inline -: emit-branch ( basic-block successor -- ) +: emit-loop-entry? ( bb -- ? ) + dup predecessors>> [ swap back-edge? ] with any? ; + +: emit-branch ( bb successor -- ) + dup emit-loop-entry? [ _loop-entry ] when 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ; M: ##branch linearize-insn @@ -32,11 +37,11 @@ M: ##branch linearize-insn : successors ( bb -- first second ) successors>> first2 ; inline -: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc ) +: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc ) [ dup successors ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline -: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc ) +: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc ) [ (binary-conditional) ] [ drop dup successors>> second useless-branch? ] 2bi [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ; @@ -53,7 +58,7 @@ M: ##compare-imm-branch linearize-insn M: ##compare-float-branch linearize-insn [ binary-conditional _compare-float-branch ] with-regs emit-branch ; -: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 ) +: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 ) [ dup successors number>> ] [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index 1eb1996da4..695a586199 100755 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -1,8 +1,8 @@ -USING: accessors arrays compiler.cfg.checker -compiler.cfg.debugger compiler.cfg.def-use -compiler.cfg.instructions fry kernel kernel.private math -math.partial-dispatch math.private sbufs sequences sequences.private sets -slots.private strings strings.private tools.test vectors layouts ; +USING: accessors arrays compiler.cfg.checker compiler.cfg.debugger +compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.optimizer +fry kernel kernel.private math math.partial-dispatch math.private +sbufs sequences sequences.private sets slots.private strings +strings.private tools.test vectors layouts ; IN: compiler.cfg.optimizer.tests ! Miscellaneous tests @@ -45,7 +45,7 @@ IN: compiler.cfg.optimizer.tests set-string-nth-fast ] } [ - [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test + [ [ ] ] dip '[ _ test-cfg first optimize-cfg check-cfg ] unit-test ] each cell 8 = [ diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index af73fd9420..1419ff1952 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -5,7 +5,6 @@ compiler.cfg.tco compiler.cfg.predecessors compiler.cfg.useless-conditionals compiler.cfg.dcn -compiler.cfg.dominance compiler.cfg.ssa compiler.cfg.branch-splitting compiler.cfg.block-joining @@ -36,7 +35,6 @@ SYMBOL: check-optimizer? join-blocks compute-predecessors deconcatenatize - compute-dominance construct-ssa alias-analysis value-numbering diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 5df0114244..f1052da2d5 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -245,7 +245,7 @@ M: _gc generate-insn [ gc-root-count>> ] } cleave %gc ; -M: ##loop-entry generate-insn drop %loop-entry ; +M: _loop-entry generate-insn drop %loop-entry ; M: ##alien-global generate-insn [ dst>> register ] [ symbol>> ] [ library>> ] tri From 31491df5f1c551a5262e16d273b49acea8b9d6d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 06:05:33 -0500 Subject: [PATCH 12/81] Removed unused code from compiler.cfg.def-use --- basis/compiler/cfg/def-use/def-use.factor | 9 --------- 1 file changed, 9 deletions(-) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 1c52c081a1..0f488de559 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -49,12 +49,3 @@ M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; M: _dispatch uses-vregs src>> 1array ; M: insn uses-vregs drop f ; - -: map-unique ( seq quot -- assoc ) - map concat unique ; inline - -: gen-set ( instructions -- seq ) - [ uses-vregs ] map-unique ; - -: kill-set ( instructions -- seq ) - [ defs-vregs ] map-unique ; From d29c2750894e0d3fb9ae2bda01aa92199daa4b7f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 19:17:21 -0500 Subject: [PATCH 13/81] compiler.cfg.builder: Fix construction of ##return instructions from #return-recursive nodes --- basis/compiler/cfg/builder/builder-tests.factor | 10 ++++++++++ basis/compiler/cfg/builder/builder.factor | 9 +++++---- 2 files changed, 15 insertions(+), 4 deletions(-) diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 90e42912a1..7381bdca55 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -9,6 +9,15 @@ byte-arrays kernel.private math slots.private ; : unit-test-cfg ( quot -- ) '[ _ test-cfg [ compute-predecessors check-cfg ] each ] [ ] swap unit-test ; +: blahblah ( nodes -- ? ) + { fixnum } declare [ + dup 3 bitand 1 = [ drop t ] [ + dup 3 bitand 2 = [ + blahblah + ] [ drop f ] if + ] if + ] any? ; inline recursive + { [ ] [ dup ] @@ -52,6 +61,7 @@ byte-arrays kernel.private math slots.private ; [ "int" { "int" } "cdecl" [ ] alien-callback ] [ swap - + * ] [ swap slot ] + [ blahblah ] } [ unit-test-cfg ] each diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 48162156c8..7a7156d5c9 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -160,12 +160,13 @@ M: #shuffle emit-node [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ; ! #return -M: #return emit-node - drop ##branch begin-basic-block ##epilogue ##return ; +: emit-return ( -- ) + ##branch begin-basic-block ##epilogue ##return ; + +M: #return emit-node drop emit-return ; M: #return-recursive emit-node - label>> id>> loops get key? - [ ##epilogue ##return ] unless ; + label>> id>> loops get key? [ emit-return ] unless ; ! #terminate M: #terminate emit-node drop ##no-tco basic-block off ; From 5559d77d05da0c792c444aa0587912362108c658 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 19:17:57 -0500 Subject: [PATCH 14/81] compiler.cfg.checker: eliminate dead code before checking MR --- basis/compiler/cfg/checker/checker.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index f4738c675c..53f84b1dda 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities -compiler.cfg.mr combinators.short-circuit accessors math sequences -sets assocs ; +compiler.cfg.dce compiler.cfg.mr combinators.short-circuit accessors +math sequences sets assocs ; IN: compiler.cfg.checker ERROR: bad-kill-block bb ; @@ -64,5 +64,5 @@ ERROR: undefined-values uses defs ; : check-cfg ( cfg -- ) [ [ check-basic-block ] each-basic-block ] - [ build-mr check-mr ] + [ eliminate-dead-code build-mr check-mr ] bi ; From 45c66b58afb278b325ff63058d8cf749ed0affa5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 19:18:12 -0500 Subject: [PATCH 15/81] compiler.cfg.dcn.rewrite: remove unused word --- basis/compiler/cfg/dcn/rewrite/rewrite.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/basis/compiler/cfg/dcn/rewrite/rewrite.factor b/basis/compiler/cfg/dcn/rewrite/rewrite.factor index e91aa248e6..bbc6783f79 100644 --- a/basis/compiler/cfg/dcn/rewrite/rewrite.factor +++ b/basis/compiler/cfg/dcn/rewrite/rewrite.factor @@ -14,9 +14,6 @@ IN: compiler.cfg.dcn.rewrite peek-in swap [ peek-out ] [ avail-out ] bi assoc-union assoc-diff ; -: remove-dead-stores ( assoc -- assoc' ) - [ drop n>> 0 >= ] assoc-filter ; - : inserting-replaces ( from to -- assoc ) [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi* assoc-union assoc-diff ; From 69ded76c66df4c30e16351411f1adbf45489ae2d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 21:10:50 -0500 Subject: [PATCH 16/81] Fixing compiler tests --- basis/compiler/cfg/dcn/dcn-tests.factor | 4 ++-- basis/compiler/tests/codegen.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor index 3dfaa665aa..c987d9edd2 100644 --- a/basis/compiler/cfg/dcn/dcn-tests.factor +++ b/basis/compiler/cfg/dcn/dcn-tests.factor @@ -24,7 +24,7 @@ compiler.cfg.dcn.rewrite ; [ inserting-peeks ] keep untranslate-locs keys ; : inserting-replaces' ( from to -- assoc ) - [ inserting-replaces ] keep untranslate-locs remove-dead-stores keys ; + [ inserting-replaces ] keep untranslate-locs [ drop n>> 0 >= ] assoc-filter keys ; [ V{ @@ -78,7 +78,7 @@ compiler.cfg.dcn.rewrite ; cfg new 0 get >>entry compute-predecessors deconcatenatize - check-cfg ; + drop ; V{ T{ ##epilogue } T{ ##return } } 0 test-bb diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 9f573019c2..4494df1705 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -286,7 +286,7 @@ M: cucumber equal? "The cucumber has no equal" throw ; [ 4294967295 B{ 255 255 255 255 } -1 ] [ -1 -1 - [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ] + [ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ] compile-call ] unit-test From 610c3b33c75b927d393496f123b2455cd368361c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Jul 2009 21:11:06 -0500 Subject: [PATCH 17/81] compiler.cfg.intrinsics: Disable inline allocation for now --- basis/compiler/cfg/intrinsics/intrinsics.factor | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 2618db0904..c6642d8ad9 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics slots.private:set-slot strings.private:string-nth strings.private:set-string-nth-fast - classes.tuple.private: - arrays: - byte-arrays: - byte-arrays:(byte-array) - kernel: + ! classes.tuple.private: + ! arrays: + ! byte-arrays: + ! byte-arrays:(byte-array) + ! kernel: alien.accessors:alien-unsigned-1 alien.accessors:set-alien-unsigned-1 alien.accessors:alien-signed-1 @@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-unsigned-2 alien.accessors:alien-signed-2 alien.accessors:set-alien-signed-2 - alien.accessors:alien-cell + ! alien.accessors:alien-cell alien.accessors:set-alien-cell } [ t "intrinsic" set-word-prop ] each @@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-float alien.accessors:alien-double alien.accessors:set-alien-double - } [ t "intrinsic" set-word-prop ] each ; + } drop f [ t "intrinsic" set-word-prop ] each ; : enable-fixnum-log2 ( -- ) \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; From 93c58a8bb5ec350dabb2a89ea357dc384a33c810 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 18:02:29 -0500 Subject: [PATCH 18/81] compiler.cfg.branch-splitting: now that we do SSA construction we can split branches with fixnum overflow ops (which have a live-out) --- .../branch-splitting/branch-splitting.factor | 17 ++--------------- 1 file changed, 2 insertions(+), 15 deletions(-) diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index 2ab476e20c..89e3604aec 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -6,18 +6,8 @@ compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.branch-splitting -: clone-renamings ( insns -- assoc ) - [ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ; - : clone-instructions ( insns -- insns' ) - dup clone-renamings renamings [ - [ - clone - dup rename-insn-defs - dup rename-insn-uses - dup fresh-insn-temps - ] map - ] with-variable ; + [ clone dup fresh-insn-temps ] map ; : clone-basic-block ( bb -- bb' ) ! The new block gets the same RPO number as the old one. @@ -62,10 +52,7 @@ IN: compiler.cfg.branch-splitting UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ; -: split-instructions? ( insns -- ? ) - [ [ irrelevant? not ] count 5 <= ] - [ last ##fixnum-overflow? not ] - bi and ; +: split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ; : split-branch? ( bb -- ? ) { From 747a2d72c8903af9e7f5454dc2886a42c4e51e66 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 18:02:46 -0500 Subject: [PATCH 19/81] compiler.cfg.empty-blocks: new pass to delete empty blocks, runs after phi elimination --- .../cfg/empty-blocks/empty-blocks.factor | 38 +++++++++++++++++++ basis/compiler/cfg/optimizer/optimizer.factor | 2 + 2 files changed, 40 insertions(+) create mode 100644 basis/compiler/cfg/empty-blocks/empty-blocks.factor diff --git a/basis/compiler/cfg/empty-blocks/empty-blocks.factor b/basis/compiler/cfg/empty-blocks/empty-blocks.factor new file mode 100644 index 0000000000..2a31a20b72 --- /dev/null +++ b/basis/compiler/cfg/empty-blocks/empty-blocks.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences combinators combinators.short-circuit +classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; +IN: compiler.cfg.empty-blocks + +: update-predecessor ( bb -- ) + ! We have to replace occurrences of bb with bb's successor + ! in bb's predecessor's list of successors. + dup predecessors>> first [ + [ + 2dup eq? [ drop successors>> first ] [ nip ] if + ] with map + ] change-successors drop ; + +: update-successor ( bb -- ) + ! We have to replace occurrences of bb with bb's predecessor + ! in bb's sucessor's list of predecessors. + dup successors>> first [ + [ + 2dup eq? [ drop predecessors>> first ] [ nip ] if + ] with map + ] change-predecessors drop ; + +: delete-basic-block ( bb -- ) + [ update-predecessor ] [ update-successor ] bi ; + +: delete-basic-block? ( bb -- ? ) + { + [ instructions>> length 1 = ] + [ predecessors>> length 1 = ] + [ successors>> length 1 = ] + [ instructions>> first ##branch? ] + } 1&& ; + +: delete-empty-blocks ( cfg -- cfg' ) + dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block + cfg-changed ; \ No newline at end of file diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 1419ff1952..0b37157b43 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -14,6 +14,7 @@ compiler.cfg.dce compiler.cfg.write-barrier compiler.cfg.rpo compiler.cfg.phi-elimination +compiler.cfg.empty-blocks compiler.cfg.checker ; IN: compiler.cfg.optimizer @@ -42,5 +43,6 @@ SYMBOL: check-optimizer? eliminate-dead-code eliminate-write-barriers eliminate-phis + delete-empty-blocks ?check ] with-scope ; From b1afd4c49183c184842759baa0288aaa87e91ef1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 18:03:04 -0500 Subject: [PATCH 20/81] compiler.cfg.linear-scan.mapping: simplify --- basis/compiler/cfg/linear-scan/mapping/mapping.factor | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping.factor b/basis/compiler/cfg/linear-scan/mapping/mapping.factor index 5b47f33c64..36678a2f53 100644 --- a/basis/compiler/cfg/linear-scan/mapping/mapping.factor +++ b/basis/compiler/cfg/linear-scan/mapping/mapping.factor @@ -44,17 +44,11 @@ M: register->register >insn SYMBOL: froms SYMBOL: tos -SINGLETONS: memory register ; - -: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ; - -: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ; - : from-reg ( operation -- seq ) - [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ; + [ from>> ] [ reg-class>> ] bi 2array ; : to-reg ( operation -- seq ) - [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ; + [ to>> ] [ reg-class>> ] bi 2array ; : start? ( operations -- pair ) from-reg tos get key? not ; From ff7f0e2f3b58b9872287e20b6b538175f9a86f92 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 18:03:14 -0500 Subject: [PATCH 21/81] Add testcase for recent bug --- basis/compiler/tests/codegen.factor | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 4494df1705..c93e20294e 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -321,4 +321,16 @@ cell 4 = [ ] when ! Regression from Slava's value numbering changes -[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test \ No newline at end of file +[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! Bug with ##return node construction +: return-recursive-bug ( nodes -- ? ) + { fixnum } declare [ + dup 3 bitand 1 = [ drop t ] [ + dup 3 bitand 2 = [ + return-recursive-bug + ] [ drop f ] if + ] if + ] any? ; inline recursive + +[ t ] [ 3 [ return-recursive-bug ] compile-call ] unit-test \ No newline at end of file From d947c61bd7345bd4fbc940c17868e0dcab2ef3fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 20:54:38 -0500 Subject: [PATCH 22/81] compiler.cfg.stacks: now performs online local DCN --- .../compiler/cfg/builder/blocks/blocks.factor | 74 +++ .../compiler/cfg/builder/builder-tests.factor | 6 +- basis/compiler/cfg/builder/builder.factor | 37 +- basis/compiler/cfg/checker/checker.factor | 6 +- basis/compiler/cfg/dcn/dcn-tests.factor | 620 ------------------ basis/compiler/cfg/dcn/dcn.factor | 44 -- basis/compiler/cfg/dcn/height/height.factor | 82 --- basis/compiler/cfg/dcn/local/local.factor | 101 --- .../cfg/instructions/instructions.factor | 2 +- .../cfg/intrinsics/alien/alien.factor | 9 +- .../cfg/intrinsics/allot/allot.factor | 4 +- .../cfg/intrinsics/fixnum/fixnum.factor | 9 +- .../cfg/intrinsics/slots/slots.factor | 4 +- .../cfg/linearization/linearization.factor | 7 +- basis/compiler/cfg/optimizer/optimizer.factor | 2 - .../finalize/finalize.factor} | 43 +- .../cfg/{dcn => stacks}/global/global.factor | 15 +- .../compiler/cfg/stacks/height/height.factor | 27 + basis/compiler/cfg/stacks/local/local.factor | 80 +++ basis/compiler/cfg/stacks/stacks.factor | 67 +- basis/compiler/cfg/utilities/utilities.factor | 36 - 21 files changed, 295 insertions(+), 980 deletions(-) create mode 100644 basis/compiler/cfg/builder/blocks/blocks.factor delete mode 100644 basis/compiler/cfg/dcn/dcn-tests.factor delete mode 100644 basis/compiler/cfg/dcn/dcn.factor delete mode 100644 basis/compiler/cfg/dcn/height/height.factor delete mode 100644 basis/compiler/cfg/dcn/local/local.factor rename basis/compiler/cfg/{dcn/rewrite/rewrite.factor => stacks/finalize/finalize.factor} (51%) rename basis/compiler/cfg/{dcn => stacks}/global/global.factor (65%) create mode 100644 basis/compiler/cfg/stacks/height/height.factor create mode 100644 basis/compiler/cfg/stacks/local/local.factor diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor new file mode 100644 index 0000000000..4f4f9ad7b3 --- /dev/null +++ b/basis/compiler/cfg/builder/blocks/blocks.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays fry kernel make math namespaces sequences +compiler.cfg compiler.cfg.instructions compiler.cfg.stacks +compiler.cfg.stacks.local ; +IN: compiler.cfg.builder.blocks + +: set-basic-block ( basic-block -- ) + [ basic-block set ] [ instructions>> building set ] bi + begin-local-analysis ; + +: initial-basic-block ( -- ) + set-basic-block ; + +: end-basic-block ( -- ) + basic-block get [ end-local-analysis ] when + building off + basic-block off ; + +: (begin-basic-block) ( -- ) + + basic-block get [ dupd successors>> push ] when* + set-basic-block ; + +: begin-basic-block ( -- ) + basic-block get [ end-local-analysis ] when + (begin-basic-block) ; + +: emit-trivial-block ( quot -- ) + building get empty? [ ##branch begin-basic-block ] unless + call + ##branch begin-basic-block ; inline + +: call-height ( #call -- n ) + [ out-d>> length ] [ in-d>> length ] bi - ; + +: emit-primitive ( node -- ) + [ + [ word>> ##call ] + [ call-height adjust-d ] bi + ] emit-trivial-block ; + +: begin-branch ( -- ) clone-current-height (begin-basic-block) ; + +: end-branch ( -- pair/f ) + ! pair is { final-bb final-height } + basic-block get dup [ + ##branch + end-local-analysis + current-height get clone 2array + ] when ; + +: with-branch ( quot -- pair/f ) + [ begin-branch call end-branch ] with-scope ; inline + +: set-successors ( branches -- ) + ! Set the successor of each branch's final basic block to the + ! current block. + basic-block get dup [ + '[ [ [ _ ] dip first successors>> push ] when* ] each + ] [ 2drop ] if ; + +: merge-heights ( branches -- ) + ! If all elements are f, that means every branch ended with a backward + ! jump so the height is irrelevant since this block is unreachable. + [ ] find nip [ second current-height set ] [ end-basic-block ] if* ; + +: emit-conditional ( branches -- ) + ! branchies is a sequence of pairs as above + end-basic-block + [ merge-heights begin-basic-block ] + [ set-successors ] + bi ; + diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 7381bdca55..812ef18e86 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -2,12 +2,12 @@ IN: compiler.cfg.builder.tests USING: tools.test kernel sequences words sequences.private fry prettyprint alien alien.accessors math.private compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger -compiler.cfg.predecessors compiler.cfg.checker arrays locals -byte-arrays kernel.private math slots.private ; +compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker +arrays locals byte-arrays kernel.private math slots.private ; ! Just ensure that various CFGs build correctly. : unit-test-cfg ( quot -- ) - '[ _ test-cfg [ compute-predecessors check-cfg ] each ] [ ] swap unit-test ; + '[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ; : blahblah ( nodes -- ? ) { fixnum } declare [ diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 7a7156d5c9..7a877ad49f 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -10,30 +10,39 @@ compiler.tree.combinators compiler.tree.propagation.info compiler.cfg compiler.cfg.hats -compiler.cfg.stacks compiler.cfg.utilities compiler.cfg.registers compiler.cfg.intrinsics compiler.cfg.comparisons compiler.cfg.stack-frame compiler.cfg.instructions +compiler.cfg.predecessors +compiler.cfg.builder.blocks +compiler.cfg.stacks compiler.alien ; IN: compiler.cfg.builder -! Convert tree SSA IR to CFG SSA IR. +! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is +! constructed later by calling compiler.cfg.ssa:construct-ssa. SYMBOL: procedures SYMBOL: loops -: begin-procedure ( word label -- ) - end-basic-block - begin-basic-block +: begin-cfg ( word label -- cfg ) + initial-basic-block H{ } clone loops set - [ basic-block get ] 2dip - procedures get push ; + [ basic-block get ] 2dip dup cfg set ; + +: begin-procedure ( word label -- ) + begin-cfg procedures get push ; : with-cfg-builder ( nodes word label quot -- ) - '[ begin-procedure @ ] with-scope ; inline + '[ + begin-stack-analysis + begin-procedure + @ + end-stack-analysis + ] with-scope ; inline GENERIC: emit-node ( node -- ) @@ -61,7 +70,7 @@ GENERIC: emit-node ( node -- ) : emit-loop-call ( basic-block -- ) ##branch basic-block get successors>> push - basic-block off ; + end-basic-block ; : emit-trivial-block ( quot -- ) basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless @@ -71,7 +80,7 @@ GENERIC: emit-node ( node -- ) : emit-call ( word height -- ) over loops get key? [ drop loops get at emit-loop-call ] - [ [ ##call ] emit-trivial-block ] + [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ] if ; ! #recursive @@ -169,7 +178,7 @@ M: #return-recursive emit-node label>> id>> loops get key? [ emit-return ] unless ; ! #terminate -M: #terminate emit-node drop ##no-tco basic-block off ; +M: #terminate emit-node drop ##no-tco end-basic-block ; ! FFI : return-size ( ctype -- n ) @@ -186,9 +195,13 @@ M: #terminate emit-node drop ##no-tco basic-block off ; [ return>> return-size >>return ] [ alien-parameters parameter-sizes drop >>params ] bi ; +: alien-node-height ( params -- n ) + [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; + : emit-alien-node ( node quot -- ) [ - [ params>> dup ] dip call + [ params>> dup dup ] dip call + alien-node-height ] emit-trivial-block ; inline M: #alien-invoke emit-node diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 53f84b1dda..22b6f03231 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities -compiler.cfg.dce compiler.cfg.mr combinators.short-circuit accessors -math sequences sets assocs ; +compiler.cfg.mr combinators.short-circuit accessors math +sequences sets assocs ; IN: compiler.cfg.checker ERROR: bad-kill-block bb ; @@ -64,5 +64,5 @@ ERROR: undefined-values uses defs ; : check-cfg ( cfg -- ) [ [ check-basic-block ] each-basic-block ] - [ eliminate-dead-code build-mr check-mr ] + [ build-mr check-mr ] bi ; diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor deleted file mode 100644 index c987d9edd2..0000000000 --- a/basis/compiler/cfg/dcn/dcn-tests.factor +++ /dev/null @@ -1,620 +0,0 @@ -IN: compiler.cfg.dcn.tests -USING: tools.test kernel accessors namespaces assocs math -cpu.architecture vectors sequences classes -compiler.cfg -compiler.cfg.utilities -compiler.cfg.debugger -compiler.cfg.registers -compiler.cfg.predecessors -compiler.cfg.instructions -compiler.cfg.checker -compiler.cfg.dcn -compiler.cfg.dcn.height -compiler.cfg.dcn.local -compiler.cfg.dcn.local.private -compiler.cfg.dcn.global -compiler.cfg.dcn.rewrite ; - -: test-local-dcn ( insns -- insns' ) - swap >>instructions - [ local-analysis ] keep - instructions>> ; - -: inserting-peeks' ( from to -- assoc ) - [ inserting-peeks ] keep untranslate-locs keys ; - -: inserting-replaces' ( from to -- assoc ) - [ inserting-replaces ] keep untranslate-locs [ drop n>> 0 >= ] assoc-filter keys ; - -[ - V{ - T{ ##copy f V int-regs 1 V int-regs 0 } - T{ ##copy f V int-regs 3 V int-regs 2 } - T{ ##copy f V int-regs 5 V int-regs 4 } - T{ ##inc-d f -1 } - T{ ##branch } - } -] [ - V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 0 } - T{ ##inc-d f -1 } - T{ ##peek f V int-regs 2 D 0 } - T{ ##peek f V int-regs 3 D 0 } - T{ ##replace f V int-regs 2 D 0 } - T{ ##replace f V int-regs 4 D 1 } - T{ ##peek f V int-regs 5 D 1 } - T{ ##replace f V int-regs 5 D 1 } - T{ ##replace f V int-regs 6 D -1 } - T{ ##branch } - } test-local-dcn -] unit-test - -[ - H{ - { V int-regs 1 V int-regs 0 } - { V int-regs 3 V int-regs 2 } - { V int-regs 5 V int-regs 4 } - } -] [ - copies get -] unit-test - -[ - H{ - { D 0 V int-regs 0 } - { D 1 V int-regs 2 } - } -] [ reads-locations get ] unit-test - -[ - H{ - { D 0 V int-regs 6 } - { D 2 V int-regs 4 } - } -] [ writes-locations get ] unit-test - -: test-global-dcn ( -- ) - cfg new 0 get >>entry - compute-predecessors - deconcatenatize - drop ; - -V{ T{ ##epilogue } T{ ##return } } 0 test-bb - -[ ] [ test-global-dcn ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##inc-d f 1 } - T{ ##peek f V int-regs 0 D 1 } - T{ ##load-immediate f V int-regs 1 100 } - T{ ##replace f V int-regs 1 D 2 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 2 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 1vector >>successors drop - -[ t ] [ 0 get kill-block? ] unit-test -[ t ] [ 2 get kill-block? ] unit-test - -[ ] [ test-global-dcn ] unit-test - -[ t ] [ D 0 1 get peek-in key? ] unit-test - -[ f ] [ D 0 0 get peek-in key? ] unit-test - -[ t ] [ D 0 1 get avail-out key? ] unit-test - -[ f ] [ D 0 0 get avail-out key? ] unit-test - -[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test - -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test - -[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test - -[ { D 2 } ] [ 1 get 2 get inserting-replaces' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 1 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##inc-d f -1 } - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 3 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 1vector >>successors drop -2 get 3 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ t ] [ D 1 2 get peek-in key? ] unit-test -[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##branch } -} 1 test-bb - -V{ - T{ ##inc-d f 1 } - T{ ##peek f V int-regs 0 D 1 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 3 test-bb - -V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##peek f V int-regs 2 D 1 } - T{ ##inc-d f 1 } - T{ ##replace f V int-regs 2 D 1 } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 5 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 4 get V{ } 2sequence >>successors drop -2 get 3 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ f ] [ D 0 1 get avail-out key? ] unit-test -[ f ] [ D 1 1 get avail-out key? ] unit-test -[ t ] [ D 0 4 get peek-in key? ] unit-test -[ t ] [ D 1 4 get peek-in key? ] unit-test - -[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test -[ { D 1 } ] [ 1 get 4 get inserting-peeks' ] unit-test -[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test -[ { D 1 } ] [ 4 get 5 get inserting-replaces' ] unit-test - -[ t ] [ D 0 1 get peek-out key? ] unit-test -[ f ] [ D 1 1 get peek-out key? ] unit-test - -[ t ] [ D 1 4 get peek-in key? ] unit-test -[ f ] [ D 1 4 get avail-in key? ] unit-test -[ t ] [ D 1 4 get avail-out key? ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##peek f V int-regs 1 D 1 } - T{ ##inc-d f -1 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##load-immediate f V int-regs 2 100 } - T{ ##replace f V int-regs 2 D 1 } - T{ ##inc-d f -1 } - T{ ##peek f V int-regs 4 D 1 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##load-immediate f V int-regs 3 100 } - T{ ##replace f V int-regs 3 D 0 } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 5 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ t ] [ D 1 4 get avail-in key? ] unit-test -[ f ] [ D 2 4 get avail-in key? ] unit-test -[ t ] [ D 1 2 get peek-in key? ] unit-test -[ f ] [ D 1 3 get peek-in key? ] unit-test - -[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test -[ { D 1 } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test -[ { D 2 } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test -[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test -[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test -[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 1 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##inc-d f -1 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##call f drop -1 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 5 test-bb - -[ t ] [ 0 get kill-block? ] unit-test -[ t ] [ 3 get kill-block? ] unit-test - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ t ] [ D 1 2 get avail-out key? ] unit-test -[ f ] [ D 1 3 get peek-out key? ] unit-test -[ f ] [ D 1 3 get avail-out key? ] unit-test -[ f ] [ D 1 4 get avail-in key? ] unit-test - -[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test -[ { D 0 } ] [ 3 get 4 get inserting-peeks' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 1 test-bb - -V{ T{ ##epilogue } T{ ##return } } 2 test-bb - -V{ T{ ##branch } } 3 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -3 get 1 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ t ] [ D 0 1 get avail-out key? ] unit-test - -[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 3 get 1 get inserting-peeks' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##branch } -} 1 test-bb - -V{ - T{ ##call f drop } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##branch } -} 3 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##branch } -} 5 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 6 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop -5 get 6 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ { } ] [ 0 get 1 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test -[ { D 0 } ] [ 2 get 4 get inserting-peeks' ] unit-test -[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test -[ { } ] [ 5 get 6 get inserting-peeks' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##branch } -} 1 test-bb - -V{ - T{ ##load-immediate f V int-regs 1 100 } - T{ ##replace f V int-regs 1 D 0 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##peek f V int-regs 2 D 0 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 4 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 5 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test -[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test -[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test -[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test -[ { D 0 } ] [ 2 get 4 get inserting-replaces' ] unit-test -[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test -[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test -[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test -[ { } ] [ 4 get 5 get inserting-replaces' ] unit-test - -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##branch } -} 1 test-bb - -V{ - T{ ##load-immediate f V int-regs 1 100 } - T{ ##replace f V int-regs 1 D 0 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##load-immediate f V int-regs 2 100 } - T{ ##replace f V int-regs 2 D 0 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##branch } -} 4 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 5 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test - -[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test - -[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test - -! Dead replace elimination -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##replace f V int-regs 1 D 0 } - T{ ##replace f V int-regs 0 D 1 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##inc-d f -2 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 3 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 1vector >>successors drop -2 get 3 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test -[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test -[ { } ] [ 2 get 3 get inserting-replaces' ] unit-test - -! More dead replace elimination tests -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek { dst V int-regs 10 } { loc D 0 } } - T{ ##inc-d { n -1 } } - T{ ##inc-r { n 1 } } - T{ ##replace { src V int-regs 10 } { loc R 0 } } - T{ ##peek { dst V int-regs 12 } { loc R 0 } } - T{ ##inc-r { n -1 } } - T{ ##inc-d { n 1 } } - T{ ##replace { src V int-regs 12 } { loc D 0 } } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 2 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test - -! Check that retain stack usage works -V{ - T{ ##prologue } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##inc-d f -1 } - T{ ##inc-r f 1 } - T{ ##replace f V int-regs 0 R 0 } - T{ ##branch } -} 1 test-bb - -V{ - T{ ##call f + -1 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##peek f V int-regs 0 R 0 } - T{ ##inc-r f -1 } - T{ ##inc-d f 1 } - T{ ##replace f V int-regs 0 D 0 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##epilogue } - T{ ##return } -} 4 test-bb - -0 get 1 get 1vector >>successors drop -1 get 2 get 1vector >>successors drop -2 get 3 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop - -[ ] [ test-global-dcn ] unit-test - -[ ##replace D 0 ] [ - 3 get successors>> first instructions>> first - [ class ] [ loc>> ] bi -] unit-test - -[ ##replace R 0 ] [ - 1 get successors>> first instructions>> first - [ class ] [ loc>> ] bi -] unit-test - -[ ##peek R 0 ] [ - 2 get successors>> first instructions>> first - [ class ] [ loc>> ] bi -] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/dcn.factor b/basis/compiler/cfg/dcn/dcn.factor deleted file mode 100644 index e2e52b30d5..0000000000 --- a/basis/compiler/cfg/dcn/dcn.factor +++ /dev/null @@ -1,44 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: combinators -compiler.cfg -compiler.cfg.dcn.height -compiler.cfg.dcn.local -compiler.cfg.dcn.global -compiler.cfg.dcn.rewrite ; -IN: compiler.cfg.dcn - -! "DeConcatenatizatioN" -- dataflow analysis to recover registers -! from stack locations. - -! Local sets: -! - P(b): locations that block b peeks before replacing -! - R(b): locations that block b replaces -! - A(b): P(b) \/ R(b) -- locations that are available in registers at the end of b - -! Global sets: -! - P_out(b) = /\ P_in(sux) for sux in successors(b) -! - P_in(b) = (P_out(b) - R(b)) \/ P(b) -! -! - R_in(b) = R_out(b) \/ R(b) -! - R_out(b) = \/ R_in(sux) for sux in successors(b) -! -! - A_in(b) = /\ A_out(pred) for pred in predecessors(b) -! - A_out(b) = A_in(b) \/ P(b) \/ R(b) - -! On every edge [b --> sux], insert a replace for each location in -! R_out(b) - R_in(sux) - -! On every edge [pred --> b], insert a peek for each location in -! P_in(b) - (P_out(pred) \/ A_out(pred)) - -! Locations are height-normalized. - -: deconcatenatize ( cfg -- cfg' ) - { - [ compute-heights ] - [ compute-local-sets ] - [ compute-global-sets ] - [ rewrite ] - [ cfg-changed ] - } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/height/height.factor b/basis/compiler/cfg/dcn/height/height.factor deleted file mode 100644 index 1a59ddcb35..0000000000 --- a/basis/compiler/cfg/dcn/height/height.factor +++ /dev/null @@ -1,82 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs accessors sequences kernel math locals fry -compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.registers ; -IN: compiler.cfg.dcn.height - -! Compute block in-height and out-height sets. These are relative to the -! stack height from the start of the procedure. - -> ; - -M: ##call ds-height-change height>> ; - -: alien-node-height ( node -- n ) - params>> [ out-d>> length ] [ in-d>> length ] bi - ; - -M: ##alien-invoke ds-height-change alien-node-height ; - -M: ##alien-indirect ds-height-change alien-node-height ; - -GENERIC: rs-height-change ( insn -- n ) - -M: insn rs-height-change drop 0 ; - -M: ##inc-r rs-height-change n>> ; - -:: compute-in-height ( bb in out -- ) - bb predecessors>> [ out at ] map-find drop 0 or - bb in set-at ; - -:: compute-out-height ( bb in out quot -- ) - bb instructions>> - bb in at - [ quot call + ] reduce - bb out set-at ; inline - -:: compute-height ( bb in out quot -- ) - bb in get out get - [ compute-in-height ] - [ quot compute-out-height ] 3bi ; inline - -: compute-ds-height ( bb -- ) - in-ds-heights out-ds-heights [ ds-height-change ] compute-height ; - -: compute-rs-height ( bb -- ) - in-rs-heights out-rs-heights [ rs-height-change ] compute-height ; - -PRIVATE> - -: compute-heights ( cfg -- ) - H{ } clone in-ds-heights set - H{ } clone out-ds-heights set - H{ } clone in-rs-heights set - H{ } clone out-rs-heights set - [ - [ compute-rs-height ] - [ compute-ds-height ] bi - ] each-basic-block ; - -GENERIC# translate-loc 1 ( loc bb -- loc' ) - -M: ds-loc translate-loc [ n>> ] [ in-ds-heights get at ] bi* - ; -M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - ; - -: translate-locs ( assoc bb -- assoc' ) - '[ [ _ translate-loc ] dip ] assoc-map ; - -GENERIC# untranslate-loc 1 ( loc bb -- loc' ) - -M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + ; -M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + ; - -: untranslate-locs ( assoc bb -- assoc' ) - '[ [ _ untranslate-loc ] dip ] assoc-map ; diff --git a/basis/compiler/cfg/dcn/local/local.factor b/basis/compiler/cfg/dcn/local/local.factor deleted file mode 100644 index 3ed543f868..0000000000 --- a/basis/compiler/cfg/dcn/local/local.factor +++ /dev/null @@ -1,101 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs kernel make namespaces sequences math -compiler.cfg.rpo compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.dcn.height ; -IN: compiler.cfg.dcn.local - -vreg ( loc -- vreg ) - dup writes-locations get at - [ ] [ reads-locations get at ] ?if ; - -SYMBOL: ds-height - -SYMBOL: rs-height - -GENERIC: translate-loc ( loc -- loc' ) - -M: ds-loc translate-loc n>> ds-height get - ; - -M: rs-loc translate-loc n>> rs-height get - ; - -GENERIC: visit ( insn -- ) - -M: insn visit , ; - -M: ##inc-d visit n>> ds-height [ + ] change ; - -M: ##inc-r visit n>> rs-height [ + ] change ; - -M: ##peek visit - ! If location is in a register already, copy existing - ! register to destination. Otherwise, associate the - ! location with the register. - [ dst>> ] [ loc>> translate-loc ] bi dup loc>vreg - [ [ record-copy ] [ ##copy ] 2bi ] - [ reads-locations get set-at ] - ?if ; - -M: ##replace visit - ! If location already contains the same value, do nothing. - ! Otherwise, associate the location with the register. - [ src>> resolve-copy ] [ loc>> translate-loc ] bi 2dup loc>vreg = - [ 2drop ] [ writes-locations get set-at ] if ; - -M: ##copy visit - ! Not needed at this point because IR doesn't have ##copy - ! on input to dcn pass, but in the future it might. - [ dst>> ] [ src>> resolve-copy ] bi record-copy ; - -: insert-height-changes ( -- ) - ds-height get dup 0 = [ drop ] [ ##inc-d ] if - rs-height get dup 0 = [ drop ] [ ##inc-r ] if ; - -: init-local-analysis ( -- ) - 0 ds-height set - 0 rs-height set - H{ } clone copies set - H{ } clone reads-locations set - H{ } clone writes-locations set ; - -: local-analysis ( bb -- ) - ! Removes all ##peek and ##replace from the basic block. - ! Conceptually, moves all ##peeks to the start - ! (reads-locations assoc) and all ##replaces to the end - ! (writes-locations assoc). - init-local-analysis - [ - [ - unclip-last-slice [ [ visit ] each ] dip - insert-height-changes - , - ] V{ } make - ] change-instructions drop ; - -SYMBOLS: peeks replaces ; - -: visit-block ( bb -- ) - [ local-analysis ] - [ [ reads-locations get ] dip [ translate-locs ] keep peeks get set-at ] - [ [ writes-locations get ] dip [ translate-locs ] keep replaces get set-at ] - tri ; - -PRIVATE> - -: peek ( bb -- assoc ) peeks get at ; -: replace ( bb -- assoc ) replaces get at ; - -: compute-local-sets ( cfg -- ) - H{ } clone peeks set - H{ } clone replaces set - [ visit-block ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 2496b29ae2..07ebcc3ba9 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -52,7 +52,7 @@ INSN: ##inc-d { n integer } ; INSN: ##inc-r { n integer } ; ! Subroutine calls -INSN: ##call word { height integer } ; +INSN: ##call word ; INSN: ##jump word ; INSN: ##return ; diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 42e23c29c9..04d841f2d1 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -1,10 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences alien math classes.algebra -fry locals combinators cpu.architecture -compiler.tree.propagation.info +USING: accessors kernel sequences alien math classes.algebra fry +locals combinators cpu.architecture compiler.tree.propagation.info compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions -compiler.cfg.utilities ; +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.alien : (prepare-alien-accessor-imm) ( class offset -- offset-vreg ) diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 7b407c3ee4..8afd9f80ca 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.order sequences accessors arrays byte-arrays layouts classes.tuple.private fry locals compiler.tree.propagation.info compiler.cfg.hats compiler.cfg.instructions compiler.cfg.stacks -compiler.cfg.utilities ; +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.allot : ##set-slots ( regs obj class -- ) diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index cfc07624fe..0eeeb0b12d 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -7,6 +7,7 @@ compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions compiler.cfg.utilities +compiler.cfg.builder.blocks compiler.cfg.registers compiler.cfg.comparisons ; IN: compiler.cfg.intrinsics.fixnum @@ -31,7 +32,7 @@ IN: compiler.cfg.intrinsics.fixnum [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ; : emit-fixnum-shift-general ( -- ) - D 0 ^^peek 0 cc> ##compare-imm-branch + ds-peek 0 cc> ##compare-imm-branch [ emit-fixnum-left-shift ] with-branch [ emit-fixnum-right-shift ] with-branch 2array emit-conditional ; @@ -62,13 +63,13 @@ IN: compiler.cfg.intrinsics.fixnum ds-pop ^^untag-fixnum ^^integer>bignum ds-push ; : emit-no-overflow-case ( dst -- final-bb ) - [ -2 ##inc-d ds-push ] with-branch ; + [ ds-drop ds-drop ds-push ] with-branch ; : emit-overflow-case ( word -- final-bb ) - [ -1 ##call ] with-branch ; + [ ##call -1 adjust-d ] with-branch ; : emit-fixnum-overflow-op ( quot word -- ) - [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip + [ [ (2inputs) ] dip call ] dip [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array emit-conditional ; inline diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 0cc6e6f5d0..93139a19a3 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: layouts namespaces kernel accessors sequences classes.algebra compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions -compiler.cfg.utilities ; +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.slots : value-tag ( info -- n ) class>> class-tag ; inline diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 1f00913b1e..f9e0e54afc 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -25,11 +25,12 @@ M: insn linearize-insn , drop ; #! don't need to branch. [ number>> ] bi@ 1 - = ; inline -: emit-loop-entry? ( bb -- ? ) - dup predecessors>> [ swap back-edge? ] with any? ; +: emit-loop-entry? ( bb successor -- ? ) + [ back-edge? not ] + [ nip dup predecessors>> [ swap back-edge? ] with any? ] 2bi and ; : emit-branch ( bb successor -- ) - dup emit-loop-entry? [ _loop-entry ] when + 2dup emit-loop-entry? [ _loop-entry ] when 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ; M: ##branch linearize-insn diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 0b37157b43..e4ad290097 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -4,7 +4,6 @@ USING: kernel sequences accessors combinators namespaces compiler.cfg.tco compiler.cfg.predecessors compiler.cfg.useless-conditionals -compiler.cfg.dcn compiler.cfg.ssa compiler.cfg.branch-splitting compiler.cfg.block-joining @@ -35,7 +34,6 @@ SYMBOL: check-optimizer? split-branches join-blocks compute-predecessors - deconcatenatize construct-ssa alias-analysis value-numbering diff --git a/basis/compiler/cfg/dcn/rewrite/rewrite.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor similarity index 51% rename from basis/compiler/cfg/dcn/rewrite/rewrite.factor rename to basis/compiler/cfg/stacks/finalize/finalize.factor index bbc6783f79..5c8c1343d0 100644 --- a/basis/compiler/cfg/dcn/rewrite/rewrite.factor +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -2,13 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs kernel fry accessors sequences make math combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions -compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.dcn.local -compiler.cfg.dcn.global compiler.cfg.dcn.height ; -IN: compiler.cfg.dcn.rewrite +compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local +compiler.cfg.stacks.global compiler.cfg.stacks.height ; +IN: compiler.cfg.stacks.finalize -! This pass inserts peeks, replaces, and copies. All stack locations -! are loaded to canonical vregs, with a 1-1 mapping from location to -! vreg. SSA is reconstructed afterwards. +! This pass inserts peeks and replaces. : inserting-peeks ( from to -- assoc ) peek-in swap [ peek-out ] [ avail-out ] bi @@ -18,10 +16,6 @@ IN: compiler.cfg.dcn.rewrite [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi* assoc-union assoc-diff ; -SYMBOL: locs>vregs - -: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ; - : each-insertion ( assoc bb quot: ( vreg loc -- ) -- ) '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline @@ -39,30 +33,9 @@ ERROR: bad-peek dst loc ; 2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make [ 2drop ] [ insert-basic-block ] if-empty ; -: visit-edges ( bb -- ) +: visit-block ( bb -- ) [ predecessors>> ] keep '[ _ visit-edge ] each ; -: insert-in-copies ( bb -- ) - peek [ swap loc>vreg ##copy ] assoc-each ; - -: insert-out-copies ( bb -- ) - replace [ swap loc>vreg swap ##copy ] assoc-each ; - -: rewrite-instructions ( bb -- ) - [ - [ - { - [ insert-in-copies ] - [ instructions>> but-last-slice % ] - [ insert-out-copies ] - [ instructions>> last , ] - } cleave - ] V{ } make - ] keep (>>instructions) ; - -: visit-block ( bb -- ) - [ visit-edges ] [ rewrite-instructions ] bi ; - -: rewrite ( cfg -- ) - H{ } clone locs>vregs set - [ visit-block ] each-basic-block ; \ No newline at end of file +: finalize-stack-shuffling ( cfg -- cfg' ) + dup [ visit-block ] each-basic-block + cfg-changed ; \ No newline at end of file diff --git a/basis/compiler/cfg/dcn/global/global.factor b/basis/compiler/cfg/stacks/global/global.factor similarity index 65% rename from basis/compiler/cfg/dcn/global/global.factor rename to basis/compiler/cfg/stacks/global/global.factor index 21a795151a..129d7e74cd 100644 --- a/basis/compiler/cfg/dcn/global/global.factor +++ b/basis/compiler/cfg/stacks/global/global.factor @@ -1,38 +1,39 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel combinators compiler.cfg.dataflow-analysis -compiler.cfg.dcn.local ; -IN: compiler.cfg.dcn.global +compiler.cfg.stacks.local ; +IN: compiler.cfg.stacks.global ! Peek analysis. Peek-in is the set of all locations anticipated at ! the start of a basic block. BACKWARD-ANALYSIS: peek -M: peek-analysis transfer-set drop [ replace assoc-diff ] keep peek assoc-union ; +M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ; ! Replace analysis. Replace-in is the set of all locations which ! will be overwritten at some point after the start of a basic block. FORWARD-ANALYSIS: replace -M: replace-analysis transfer-set drop replace assoc-union ; +M: replace-analysis transfer-set drop replace-set assoc-union ; ! Availability analysis. Avail-out is the set of all locations ! in registers at the end of a basic block. FORWARD-ANALYSIS: avail -M: avail-analysis transfer-set drop [ peek ] [ replace ] bi assoc-union assoc-union ; +M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ; ! Kill analysis. Kill-in is the set of all locations ! which are going to be overwritten. BACKWARD-ANALYSIS: kill -M: kill-analysis transfer-set drop replace assoc-union ; +M: kill-analysis transfer-set drop replace-set assoc-union ; ! Main word -: compute-global-sets ( cfg -- ) +: compute-global-sets ( cfg -- cfg' ) { [ compute-peek-sets ] [ compute-replace-sets ] [ compute-avail-sets ] [ compute-kill-sets ] + [ ] } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/height/height.factor b/basis/compiler/cfg/stacks/height/height.factor new file mode 100644 index 0000000000..4d91dc614a --- /dev/null +++ b/basis/compiler/cfg/stacks/height/height.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel math +namespaces compiler.cfg.registers ; +IN: compiler.cfg.stacks.height + +! Global stack height tracking done while constructing CFG. +SYMBOLS: ds-heights rs-heights ; + +: record-stack-heights ( ds-height rs-height bb -- ) + [ ds-heights get set-at ] [ rs-heights get set-at ] bi-curry bi* ; + +GENERIC# translate-loc 1 ( loc bb -- loc' ) + +M: ds-loc translate-loc [ n>> ] [ ds-heights get at ] bi* - ; +M: rs-loc translate-loc [ n>> ] [ rs-heights get at ] bi* - ; + +: translate-locs ( assoc bb -- assoc' ) + '[ [ _ translate-loc ] dip ] assoc-map ; + +GENERIC# untranslate-loc 1 ( loc bb -- loc' ) + +M: ds-loc untranslate-loc [ n>> ] [ ds-heights get at ] bi* + ; +M: rs-loc untranslate-loc [ n>> ] [ rs-heights get at ] bi* + ; + +: untranslate-locs ( assoc bb -- assoc' ) + '[ [ _ untranslate-loc ] dip ] assoc-map ; \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor new file mode 100644 index 0000000000..a484464a59 --- /dev/null +++ b/basis/compiler/cfg/stacks/local/local.factor @@ -0,0 +1,80 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel math namespaces sets make sequences +compiler.cfg compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.stacks.height ; +IN: compiler.cfg.stacks.local + +! Local stack analysis. We build local peek and replace sets for every basic +! block while constructing the CFG. + +SYMBOLS: peek-sets replace-sets ; + +SYMBOL: locs>vregs + +: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ; + +TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ; + +SYMBOLS: copies local-peek-set local-replace-set ; + +: record-copy ( dst src -- ) swap copies get set-at ; +: resolve-copy ( vreg -- vreg' ) copies get ?at drop ; + +GENERIC: translate-local-loc ( loc -- loc' ) +M: ds-loc translate-local-loc n>> current-height get d>> - ; +M: rs-loc translate-local-loc n>> current-height get r>> - ; + +: emit-height-changes ( -- ) + ! Insert height changes prior to the last instruction + building get pop + current-height get + [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ] + [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi + , ; + +! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later +: inc-d ( n -- ) + current-height get + [ [ + ] change-emit-d drop ] + [ [ + ] change-d drop ] + 2bi ; + +: inc-r ( n -- ) + current-height get + [ [ + ] change-emit-r drop ] + [ [ + ] change-r drop ] + 2bi ; + +: peek-loc ( loc -- vreg ) + translate-local-loc + [ dup local-replace-set get key? [ drop ] [ local-peek-set get conjoin ] if ] + [ loc>vreg [ i ] dip [ record-copy ] [ ##copy ] [ drop ] 2tri ] + bi ; + +: replace-loc ( vreg loc -- ) + translate-local-loc + 2dup [ resolve-copy ] dip loc>vreg = [ 2drop ] [ + [ local-replace-set get conjoin ] + [ loc>vreg swap ##copy ] + bi + ] if ; + +: begin-local-analysis ( -- ) + H{ } clone copies set + H{ } clone local-peek-set set + H{ } clone local-replace-set set + current-height get 0 >>emit-d 0 >>emit-r drop + current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ; + +: end-local-analysis ( -- ) + emit-height-changes + local-peek-set get basic-block get peek-sets get set-at + local-replace-set get basic-block get replace-sets get set-at ; + +: clone-current-height ( -- ) + current-height [ clone ] change ; + +: peek-set ( bb -- assoc ) peek-sets get at ; +: replace-set ( bb -- assoc ) replace-sets get at ; diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index c8fcae87c0..f68b70467a 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -1,45 +1,76 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math sequences kernel cpu.architecture -compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.hats ; +USING: math sequences kernel namespaces accessors compiler.cfg +compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats +compiler.cfg.predecessors compiler.cfg.stacks.local +compiler.cfg.stacks.height compiler.cfg.stacks.global +compiler.cfg.stacks.finalize ; IN: compiler.cfg.stacks -: ds-drop ( -- ) - -1 ##inc-d ; +: begin-stack-analysis ( -- ) + H{ } clone locs>vregs set + H{ } clone ds-heights set + H{ } clone rs-heights set + H{ } clone peek-sets set + H{ } clone replace-sets set + current-height new current-height set ; -: ds-pop ( -- vreg ) - D 0 ^^peek -1 ##inc-d ; +: end-stack-analysis ( -- ) + cfg get + compute-predecessors + compute-global-sets + finalize-stack-shuffling + drop ; -: ds-push ( vreg -- ) - 1 ##inc-d D 0 ##replace ; +: ds-drop ( -- ) -1 inc-d ; + +: ds-peek ( -- vreg ) D 0 peek-loc ; + +: ds-pop ( -- vreg ) ds-peek ds-drop ; + +: ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ; : ds-load ( n -- vregs ) dup 0 = [ drop f ] - [ [ [ ^^peek ] map ] [ neg ##inc-d ] bi ] if ; + [ [ [ peek-loc ] map ] [ neg inc-d ] bi ] if ; : ds-store ( vregs -- ) [ - [ length ##inc-d ] - [ [ ##replace ] each-index ] bi + [ length inc-d ] + [ [ replace-loc ] each-index ] bi ] unless-empty ; +: rs-drop ( -- ) -1 inc-r ; + : rs-load ( n -- vregs ) dup 0 = [ drop f ] - [ [ [ ^^peek ] map ] [ neg ##inc-r ] bi ] if ; + [ [ [ peek-loc ] map ] [ neg inc-r ] bi ] if ; : rs-store ( vregs -- ) [ - [ length ##inc-r ] - [ [ ##replace ] each-index ] bi + [ length inc-r ] + [ [ replace-loc ] each-index ] bi ] unless-empty ; +: (2inputs) ( -- vreg1 vreg2 ) + D 1 peek-loc D 0 peek-loc ; + : 2inputs ( -- vreg1 vreg2 ) - D 1 ^^peek D 0 ^^peek -2 ##inc-d ; + (2inputs) -2 inc-d ; + +: (3inputs) ( -- vreg1 vreg2 vreg3 ) + D 2 peek-loc D 1 peek-loc D 0 peek-loc ; : 3inputs ( -- vreg1 vreg2 vreg3 ) - D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ; + (3inputs) -3 inc-d ; + +! adjust-d/adjust-r: these are called when other instructions which +! internally adjust the stack height are emitted, such as ##call and +! ##alien-invoke +: adjust-d ( n -- ) current-height get [ + ] change-d drop ; +: adjust-r ( n -- ) current-height get [ + ] change-r drop ; + diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index c3d3e47485..ad3ee9c57b 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -20,42 +20,6 @@ IN: compiler.cfg.utilities } cond ] [ drop f ] if ; -: set-basic-block ( basic-block -- ) - [ basic-block set ] [ instructions>> building set ] bi ; - -: begin-basic-block ( -- ) - basic-block get [ - dupd successors>> push - ] when* - set-basic-block ; - -: end-basic-block ( -- ) - building off - basic-block off ; - -: emit-trivial-block ( quot -- ) - basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless - call - ##branch begin-basic-block ; inline - -: call-height ( #call -- n ) - [ out-d>> length ] [ in-d>> length ] bi - ; - -: emit-primitive ( node -- ) - [ [ word>> ] [ call-height ] bi ##call ] emit-trivial-block ; - -: with-branch ( quot -- final-bb ) - [ - begin-basic-block - call - basic-block get dup [ ##branch ] when - ] with-scope ; inline - -: emit-conditional ( branches -- ) - end-basic-block - begin-basic-block - basic-block get '[ [ _ swap successors>> push ] when* ] each ; - PREDICATE: kill-block < basic-block instructions>> { [ length 2 = ] From 2bea1072025902d557023584189a40c2ec6549c4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Jul 2009 21:24:15 -0500 Subject: [PATCH 23/81] compiler.cfg.builder: fix stack effect declaration --- basis/compiler/cfg/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 7a877ad49f..4ae5cfcc57 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -195,7 +195,7 @@ M: #terminate emit-node drop ##no-tco end-basic-block ; [ return>> return-size >>return ] [ alien-parameters parameter-sizes drop >>params ] bi ; -: alien-node-height ( params -- n ) +: alien-node-height ( params -- ) [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; : emit-alien-node ( node quot -- ) From 7590ad3574e123c342ddf61bb9987f4cd580cdda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 03:37:18 -0500 Subject: [PATCH 24/81] compiler.cfg: introduce less temporaries when building CFG --- .../compiler/cfg/builder/blocks/blocks.factor | 2 +- basis/compiler/cfg/builder/builder.factor | 18 ++++---- basis/compiler/cfg/hats/hats.factor | 4 +- .../cfg/intrinsics/fixnum/fixnum.factor | 4 +- basis/compiler/cfg/stacks/local/local.factor | 45 ++++++++++++------- basis/compiler/cfg/stacks/stacks.factor | 4 +- 6 files changed, 45 insertions(+), 32 deletions(-) diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor index 4f4f9ad7b3..8e96255bdd 100644 --- a/basis/compiler/cfg/builder/blocks/blocks.factor +++ b/basis/compiler/cfg/builder/blocks/blocks.factor @@ -27,7 +27,7 @@ IN: compiler.cfg.builder.blocks (begin-basic-block) ; : emit-trivial-block ( quot -- ) - building get empty? [ ##branch begin-basic-block ] unless + ##branch begin-basic-block call ##branch begin-basic-block ; inline diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 4ae5cfcc57..ed1069d043 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -72,11 +72,6 @@ GENERIC: emit-node ( node -- ) basic-block get successors>> push end-basic-block ; -: emit-trivial-block ( quot -- ) - basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless - call - ##branch begin-basic-block ; inline - : emit-call ( word height -- ) over loops get key? [ drop loops get at emit-loop-call ] @@ -109,9 +104,6 @@ M: #recursive emit-node : emit-if ( node -- ) children>> [ emit-branch ] map emit-conditional ; -: ##branch-t ( vreg -- ) - \ f tag-number cc/= ##compare-imm-branch ; - : trivial-branch? ( nodes -- value ? ) dup length 1 = [ first dup #push? [ literal>> t ] [ drop f f ] if @@ -135,15 +127,23 @@ M: #recursive emit-node : emit-trivial-not-if ( -- ) ds-pop \ f tag-number cc= ^^compare-imm ds-push ; +: emit-actual-if ( #if -- ) + ! Inputs to the final instruction need to be copied because of + ! loc>vreg sync + ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ; + M: #if emit-node { { [ dup trivial-if? ] [ drop emit-trivial-if ] } { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] } - [ ds-pop ##branch-t emit-if ] + [ emit-actual-if ] } cond ; ! #dispatch M: #dispatch emit-node + ! Inputs to the final instruction need to be copied because of + ! loc>vreg sync. ^^offset>slot always returns a fresh vreg, + ! though. ds-pop ^^offset>slot i ##dispatch emit-if ; ! #call diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 287d0a6999..4c1999943f 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -18,7 +18,7 @@ IN: compiler.cfg.hats : ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline : ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline -: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline +: ^^copy ( src -- dst ) ^^i1 ##copy ; inline : ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline : ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline : ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline @@ -74,7 +74,7 @@ IN: compiler.cfg.hats : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline -: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline +: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline : ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 0eeeb0b12d..d4b9db58c8 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -69,7 +69,9 @@ IN: compiler.cfg.intrinsics.fixnum [ ##call -1 adjust-d ] with-branch ; : emit-fixnum-overflow-op ( quot word -- ) - [ [ (2inputs) ] dip call ] dip + ! Inputs to the final instruction need to be copied because + ! of loc>vreg sync + [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array emit-conditional ; inline diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor index a484464a59..754789042a 100644 --- a/basis/compiler/cfg/stacks/local/local.factor +++ b/basis/compiler/cfg/stacks/local/local.factor @@ -1,9 +1,12 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math namespaces sets make sequences -compiler.cfg compiler.cfg.hats -compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.stacks.height ; +compiler.cfg +compiler.cfg.hats +compiler.cfg.instructions +compiler.cfg.registers +compiler.cfg.stacks.height +compiler.cfg.parallel-copy ; IN: compiler.cfg.stacks.local ! Local stack analysis. We build local peek and replace sets for every basic @@ -14,24 +17,31 @@ SYMBOLS: peek-sets replace-sets ; SYMBOL: locs>vregs : loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ; +: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ; TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ; -SYMBOLS: copies local-peek-set local-replace-set ; - -: record-copy ( dst src -- ) swap copies get set-at ; -: resolve-copy ( vreg -- vreg' ) copies get ?at drop ; +SYMBOLS: local-peek-set local-replace-set replace-mapping ; GENERIC: translate-local-loc ( loc -- loc' ) M: ds-loc translate-local-loc n>> current-height get d>> - ; M: rs-loc translate-local-loc n>> current-height get r>> - ; +: emit-stack-changes ( -- ) + replace-mapping get dup assoc-empty? [ drop ] [ + [ [ loc>vreg ] dip ] assoc-map parallel-copy + ] if ; + : emit-height-changes ( -- ) - ! Insert height changes prior to the last instruction - building get pop current-height get [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ] - [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi + [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ; + +: emit-changes ( -- ) + ! Insert height and stack changes prior to the last instruction + building get pop + emit-stack-changes + emit-height-changes , ; ! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later @@ -49,27 +59,28 @@ M: rs-loc translate-local-loc n>> current-height get r>> - ; : peek-loc ( loc -- vreg ) translate-local-loc - [ dup local-replace-set get key? [ drop ] [ local-peek-set get conjoin ] if ] - [ loc>vreg [ i ] dip [ record-copy ] [ ##copy ] [ drop ] 2tri ] - bi ; + dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless + dup replace-mapping get at [ ] [ loc>vreg ] ?if ; : replace-loc ( vreg loc -- ) translate-local-loc - 2dup [ resolve-copy ] dip loc>vreg = [ 2drop ] [ + 2dup loc>vreg = + [ nip replace-mapping get delete-at ] + [ [ local-replace-set get conjoin ] - [ loc>vreg swap ##copy ] + [ replace-mapping get set-at ] bi ] if ; : begin-local-analysis ( -- ) - H{ } clone copies set H{ } clone local-peek-set set H{ } clone local-replace-set set + H{ } clone replace-mapping set current-height get 0 >>emit-d 0 >>emit-r drop current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ; : end-local-analysis ( -- ) - emit-height-changes + emit-changes local-peek-set get basic-block get peek-sets get set-at local-replace-set get basic-block get replace-sets get set-at ; diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index f68b70467a..2683222fb8 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math sequences kernel namespaces accessors compiler.cfg +USING: math sequences kernel namespaces accessors biassocs compiler.cfg compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats compiler.cfg.predecessors compiler.cfg.stacks.local compiler.cfg.stacks.height compiler.cfg.stacks.global @@ -8,7 +8,7 @@ compiler.cfg.stacks.finalize ; IN: compiler.cfg.stacks : begin-stack-analysis ( -- ) - H{ } clone locs>vregs set + locs>vregs set H{ } clone ds-heights set H{ } clone rs-heights set H{ } clone peek-sets set From de73534424d6ef19254e53ab1388c28985b090e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 05:29:28 -0500 Subject: [PATCH 25/81] compiler.cfg.write-barrier: simplify a little bit. It doesn't need to do copy propagation, since its a separate pass now --- .../cfg/write-barrier/write-barrier.factor | 31 +++++++------------ 1 file changed, 12 insertions(+), 19 deletions(-) diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index bcec542501..2f32a4ca81 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces assocs sets sequences locals -compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop -compiler.cfg.rpo ; +USING: kernel accessors namespaces assocs sets sequences +compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; IN: compiler.cfg.write-barrier ! Eliminate redundant write barrier hits. @@ -14,33 +13,27 @@ SYMBOL: safe ! Objects which have been mutated SYMBOL: mutated -GENERIC: eliminate-write-barrier ( insn -- insn' ) +GENERIC: eliminate-write-barrier ( insn -- ? ) M: ##allot eliminate-write-barrier - dup dst>> safe get conjoin ; + dst>> safe get conjoin t ; M: ##write-barrier eliminate-write-barrier - dup src>> resolve dup - [ safe get key? not ] - [ mutated get key? ] bi and - [ safe get conjoin ] [ 2drop f ] if ; - -M: ##copy eliminate-write-barrier - dup record-copy ; + src>> dup [ safe get key? not ] [ mutated get key? ] bi and + [ safe get conjoin t ] [ drop f ] if ; M: ##set-slot eliminate-write-barrier - dup obj>> resolve mutated get conjoin ; + obj>> mutated get conjoin t ; M: ##set-slot-imm eliminate-write-barrier - dup obj>> resolve mutated get conjoin ; + obj>> mutated get conjoin t ; -M: insn eliminate-write-barrier ; +M: insn eliminate-write-barrier drop t ; -: write-barriers-step ( insns -- insns' ) +: write-barriers-step ( bb -- ) H{ } clone safe set H{ } clone mutated set - H{ } clone copies set - [ eliminate-write-barrier ] map sift ; + instructions>> [ eliminate-write-barrier ] filter-here ; : eliminate-write-barriers ( cfg -- cfg' ) - [ write-barriers-step ] local-optimization ; + dup [ write-barriers-step ] each-basic-block ; From e0f6d89ff1f331dbd05fc6b6947394f3f811719c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 05:30:30 -0500 Subject: [PATCH 26/81] compiler.cfg.value-numbering: insert ##copy instructions for instructions whose expressions simplify. While subsequent usages are replaced with the instruction computing the simplified vreg locally, global usages may exist of the original instruction. In this case, the ##copy is not dead --- .../value-numbering/rewrite/rewrite.factor | 52 +++++++++---------- .../value-numbering/simplify/simplify.factor | 16 +++--- .../value-numbering/value-numbering.factor | 31 ++++++----- 3 files changed, 50 insertions(+), 49 deletions(-) diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index fcd1b1c9ac..4b8ee2a1ae 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -20,13 +20,9 @@ IN: compiler.cfg.value-numbering.rewrite ! Outputs f to mean no change -GENERIC: rewrite* ( insn -- insn/f ) +GENERIC: rewrite ( insn -- insn/f ) -: rewrite ( insn -- insn' ) - dup [ number-values ] [ rewrite* ] bi - [ rewrite ] [ ] ?if ; - -M: insn rewrite* drop f ; +M: insn rewrite drop f ; : ##branch-t? ( insn -- ? ) dup ##compare-imm-branch? [ @@ -123,7 +119,7 @@ ERROR: bad-comparison ; : fold-compare-imm-branch ( insn -- insn/f ) (fold-compare-imm) fold-branch ; -M: ##compare-imm-branch rewrite* +M: ##compare-imm-branch rewrite { { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] } { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } @@ -154,7 +150,7 @@ M: ##compare-imm-branch rewrite* : rewrite-self-compare-branch ( insn -- insn' ) (rewrite-self-compare) fold-branch ; -M: ##compare-branch rewrite* +M: ##compare-branch rewrite { { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] } { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] } @@ -185,7 +181,7 @@ M: ##compare-branch rewrite* : rewrite-self-compare ( insn -- insn' ) dup (rewrite-self-compare) >boolean-insn ; -M: ##compare rewrite* +M: ##compare rewrite { { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] } { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] } @@ -196,7 +192,7 @@ M: ##compare rewrite* : fold-compare-imm ( insn -- insn' ) dup (fold-compare-imm) >boolean-insn ; -M: ##compare-imm rewrite* +M: ##compare-imm rewrite { { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] } { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } @@ -238,7 +234,7 @@ M: ##shl-imm constant-fold* drop shift ; ] dip over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline -M: ##add-imm rewrite* +M: ##add-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##add-imm reassociate ] } @@ -249,7 +245,7 @@ M: ##add-imm rewrite* [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough? [ \ ##add-imm new-insn ] [ 3drop f ] if ; -M: ##sub-imm rewrite* +M: ##sub-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ sub-imm>add-imm ] @@ -261,7 +257,7 @@ M: ##sub-imm rewrite* : strength-reduce-mul? ( insn -- ? ) src2>> power-of-2? ; -M: ##mul-imm rewrite* +M: ##mul-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] } @@ -269,40 +265,40 @@ M: ##mul-imm rewrite* [ drop f ] } cond ; -M: ##and-imm rewrite* +M: ##and-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##and-imm reassociate ] } [ drop f ] } cond ; -M: ##or-imm rewrite* +M: ##or-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##or-imm reassociate ] } [ drop f ] } cond ; -M: ##xor-imm rewrite* +M: ##xor-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##xor-imm reassociate ] } [ drop f ] } cond ; -M: ##shl-imm rewrite* +M: ##shl-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ drop f ] } cond ; -M: ##shr-imm rewrite* +M: ##shr-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ drop f ] } cond ; -M: ##sar-imm rewrite* +M: ##sar-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ drop f ] @@ -327,7 +323,7 @@ M: ##sar-imm rewrite* [ 2drop f ] } cond ; inline -M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ; +M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ; : subtraction-identity? ( insn -- ? ) [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ; @@ -335,22 +331,22 @@ M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ; : rewrite-subtraction-identity ( insn -- insn' ) dst>> 0 \ ##load-immediate new-insn ; -M: ##sub rewrite* +M: ##sub rewrite { { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] } [ \ ##sub-imm rewrite-arithmetic ] } cond ; -M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ; +M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ; -M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ; +M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ; -M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ; +M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ; -M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ; +M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ; -M: ##shl rewrite* \ ##shl-imm rewrite-arithmetic ; +M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ; -M: ##shr rewrite* \ ##shr-imm rewrite-arithmetic ; +M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ; -M: ##sar rewrite* \ ##sar-imm rewrite-arithmetic ; +M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ; diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor index 5934643acc..3e1f6e393b 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -120,14 +120,12 @@ M: binary-expr simplify* M: expr simplify* drop f ; -: simplify ( expr -- vn ) +: simplify ( expr -- simplified? vn ) dup simplify* { - { [ dup not ] [ drop expr>vn ] } - { [ dup expr? ] [ expr>vn nip ] } - { [ dup integer? ] [ nip ] } - } cond ; + { [ dup not ] [ drop expr>vn f ] } + { [ dup expr? ] [ expr>vn nip t ] } + { [ dup integer? ] [ nip t ] } + } cond swap ; -GENERIC: number-values ( insn -- ) - -M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ; -M: insn number-values drop ; +: number-values ( insn -- simplified? ) + [ >expr simplify ] [ dst>> set-vn ] bi ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index 0c9616b4e5..0688d81109 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs biassocs classes kernel math accessors -sorting sets sequences fry +USING: namespaces assocs kernel accessors +sorting sets sequences compiler.cfg compiler.cfg.rpo -compiler.cfg.renaming +compiler.cfg.instructions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions compiler.cfg.value-numbering.simplify @@ -12,20 +12,27 @@ compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering ! Local value numbering. Predecessors must be recomputed after this -: vreg>vreg-mapping ( -- assoc ) - vregs>vns get [ keys ] keep - '[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ; +: >copy ( insn -- ##copy ) + dst>> dup vreg>vn vn>vreg \ ##copy new-insn ; -: rename-uses ( insns -- ) - vreg>vreg-mapping renamings [ - [ rename-insn-uses ] each - ] with-variable ; +: rewrite-loop ( insn -- insn' ) + dup rewrite [ rewrite-loop ] [ ] ?if ; + +GENERIC: process-instruction ( insn -- insn' ) + +M: ##flushable process-instruction + dup rewrite + [ process-instruction ] + [ dup number-values [ >copy ] when ] ?if ; + +M: insn process-instruction + dup rewrite + [ process-instruction ] [ ] ?if ; : value-numbering-step ( insns -- insns' ) init-value-graph init-expressions - [ rewrite ] map - dup rename-uses ; + [ process-instruction ] map ; : value-numbering ( cfg -- cfg' ) [ value-numbering-step ] local-optimization cfg-changed ; From 7068de6cd30322fd77d4e39454c30c69b2421cef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 05:30:46 -0500 Subject: [PATCH 27/81] compiler.cfg.copy-prop: Global copy propagation --- basis/compiler/cfg/copy-prop/copy-prop.factor | 28 +++++++++++++++++-- basis/compiler/cfg/optimizer/optimizer.factor | 8 ++++-- basis/compiler/cfg/renaming/renaming.factor | 4 +++ 3 files changed, 35 insertions(+), 5 deletions(-) diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index d526ea9c1d..b13aa5d75b 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -1,8 +1,10 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces assocs accessors ; +USING: kernel namespaces assocs accessors sequences +compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ; IN: compiler.cfg.copy-prop +! The first three definitions are also used in compiler.cfg.alias-analysis. SYMBOL: copies : resolve ( vreg -- vreg ) @@ -10,3 +12,25 @@ SYMBOL: copies : record-copy ( insn -- ) [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline + +: collect-copies ( cfg -- ) + H{ } clone copies set + [ + instructions>> + [ dup ##copy? [ record-copy ] [ drop ] if ] each + ] each-basic-block ; + +: rename-copies ( cfg -- ) + copies get dup assoc-empty? [ 2drop ] [ + renamings set + [ + instructions>> + [ dup ##copy? [ drop f ] [ rename-insn-uses t ] if ] filter-here + ] each-basic-block + ] if ; + +: copy-propagation ( cfg -- cfg' ) + [ collect-copies ] + [ rename-copies ] + [ ] + tri ; diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index e4ad290097..ede2a9382c 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -2,18 +2,19 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors combinators namespaces compiler.cfg.tco -compiler.cfg.predecessors compiler.cfg.useless-conditionals -compiler.cfg.ssa compiler.cfg.branch-splitting compiler.cfg.block-joining +compiler.cfg.ssa compiler.cfg.alias-analysis compiler.cfg.value-numbering +compiler.cfg.copy-prop compiler.cfg.dce compiler.cfg.write-barrier -compiler.cfg.rpo compiler.cfg.phi-elimination compiler.cfg.empty-blocks +compiler.cfg.predecessors +compiler.cfg.rpo compiler.cfg.checker ; IN: compiler.cfg.optimizer @@ -38,6 +39,7 @@ SYMBOL: check-optimizer? alias-analysis value-numbering compute-predecessors + copy-propagation eliminate-dead-code eliminate-write-barriers eliminate-phis diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor index a2204fb36e..eb8538256a 100644 --- a/basis/compiler/cfg/renaming/renaming.factor +++ b/basis/compiler/cfg/renaming/renaming.factor @@ -102,6 +102,10 @@ M: ##fixnum-overflow rename-insn-uses [ rename-value ] change-src2 drop ; +M: ##phi rename-insn-uses + [ [ rename-value ] assoc-map ] change-inputs + drop ; + M: insn rename-insn-uses drop ; : fresh-vreg ( vreg -- vreg' ) From 13c3fdcb5c0bb663246e17ac18a62f279d4b624d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 06:08:07 -0500 Subject: [PATCH 28/81] compiler.cfg: Fixing test failures --- .../value-numbering/simplify/simplify.factor | 14 +++--- .../value-numbering-tests.factor | 47 +++++++------------ .../value-numbering/value-numbering.factor | 7 +-- .../write-barrier/write-barrier-tests.factor | 40 +++++++--------- 4 files changed, 45 insertions(+), 63 deletions(-) diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor index 3e1f6e393b..6bd84021b3 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -120,12 +120,12 @@ M: binary-expr simplify* M: expr simplify* drop f ; -: simplify ( expr -- simplified? vn ) +: simplify ( expr -- vn ) dup simplify* { - { [ dup not ] [ drop expr>vn f ] } - { [ dup expr? ] [ expr>vn nip t ] } - { [ dup integer? ] [ nip t ] } - } cond swap ; + { [ dup not ] [ drop expr>vn ] } + { [ dup expr? ] [ expr>vn nip ] } + { [ dup integer? ] [ nip ] } + } cond ; -: number-values ( insn -- simplified? ) - [ >expr simplify ] [ dst>> set-vn ] bi ; +: number-values ( insn -- ) + [ >expr simplify ] [ dst>> ] bi set-vn ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 9063947ae1..60d06fcde4 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -35,9 +35,9 @@ compiler.cfg assocs vectors arrays layouts namespaces ; [ { T{ ##load-reference f V int-regs 0 0.0 } - T{ ##load-reference f V int-regs 1 0.0 } + T{ ##copy f V int-regs 1 V int-regs 0 } T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 0 D 1 } + T{ ##replace f V int-regs 1 D 1 } } ] [ { @@ -51,9 +51,9 @@ compiler.cfg assocs vectors arrays layouts namespaces ; [ { T{ ##load-reference f V int-regs 0 t } - T{ ##load-reference f V int-regs 1 t } + T{ ##copy f V int-regs 1 V int-regs 0 } T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 0 D 1 } + T{ ##replace f V int-regs 1 D 1 } } ] [ { @@ -64,29 +64,14 @@ compiler.cfg assocs vectors arrays layouts namespaces ; } value-numbering-step ] unit-test -! Copy propagation -[ - { - T{ ##peek f V int-regs 45 D 1 } - T{ ##copy f V int-regs 48 V int-regs 45 } - T{ ##compare-imm-branch f V int-regs 45 7 cc/= } - } -] [ - { - T{ ##peek f V int-regs 45 D 1 } - T{ ##copy f V int-regs 48 V int-regs 45 } - T{ ##compare-imm-branch f V int-regs 48 7 cc/= } - } value-numbering-step -] unit-test - ! Compare propagation [ { T{ ##load-reference f V int-regs 1 + } T{ ##peek f V int-regs 2 D 0 } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } - T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } - T{ ##replace f V int-regs 4 D 0 } + T{ ##copy f V int-regs 6 V int-regs 4 } + T{ ##replace f V int-regs 6 D 0 } } ] [ { @@ -612,8 +597,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##peek f V int-regs 1 D 1 } T{ ##load-immediate f V int-regs 2 0 } - T{ ##add-imm f V int-regs 3 V int-regs 0 0 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -630,8 +615,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##peek f V int-regs 1 D 1 } T{ ##load-immediate f V int-regs 2 0 } - T{ ##add-imm f V int-regs 3 V int-regs 0 0 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -648,8 +633,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##peek f V int-regs 1 D 1 } T{ ##load-immediate f V int-regs 2 0 } - T{ ##or-imm f V int-regs 3 V int-regs 0 0 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -666,8 +651,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; T{ ##peek f V int-regs 0 D 0 } T{ ##peek f V int-regs 1 D 1 } T{ ##load-immediate f V int-regs 2 0 } - T{ ##xor-imm f V int-regs 3 V int-regs 0 0 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -683,8 +668,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; { T{ ##peek f V int-regs 0 D 0 } T{ ##load-immediate f V int-regs 1 1 } - T{ ##shl-imm f V int-regs 2 V int-regs 0 0 } - T{ ##replace f V int-regs 0 D 0 } + T{ ##copy f V int-regs 2 V int-regs 0 } + T{ ##replace f V int-regs 2 D 0 } } ] [ { diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index 0688d81109..a249f71c02 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -12,8 +12,9 @@ compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering ! Local value numbering. Predecessors must be recomputed after this -: >copy ( insn -- ##copy ) - dst>> dup vreg>vn vn>vreg \ ##copy new-insn ; +: >copy ( insn -- insn/##copy ) + dup dst>> dup vreg>vn vn>vreg + 2dup eq? [ 2drop ] [ \ ##copy new-insn nip ] if ; : rewrite-loop ( insn -- insn' ) dup rewrite [ rewrite-loop ] [ ] ?if ; @@ -23,7 +24,7 @@ GENERIC: process-instruction ( insn -- insn' ) M: ##flushable process-instruction dup rewrite [ process-instruction ] - [ dup number-values [ >copy ] when ] ?if ; + [ dup number-values >copy ] ?if ; M: insn process-instruction dup rewrite diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor index c1a667c004..14197bc3f7 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -1,42 +1,43 @@ USING: compiler.cfg.write-barrier compiler.cfg.instructions compiler.cfg.registers compiler.cfg.debugger cpu.architecture -arrays tools.test vectors compiler.cfg kernel accessors ; +arrays tools.test vectors compiler.cfg kernel accessors +compiler.cfg.utilities ; IN: compiler.cfg.write-barrier.tests : test-write-barrier ( insns -- insns ) - write-barriers-step ; + dup write-barriers-step instructions>> ; [ - { + V{ T{ ##peek f V int-regs 4 D 0 f } - T{ ##copy f V int-regs 6 V int-regs 4 f } T{ ##allot f V int-regs 7 24 array V int-regs 8 f } T{ ##load-immediate f V int-regs 9 8 f } T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f } - T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f } + T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 f } T{ ##replace f V int-regs 7 D 0 f } + T{ ##branch } } ] [ { T{ ##peek f V int-regs 4 D 0 } - T{ ##copy f V int-regs 6 V int-regs 4 } T{ ##allot f V int-regs 7 24 array V int-regs 8 } T{ ##load-immediate f V int-regs 9 8 } T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 } T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 } - T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 } + T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 } T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 } T{ ##replace f V int-regs 7 D 0 } } test-write-barrier ] unit-test [ - { + V{ T{ ##load-immediate f V int-regs 4 24 } T{ ##peek f V int-regs 5 D -1 } T{ ##peek f V int-regs 6 D -2 } T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 } T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 } + T{ ##branch } } ] [ { @@ -49,28 +50,23 @@ IN: compiler.cfg.write-barrier.tests ] unit-test [ - { + V{ T{ ##peek f V int-regs 19 D -3 } T{ ##peek f V int-regs 22 D -2 } - T{ ##copy f V int-regs 23 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 } - T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 } - T{ ##copy f V int-regs 26 V int-regs 19 } + T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 } + T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 } T{ ##peek f V int-regs 28 D -1 } - T{ ##copy f V int-regs 29 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } + T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 } + T{ ##branch } } ] [ { T{ ##peek f V int-regs 19 D -3 } T{ ##peek f V int-regs 22 D -2 } - T{ ##copy f V int-regs 23 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 } - T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 } - T{ ##copy f V int-regs 26 V int-regs 19 } + T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 } + T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 } T{ ##peek f V int-regs 28 D -1 } - T{ ##copy f V int-regs 29 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } - T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 } + T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 } + T{ ##write-barrier f V int-regs 19 V int-regs 30 V int-regs 3 } } test-write-barrier ] unit-test From 4624af75f4047644423049ec60e5d02f0d438114 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 16:45:31 -0500 Subject: [PATCH 29/81] compiler.cfg.phi-elimination: move some utilities from compiler.cfg.utilities here since that's the only place they get used --- .../cfg/phi-elimination/phi-elimination.factor | 14 ++++++++++++++ basis/compiler/cfg/utilities/utilities.factor | 14 -------------- 2 files changed, 14 insertions(+), 14 deletions(-) diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor index 7e73f0b854..38e82176ca 100644 --- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor +++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor @@ -6,6 +6,20 @@ compiler.cfg.utilities compiler.cfg.hats make locals ; IN: compiler.cfg.phi-elimination +! assoc mapping predecessors to sequences +SYMBOL: added-instructions + +: add-instructions ( predecessor quot -- ) + [ + added-instructions get + [ drop V{ } clone ] cache + building + ] dip with-variable ; inline + +: insert-basic-blocks ( bb -- ) + [ added-instructions get ] dip + '[ [ _ ] dip insert-basic-block ] assoc-each ; + : insert-copy ( predecessor input output -- ) '[ _ _ swap ##copy ] add-instructions ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index ad3ee9c57b..4b0468b911 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -48,16 +48,6 @@ SYMBOL: visited : skip-empty-blocks ( bb -- bb' ) H{ } clone visited [ (skip-empty-blocks) ] with-variable ; -! assoc mapping predecessors to sequences -SYMBOL: added-instructions - -: add-instructions ( predecessor quot -- ) - [ - added-instructions get - [ drop V{ } clone ] cache - building - ] dip with-variable ; inline - :: insert-basic-block ( from to bb -- ) bb from 1vector >>predecessors drop bb to 1vector >>successors drop @@ -69,7 +59,3 @@ SYMBOL: added-instructions swap >vector \ ##branch new-insn over push >>instructions ; - -: insert-basic-blocks ( bb -- ) - [ added-instructions get ] dip - '[ [ _ ] dip insert-basic-block ] assoc-each ; From 2fb0198d487749d509dbb67fe3de4686119f1add Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 19:46:33 -0500 Subject: [PATCH 30/81] compiler.cfg.parallel-copy: forgot to add this --- .../parallel-copy/parallel-copy-tests.factor | 63 +++++++++++++++++++ .../parallel-copy/parallel-copy.alt.factor | 57 +++++++++++++++++ .../cfg/parallel-copy/parallel-copy.factor | 46 ++++++++++++++ 3 files changed, 166 insertions(+) create mode 100644 basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor create mode 100644 basis/compiler/cfg/parallel-copy/parallel-copy.alt.factor create mode 100644 basis/compiler/cfg/parallel-copy/parallel-copy.factor diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor b/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor new file mode 100644 index 0000000000..0234c2eae7 --- /dev/null +++ b/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor @@ -0,0 +1,63 @@ +USING: compiler.cfg.parallel-copy tools.test make arrays +compiler.cfg.registers namespaces compiler.cfg.instructions +cpu.architecture ; +IN: compiler.cfg.parallel-copy.tests + +SYMBOL: temp + +: test-parallel-copy ( mapping -- seq ) + 3 vreg-counter set-global + [ parallel-copy ] { } make ; + +[ + { + T{ ##copy f V int-regs 3 V int-regs 2 } + T{ ##copy f V int-regs 2 V int-regs 1 } + T{ ##copy f V int-regs 1 V int-regs 3 } + } +] [ + H{ + { V int-regs 1 V int-regs 2 } + { V int-regs 2 V int-regs 1 } + } test-parallel-copy +] unit-test + +[ + { + T{ ##copy f V int-regs 1 V int-regs 2 } + T{ ##copy f V int-regs 3 V int-regs 4 } + } +] [ + H{ + { V int-regs 1 V int-regs 2 } + { V int-regs 3 V int-regs 4 } + } test-parallel-copy +] unit-test + +[ + { + T{ ##copy f V int-regs 1 V int-regs 3 } + T{ ##copy f V int-regs 2 V int-regs 1 } + } +] [ + H{ + { V int-regs 1 V int-regs 3 } + { V int-regs 2 V int-regs 3 } + } test-parallel-copy +] unit-test + +[ + { + T{ ##copy f V int-regs 4 V int-regs 3 } + T{ ##copy f V int-regs 3 V int-regs 2 } + T{ ##copy f V int-regs 2 V int-regs 1 } + T{ ##copy f V int-regs 1 V int-regs 4 } + } +] [ + { + { V int-regs 2 V int-regs 1 } + { V int-regs 3 V int-regs 2 } + { V int-regs 1 V int-regs 3 } + { V int-regs 4 V int-regs 3 } + } test-parallel-copy +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy.alt.factor b/basis/compiler/cfg/parallel-copy/parallel-copy.alt.factor new file mode 100644 index 0000000000..534cef36d2 --- /dev/null +++ b/basis/compiler/cfg/parallel-copy/parallel-copy.alt.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs compiler.cfg.hats compiler.cfg.instructions +deques dlists fry kernel locals namespaces sequences +hashtables ; +IN: compiler.cfg.parallel-copy + +! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency +! http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf, +! Algorithm 1 + + to-do set + ready set + [ preds set ] + [ [ nip dup ] H{ } assoc-map-as locs set ] + [ keys [ init-to-do ] [ init-ready ] bi ] tri ; + +:: process-ready ( b quot -- ) + b preds get at :> a + a locs get at :> c + b c quot call + b a locs get set-at + a c = a preds get at and [ a ready get push-front ] when ; inline + +:: process-to-do ( b quot -- ) + b preds get at locs get at b = [ + temp get b quot call + temp get b locs get set-at + b ready get push-front + ] unless ; inline + +PRIVATE> + +:: parallel-mapping ( mapping temp quot -- ) + [ + mapping temp init + to-do get [ + ready get [ + quot process-ready + ] slurp-deque + quot process-to-do + ] slurp-deque + ] with-scope ; + +: parallel-copy ( mapping -- ) i [ ##copy ] parallel-mapping ; \ No newline at end of file diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy.factor b/basis/compiler/cfg/parallel-copy/parallel-copy.factor new file mode 100644 index 0000000000..ff309c45ad --- /dev/null +++ b/basis/compiler/cfg/parallel-copy/parallel-copy.factor @@ -0,0 +1,46 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs compiler.cfg.hats compiler.cfg.instructions +deques dlists fry kernel locals namespaces sequences +sets hashtables ; +IN: compiler.cfg.parallel-copy + +SYMBOLS: mapping dependency-graph work-list ; + +: build-dependency-graph ( mapping -- deps ) + H{ } clone [ '[ _ conjoin-at ] assoc-each ] keep ; + +: build-work-list ( mapping graph -- work-list ) + [ keys ] dip '[ _ key? not ] filter [ push-all-front ] keep ; + +: init ( mapping -- work-list ) + dup build-dependency-graph + [ [ >hashtable mapping set ] [ dependency-graph set ] bi* ] + [ build-work-list dup work-list set ] + 2bi ; + +:: retire-copy ( dst src -- ) + dst mapping get delete-at + src dependency-graph get at :> deps + dst deps delete-at + deps assoc-empty? [ + src mapping get key? [ + src work-list get push-front + ] when + ] when ; + +: perform-copy ( dst -- ) + dup mapping get at + [ ##copy ] [ retire-copy ] 2bi ; + +: break-cycle ( dst src -- dst src' ) + [ i dup ] dip ##copy ; + +: break-cycles ( mapping -- ) + >alist [ break-cycle ] { } assoc-map-as [ ##copy ] assoc-each ; + +: parallel-copy ( mapping -- ) + [ + init [ perform-copy ] slurp-deque + mapping get dup assoc-empty? [ drop ] [ break-cycles ] if + ] with-scope ; \ No newline at end of file From 053de0af40324a5487913ac8830ddbee6bf333d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Jul 2009 19:56:21 -0500 Subject: [PATCH 31/81] compiler.cfg.copy-prop: work in progress --- basis/compiler/cfg/copy-prop/copy-prop.factor | 24 ++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index b13aa5d75b..63f299d2a3 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -10,25 +10,43 @@ SYMBOL: copies : resolve ( vreg -- vreg ) [ copies get at ] keep or ; -: record-copy ( insn -- ) +: record-copy ( ##copy -- ) [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline +> values [ resolve ] map all-equal? [ "BLAH!" print ] when ; + +M: insn visit-insn drop ; + : collect-copies ( cfg -- ) H{ } clone copies set [ instructions>> - [ dup ##copy? [ record-copy ] [ drop ] if ] each + [ visit-insn ] each ] each-basic-block ; +GENERIC: update-insn ( insn -- keep? ) + +M: ##copy update-insn drop f ; + +M: insn update-insn rename-insn-uses t ; + : rename-copies ( cfg -- ) copies get dup assoc-empty? [ 2drop ] [ renamings set [ instructions>> - [ dup ##copy? [ drop f ] [ rename-insn-uses t ] if ] filter-here + [ update-insn ] filter-here ] each-basic-block ] if ; +PRIVATE> + : copy-propagation ( cfg -- cfg' ) [ collect-copies ] [ rename-copies ] From 2137c9cc792f31e383833e265cafd5d162b8b5d1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Jul 2009 21:10:05 -0500 Subject: [PATCH 32/81] compiler.cfg.dominance: add pre order and max pre order numbers; use them to implement dominates? check --- .../cfg/dominance/dominance-tests.factor | 9 +++++- basis/compiler/cfg/dominance/dominance.factor | 28 ++++++++++++++++++- 2 files changed, 35 insertions(+), 2 deletions(-) diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor index e884e32d78..0d4513c848 100644 --- a/basis/compiler/cfg/dominance/dominance-tests.factor +++ b/basis/compiler/cfg/dominance/dominance-tests.factor @@ -6,7 +6,8 @@ compiler.cfg.predecessors ; : test-dominance ( -- ) cfg new 0 get >>entry compute-predecessors - compute-dominance ; + dup compute-dominance + compute-dfs ; ! Example with no back edges V{ } 0 test-bb @@ -38,6 +39,12 @@ V{ } 5 test-bb [ { } ] [ 0 get dom-frontier ] unit-test [ { } ] [ 4 get dom-frontier ] unit-test +[ t ] [ 0 get 3 get dominates? ] unit-test +[ f ] [ 3 get 4 get dominates? ] unit-test +[ f ] [ 1 get 4 get dominates? ] unit-test +[ t ] [ 4 get 5 get dominates? ] unit-test +[ f ] [ 1 get 5 get dominates? ] unit-test + ! Example from the paper V{ } 0 test-bb V{ } 1 test-bb diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor index 73d9f58eec..6a73b349de 100644 --- a/basis/compiler/cfg/dominance/dominance.factor +++ b/basis/compiler/cfg/dominance/dominance.factor @@ -112,4 +112,30 @@ PRIVATE> [ add-to-work-list ] each work-list get [ iterated-dom-frontier-step ] slurp-deque visited get keys - ] with-scope ; \ No newline at end of file + ] with-scope ; + + + +: compute-dfs ( cfg -- ) + H{ } clone preorder set + H{ } clone maxpreorder set + [ 0 ] dip entry>> (compute-dfs) drop ; + +: dominates? ( bb1 bb2 -- ? ) + ! Requires DFS to be computed + swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ; \ No newline at end of file From 1319d8e54997eeb5f4ceb522684acbc023024a28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Jul 2009 21:10:14 -0500 Subject: [PATCH 33/81] compiler.cfg.def-use: build def-use chains --- basis/compiler/cfg/def-use/def-use.factor | 57 ++++++++++++++++++++++- basis/compiler/cfg/ssa/ssa.factor | 15 +----- 2 files changed, 56 insertions(+), 16 deletions(-) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 0f488de559..d4d6ce8289 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel assocs sequences -sets compiler.cfg.instructions ; +USING: accessors arrays kernel assocs sequences namespaces fry +sets compiler.cfg.rpo compiler.cfg.instructions ; IN: compiler.cfg.def-use GENERIC: defs-vregs ( insn -- seq ) @@ -49,3 +49,56 @@ M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ; M: _compare-imm-branch uses-vregs src1>> 1array ; M: _dispatch uses-vregs src>> 1array ; M: insn uses-vregs drop f ; + +! Computing def-use chains. We don't assume a program is in SSA form, +! since SSA construction itself needs def-use information. defs-1 +! is only useful if the program is SSA. +SYMBOLS: defs defs-1 insns uses ; + +: def-of ( vreg -- node ) defs-1 get at ; +: defs-of ( vreg -- nodes ) defs get at ; +: uses-of ( vreg -- nodes ) uses get at ; +: insn-of ( vreg -- insn ) insns get at ; + +> [ + @ [ + _ conjoin-at + ] with each + ] with each + ] each-basic-block + ] keep + [ keys ] assoc-map ; inline + +PRIVATE> + +: compute-defs ( cfg -- ) + [ defs-vregs ] (compute-def-use) + [ defs set ] [ [ first ] assoc-map defs-1 set ] bi ; + +: compute-uses ( cfg -- ) + [ uses-vregs ] (compute-def-use) uses set ; + +: compute-insns ( cfg -- ) + H{ } clone [ + '[ + instructions>> [ + dup defs-vregs [ + _ set-at + ] with each + ] each + ] each-basic-block + ] keep insns set ; + +: compute-def-use ( cfg -- ) + [ compute-defs ] [ compute-uses ] [ compute-insns ] tri ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/ssa.factor b/basis/compiler/cfg/ssa/ssa.factor index 2e76ba35a1..97b8db8104 100644 --- a/basis/compiler/cfg/ssa/ssa.factor +++ b/basis/compiler/cfg/ssa/ssa.factor @@ -23,22 +23,9 @@ IN: compiler.cfg.ssa > [ - defs-vregs [ - _ conjoin-at - ] with each - ] with each - ] each-basic-block ; - : insert-phi-node-later ( vreg bb -- ) 2dup live-in key? [ [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep @@ -46,7 +33,7 @@ SYMBOL: inserting-phi-nodes ] [ 2drop ] if ; : compute-phi-nodes-for ( vreg bbs -- ) - keys dup length 2 >= [ + dup length 2 >= [ iterated-dom-frontier [ insert-phi-node-later ] with each From fc4114072005dc98da879d78ec0e8da385093875 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Jul 2009 21:10:33 -0500 Subject: [PATCH 34/81] compiler.cfg.utilities: move value-info utilities to compiler.tree.propagation.info --- basis/compiler/cfg/utilities/utilities.factor | 21 ++++++------------- .../tree/propagation/info/info.factor | 15 +++++++++++++ 2 files changed, 21 insertions(+), 15 deletions(-) diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 4b0468b911..2be805bd20 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -5,21 +5,6 @@ compiler.cfg compiler.cfg.instructions cpu.architecture kernel layouts locals make math namespaces sequences sets vectors fry ; IN: compiler.cfg.utilities -: value-info-small-fixnum? ( value-info -- ? ) - literal>> { - { [ dup fixnum? ] [ tag-fixnum small-enough? ] } - [ drop f ] - } cond ; - -: value-info-small-tagged? ( value-info -- ? ) - dup literal?>> [ - literal>> { - { [ dup fixnum? ] [ tag-fixnum small-enough? ] } - { [ dup not ] [ drop t ] } - [ drop f ] - } cond - ] [ drop f ] if ; - PREDICATE: kill-block < basic-block instructions>> { [ length 2 = ] @@ -59,3 +44,9 @@ SYMBOL: visited swap >vector \ ##branch new-insn over push >>instructions ; + +: has-phis? ( bb -- ? ) + instructions>> first ##phi? ; + +: if-has-phis ( bb quot: ( bb -- ) -- ) + [ dup has-phis? ] dip [ drop ] if ; inline diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 816368466f..f45fc2e18a 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -306,3 +306,18 @@ SYMBOL: value-infos dup in-d>> last node-value-info literal>> first immutable-tuple-class? ] [ drop f ] if ; + +: value-info-small-fixnum? ( value-info -- ? ) + literal>> { + { [ dup fixnum? ] [ tag-fixnum small-enough? ] } + [ drop f ] + } cond ; + +: value-info-small-tagged? ( value-info -- ? ) + dup literal?>> [ + literal>> { + { [ dup fixnum? ] [ tag-fixnum small-enough? ] } + { [ dup not ] [ drop t ] } + [ drop f ] + } cond + ] [ drop f ] if ; From e9935b6aadfb1b37f0e3b1e9a69eee11ef1a0b96 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Jul 2009 21:11:02 -0500 Subject: [PATCH 35/81] compiler.cfg.copy-prop: remove ##phi nodes where all inputs are copy-equivalent --- basis/compiler/cfg/copy-prop/copy-prop.factor | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index 63f299d2a3..1f2c75f28a 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces assocs accessors sequences +USING: kernel namespaces assocs accessors sequences grouping compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ; IN: compiler.cfg.copy-prop @@ -8,10 +8,13 @@ IN: compiler.cfg.copy-prop SYMBOL: copies : resolve ( vreg -- vreg ) - [ copies get at ] keep or ; + copies get ?at drop ; + +: (record-copy) ( dst src -- ) + swap copies get set-at ; inline : record-copy ( ##copy -- ) - [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline + [ dst>> ] [ src>> resolve ] bi (record-copy) ; inline > values [ resolve ] map all-equal? [ "BLAH!" print ] when ; +M: ##phi visit-insn + [ dst>> ] [ inputs>> values [ resolve ] map ] bi + dup all-equal? [ first (record-copy) ] [ 2drop ] if ; M: insn visit-insn drop ; @@ -34,6 +39,9 @@ GENERIC: update-insn ( insn -- keep? ) M: ##copy update-insn drop f ; +M: ##phi update-insn + dup dst>> copies get key? [ drop f ] [ call-next-method ] if ; + M: insn update-insn rename-insn-uses t ; : rename-copies ( cfg -- ) From a5e5510615956584df083f0321df0d2bf4b49e8e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Jul 2009 21:11:26 -0500 Subject: [PATCH 36/81] compiler.cfg.coalescing: work in progress --- .../compiler/cfg/coalescing/coalescing.factor | 42 +++++ .../cfg/coalescing/copies/copies.factor | 8 + .../cfg/coalescing/forest/forest-tests.factor | 87 ++++++++++ .../cfg/coalescing/forest/forest.factor | 39 +++++ .../interference/interference.factor | 56 ++++++ .../process-blocks/process-blocks.factor | 160 ++++++++++++++++++ .../cfg/coalescing/state/state.factor | 15 ++ 7 files changed, 407 insertions(+) create mode 100644 basis/compiler/cfg/coalescing/coalescing.factor create mode 100644 basis/compiler/cfg/coalescing/copies/copies.factor create mode 100644 basis/compiler/cfg/coalescing/forest/forest-tests.factor create mode 100644 basis/compiler/cfg/coalescing/forest/forest.factor create mode 100644 basis/compiler/cfg/coalescing/interference/interference.factor create mode 100644 basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor create mode 100644 basis/compiler/cfg/coalescing/state/state.factor diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor new file mode 100644 index 0000000000..5a09b59749 --- /dev/null +++ b/basis/compiler/cfg/coalescing/coalescing.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel locals math math.order +sequences +compiler.cfg.rpo +compiler.cfg.instructions +compiler.cfg.dominance +compiler.cfg.coalescing.state +compiler.cfg.coalescing.forest +compiler.cfg.coalescing.process-blocks ; +IN: compiler.cfg.coalescing + +! Fast Copy Coalescing and Live-Range Identification +! http://www.cs.ucsd.edu/classes/sp02/cse231/kenpldi.pdf + +! Dominance, liveness and def-use need to be computed + +: process-blocks ( cfg -- ) + [ [ process-block ] if-has-phis ] each-basic-block ; + +: schedule-copies ( bb -- ) drop ; + +: break-interferences ( -- ) ; + +: insert-copies ( cfg -- ) drop ; + +: perform-renaming ( cfg -- ) drop ; + +: remove-phis-from-block ( bb -- ) + instructions>> [ ##phi? not ] filter-here ; + +: remove-phis ( cfg -- ) + [ [ remove-phis-from-block ] if-has-phis ] each-basic-block ; + +: coalesce ( cfg -- cfg' ) + init-coalescing + dup compute-dfs + dup process-blocks + break-interferences + dup insert-copies + dup perform-renaming + dup remove-phis ; \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/coalescing/copies/copies.factor new file mode 100644 index 0000000000..c0a3ed8923 --- /dev/null +++ b/basis/compiler/cfg/coalescing/copies/copies.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: ; +IN: compiler.cfg.coalescing.copies + +: schedule-copies ( bb -- ) drop ; + +: insert-copies ( cfg -- ) drop ; diff --git a/basis/compiler/cfg/coalescing/forest/forest-tests.factor b/basis/compiler/cfg/coalescing/forest/forest-tests.factor new file mode 100644 index 0000000000..3cbcbb186a --- /dev/null +++ b/basis/compiler/cfg/coalescing/forest/forest-tests.factor @@ -0,0 +1,87 @@ +USING: accessors compiler.cfg compiler.cfg.coalescing.forest +compiler.cfg.debugger compiler.cfg.dominance compiler.cfg.instructions +compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.def-use +cpu.architecture kernel namespaces sequences tools.test vectors sorting +math.order ; +IN: compiler.cfg.coalescing.forest.tests + +V{ T{ ##peek f V int-regs 0 D 0 } } clone 0 test-bb +V{ T{ ##peek f V int-regs 1 D 0 } } clone 1 test-bb +V{ T{ ##peek f V int-regs 2 D 0 } } clone 2 test-bb +V{ T{ ##peek f V int-regs 3 D 0 } } clone 3 test-bb +V{ T{ ##peek f V int-regs 4 D 0 } } clone 4 test-bb +V{ T{ ##peek f V int-regs 5 D 0 } } clone 5 test-bb +V{ T{ ##peek f V int-regs 6 D 0 } } clone 6 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop +2 get 3 get 4 get V{ } 2sequence >>successors drop +3 get 5 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop +1 get 6 get 1vector >>successors drop +5 get 6 get 1vector >>successors drop + +: clean-up-forest ( forest -- forest' ) + [ [ vreg>> n>> ] compare ] sort + [ + [ clean-up-forest ] change-children + [ number>> ] change-bb + ] V{ } map-as ; + +: test-dom-forest ( vregs -- forest ) + cfg new 0 get >>entry + compute-predecessors + dup compute-dominance + dup compute-def-use + compute-dfs + compute-dom-forest + clean-up-forest ; + +[ V{ } ] [ { } test-dom-forest ] unit-test + +[ V{ T{ dom-forest-node f V int-regs 0 0 V{ } } } ] +[ { V int-regs 0 } test-dom-forest ] +unit-test + +[ + V{ + T{ dom-forest-node + f + V int-regs 0 + 0 + V{ T{ dom-forest-node f V int-regs 1 1 V{ } } } + } + } +] +[ { V int-regs 0 V int-regs 1 } test-dom-forest ] +unit-test + +[ + V{ + T{ dom-forest-node + f + V int-regs 1 + 1 + V{ } + } + T{ dom-forest-node + f + V int-regs 2 + 2 + V{ + T{ dom-forest-node f V int-regs 3 3 V{ } } + T{ dom-forest-node f V int-regs 4 4 V{ } } + T{ dom-forest-node f V int-regs 5 5 V{ } } + } + } + T{ dom-forest-node + f + V int-regs 6 + 6 + V{ } + } + } +] +[ + { V int-regs 1 V int-regs 6 V int-regs 2 V int-regs 3 V int-regs 4 V int-regs 5 } + test-dom-forest +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/forest/forest.factor b/basis/compiler/cfg/coalescing/forest/forest.factor new file mode 100644 index 0000000000..f1f8334975 --- /dev/null +++ b/basis/compiler/cfg/coalescing/forest/forest.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel math math.order +namespaces sequences sorting vectors compiler.cfg.def-use +compiler.cfg.dominance ; +IN: compiler.cfg.coalescing.forest + +TUPLE: dom-forest-node vreg bb children ; + +assoc + [ [ second pre-of ] compare ] sort ; + +: ( vreg bb parent -- node ) + [ V{ } clone dom-forest-node boa dup ] dip children>> push ; + +: ( -- node ) + f f V{ } clone dom-forest-node boa ; + +: find-parent ( pre stack -- parent ) + 2dup last vreg>> def-of maxpre-of > [ + dup pop* find-parent + ] [ nip last ] if ; + +: (compute-dom-forest) ( vreg bb stack -- ) + [ dup pre-of ] dip [ find-parent ] keep push ; + +PRIVATE> + +: compute-dom-forest ( vregs -- forest ) + ! compute-dfs must be called on the CFG first + [ + 1vector + [ sort-vregs-by-bb ] dip + '[ _ (compute-dom-forest) ] assoc-each + ] keep children>> ; diff --git a/basis/compiler/cfg/coalescing/interference/interference.factor b/basis/compiler/cfg/coalescing/interference/interference.factor new file mode 100644 index 0000000000..36dea6f0a0 --- /dev/null +++ b/basis/compiler/cfg/coalescing/interference/interference.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators combinators.short-circuit +kernel math namespaces sequences compiler.cfg.def-use +compiler.cfg.liveness ; +IN: compiler.cfg.coalescing.interference + +! Local interference testing. Requires live-out information +> [ + [ swap defs-vregs [ def-index get set-at ] with each ] + [ swap uses-vregs [ kill-index get set-at ] with each ] + 2bi + ] each-index + ] + [ live-out keys [ [ 1/0. ] dip kill-index get set-at ] each ] + bi ; + +: kill-after-def? ( vreg1 vreg2 -- ? ) + ! If first register is killed after second one is defined, they interfere + [ kill-index get at ] [ def-index get at ] bi* >= ; + +: interferes-same-block? ( vreg1 vreg2 -- ? ) + ! If both are defined in the same basic block, they interfere if their + ! local live ranges intersect. + { [ kill-after-def? ] [ swap kill-after-def? ] } 2|| ; + +: interferes-first-dominates? ( vreg1 vreg2 -- ? ) + ! If vreg1 dominates vreg2, then they interfere if vreg2's definition + ! occurs before vreg1 is killed. + kill-after-def? ; + +: interferes-second-dominates? ( vreg1 vreg2 -- ? ) + ! If vreg2 dominates vreg1, then they interfere if vreg1's definition + ! occurs before vreg2 is killed. + swap kill-after-def? ; + +PRIVATE> + +SYMBOLS: +same-block+ +first-dominates+ +second-dominates+ ; + +: interferes? ( vreg1 vreg2 bb mode -- ? ) + ! local interference test - mode is one of the above symbols + [ compute-local-live-ranges ] dip + { + { +same-block+ [ interferes-same-block? ] } + { +first-dominates+ [ interferes-first-dominates? ] } + { +second-dominates+ [ interferes-second-dominates? ] } + } case ; \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor new file mode 100644 index 0000000000..6e73bb5e2f --- /dev/null +++ b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor @@ -0,0 +1,160 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel locals math math.order arrays +namespaces sequences sorting sets combinators combinators.short-circuit +dlists deques make +compiler.cfg.def-use +compiler.cfg.instructions +compiler.cfg.liveness +compiler.cfg.dominance +compiler.cfg.coalescing.state +compiler.cfg.coalescing.forest +compiler.cfg.coalescing.interference ; +IN: compiler.cfg.coalescing.process-blocks + +SYMBOLS: phi-union unioned-blocks ; + +:: operand-live-into-phi-node's-block? ( bb src dst -- ? ) + src bb live-in key? ; + +:: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? ) + dst src def-of live-out key? ; + +:: operand-is-phi-node-and-live-into-operand's-block? ( bb src dst -- ? ) + { [ src insn-of ##phi? ] [ src src def-of live-in key? ] } 0&& ; + +:: operand-being-renamed? ( bb src dst -- ? ) + src processed-names get key? ; + +:: two-operands-in-same-block? ( bb src dst -- ? ) + src def-of unioned-blocks get key? ; + +: trivial-interference? ( bb src dst -- ? ) + { + [ operand-live-into-phi-node's-block? ] + [ phi-node-is-live-out-of-operand's-block? ] + [ operand-is-phi-node-and-live-into-operand's-block? ] + [ operand-being-renamed? ] + [ two-operands-in-same-block? ] + } 3|| ; + +: don't-coalesce ( bb src dst -- ) + 2nip processed-name ; + +:: trivial-interference ( bb src dst -- ) + dst src bb waiting-for push-at + src used-by-another get push ; + +:: add-to-renaming-set ( bb src dst -- ) + src phi-union get conjoin + src def-of unioned-blocks get conjoin ; + +: process-phi-operand ( bb src dst -- ) + { + { [ 2dup eq? ] [ don't-coalesce ] } + { [ 3dup trivial-interference? ] [ trivial-interference ] } + [ add-to-renaming-set ] + } cond ; + +SYMBOLS: visited work-list ; + +: node-is-live-in-of-child? ( node child -- ? ) + [ vreg>> ] [ bb>> live-in ] bi* key? ; + +: node-is-live-out-of-child? ( node child -- ? ) + [ vreg>> ] [ bb>> live-out ] bi* key? ; + +:: insert-copy ( bb src dst -- ) + bb src dst trivial-interference + src phi-union get delete-at ; + +:: insert-copy-for-parent ( bb src node dst -- ) + src node vreg>> eq? [ bb src dst insert-copy ] when ; + +: insert-copies-for-parent ( ##phi node child -- ) + drop + [ [ inputs>> ] [ dst>> ] bi ] dip + '[ _ _ insert-copy-for-parent ] assoc-each ; + +: defined-in-same-block? ( node child -- ? ) [ bb>> ] bi@ eq? ; + +: add-interference ( ##phi node child -- ) + [ vreg>> ] bi@ 2array , drop ; + +: add-to-work-list ( child -- inserted? ) + dup visited get key? [ drop f ] [ work-list get push-back t ] if ; + +: process-df-child ( ##phi node child -- inserted? ) + [ + { + { [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] } + { [ 2dup node-is-live-in-of-child? ] [ add-interference ] } + { [ 2dup defined-in-same-block? ] [ add-interference ] } + [ 3drop ] + } cond + ] + [ add-to-work-list ] + bi ; + +: process-df-node ( ##phi node -- ) + dup visited get conjoin + dup children>> [ process-df-child ] with with map + [ ] any? [ work-list get pop-back* ] unless ; + +: process-phi-union ( ##phi dom-forest -- ) + H{ } clone visited set + [ push-all-front ] keep + [ work-list set ] [ [ process-df-node ] with slurp-deque ] bi ; + +:: add-local-interferences ( bb ##phi -- ) + phi-union get [ + drop dup def-of bb eq? + [ ##phi dst>> 2array , ] [ drop ] if + ] assoc-each ; + +: compute-local-interferences ( bb ##phi -- pairs ) + [ + [ phi-union get compute-dom-forest process-phi-union drop ] + [ add-local-interferences ] + 2bi + ] { } make ; + +:: insert-copies-for-interference ( ##phi src -- ) + ##phi inputs>> [| bb src' | + src src' eq? [ bb src ##phi dst>> insert-copy ] when + ] assoc-each ; + +:: same-block ( ##phi vreg1 vreg2 bb1 bb2 -- ) + vreg1 vreg2 bb1 +same-block+ interferes? + [ ##phi vreg1 insert-copies-for-interference ] when ; + +:: first-dominates ( ##phi vreg1 vreg2 bb1 bb2 -- ) + vreg1 vreg2 bb2 +first-dominates+ interferes? + [ ##phi vreg1 insert-copies-for-interference ] when ; + +:: second-dominates ( ##phi vreg1 vreg2 bb1 bb2 -- ) + vreg1 vreg2 bb1 +second-dominates+ interferes? + [ ##phi vreg1 insert-copies-for-interference ] when ; + +: process-local-interferences ( ##phi pairs -- ) + [ + first2 2dup [ def-of ] bi@ { + { [ 2dup eq? ] [ same-block ] } + { [ 2dup dominates? ] [ first-dominates ] } + [ second-dominates ] + } cond + ] with each ; + +: add-renaming-set ( ##phi -- ) + dst>> phi-union get swap renaming-sets get set-at + phi-union get [ drop processed-name ] assoc-each ; + +:: process-phi ( bb ##phi -- ) + H{ } phi-union set + H{ } unioned-blocks set + ##phi inputs>> ##phi dst>> '[ _ process-phi-operand ] assoc-each + ##phi bb ##phi compute-local-interferences process-local-interferences + ##phi add-renaming-set ; + +: process-block ( bb -- ) + dup [ dup ##phi? [ process-phi t ] [ 2drop f ] if ] with all? drop ; diff --git a/basis/compiler/cfg/coalescing/state/state.factor b/basis/compiler/cfg/coalescing/state/state.factor new file mode 100644 index 0000000000..b2c2f59e45 --- /dev/null +++ b/basis/compiler/cfg/coalescing/state/state.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces sets kernel assocs ; +IN: compiler.cfg.coalescing.state + +SYMBOLS: processed-names waiting used-by-another renaming-sets ; + +: init-coalescing ( -- ) + H{ } clone processed-names set + H{ } clone waiting set + V{ } clone used-by-another set ; + +: processed-name ( vreg -- ) processed-names get conjoin ; + +: waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ; From 501629cf75bdd3cb912ea35a4a89dd69c6b5b0ae Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 00:30:24 -0500 Subject: [PATCH 37/81] compiler.tree.propagation.info: fix load error --- basis/compiler/tree/propagation/info/info.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index f45fc2e18a..a2dec12279 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -3,7 +3,7 @@ USING: assocs classes classes.algebra classes.tuple classes.tuple.private kernel accessors math math.intervals namespaces sequences words combinators byte-arrays strings -arrays compiler.tree.propagation.copy ; +arrays layouts cpu.architecture compiler.tree.propagation.copy ; IN: compiler.tree.propagation.info : false-class? ( class -- ? ) \ f class<= ; From a32cbdd2314e5ad740b60ae6f7654bc0b6fa0943 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 00:31:21 -0500 Subject: [PATCH 38/81] compiler.cfg.coalescing: more work done --- .../compiler/cfg/coalescing/coalescing.factor | 13 ++--- .../cfg/coalescing/copies/copies.factor | 37 +++++++++++- .../cfg/coalescing/forest/forest.factor | 2 +- .../interference/interference.factor | 30 +++++----- .../process-blocks/process-blocks.factor | 47 +++++++-------- .../cfg/coalescing/renaming/renaming.factor | 10 ++++ .../cfg/coalescing/state/state.factor | 1 + basis/compiler/cfg/dominance/dominance.factor | 4 ++ basis/compiler/cfg/liveness/liveness.factor | 6 +- basis/compiler/cfg/liveness/ssa/ssa.factor | 57 +++++++++++++++++++ 10 files changed, 155 insertions(+), 52 deletions(-) create mode 100644 basis/compiler/cfg/coalescing/renaming/renaming.factor create mode 100644 basis/compiler/cfg/liveness/ssa/ssa.factor diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor index 5a09b59749..05a67a230b 100644 --- a/basis/compiler/cfg/coalescing/coalescing.factor +++ b/basis/compiler/cfg/coalescing/coalescing.factor @@ -3,10 +3,13 @@ USING: accessors assocs fry kernel locals math math.order sequences compiler.cfg.rpo -compiler.cfg.instructions +compiler.cfg.utilities compiler.cfg.dominance +compiler.cfg.instructions compiler.cfg.coalescing.state compiler.cfg.coalescing.forest +compiler.cfg.coalescing.copies +compiler.cfg.coalescing.renaming compiler.cfg.coalescing.process-blocks ; IN: compiler.cfg.coalescing @@ -18,14 +21,8 @@ IN: compiler.cfg.coalescing : process-blocks ( cfg -- ) [ [ process-block ] if-has-phis ] each-basic-block ; -: schedule-copies ( bb -- ) drop ; - : break-interferences ( -- ) ; -: insert-copies ( cfg -- ) drop ; - -: perform-renaming ( cfg -- ) drop ; - : remove-phis-from-block ( bb -- ) instructions>> [ ##phi? not ] filter-here ; @@ -38,5 +35,5 @@ IN: compiler.cfg.coalescing dup process-blocks break-interferences dup insert-copies - dup perform-renaming + perform-renaming dup remove-phis ; \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/coalescing/copies/copies.factor index c0a3ed8923..7293bcc802 100644 --- a/basis/compiler/cfg/coalescing/copies/copies.factor +++ b/basis/compiler/cfg/coalescing/copies/copies.factor @@ -1,8 +1,39 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ; +USING: accessors assocs combinators fry kernel namespaces sequences +compiler.cfg.def-use compiler.cfg.dominance compiler.cfg.instructions +compiler.cfg.renaming ; IN: compiler.cfg.coalescing.copies -: schedule-copies ( bb -- ) drop ; +SYMBOLS: stacks visited pushed ; -: insert-copies ( cfg -- ) drop ; +: compute-renaming ( insn -- assoc ) + uses-vregs stacks get + '[ dup dup _ at [ nip last ] unless-empty ] + H{ } map>assoc ; + +: rename-operands ( bb -- ) + instructions>> [ + dup ##phi? [ drop ] [ + dup compute-renaming renamings set + [ rename-insn-uses ] [ rename-insn-defs ] bi + ] if + ] each ; + +: schedule-copies ( bb -- ) + ! FIXME + drop ; + +: pop-stacks ( -- ) + pushed get stacks get '[ drop _ at pop* ] assoc-each ; + +: (insert-copies) ( bb -- ) + H{ } clone pushed [ + [ rename-operands ] + [ schedule-copies ] + [ dom-children [ (insert-copies) ] each ] tri + pop-stacks + ] with-variable ; + +: insert-copies ( cfg -- ) + entry>> (insert-copies) ; \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/forest/forest.factor b/basis/compiler/cfg/coalescing/forest/forest.factor index f1f8334975..fa0aa6e6d3 100644 --- a/basis/compiler/cfg/coalescing/forest/forest.factor +++ b/basis/compiler/cfg/coalescing/forest/forest.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs fry kernel math math.order namespaces sequences sorting vectors compiler.cfg.def-use -compiler.cfg.dominance ; +compiler.cfg.dominance compiler.cfg.registers ; IN: compiler.cfg.coalescing.forest TUPLE: dom-forest-node vreg bb children ; diff --git a/basis/compiler/cfg/coalescing/interference/interference.factor b/basis/compiler/cfg/coalescing/interference/interference.factor index 36dea6f0a0..9fdf06bcb4 100644 --- a/basis/compiler/cfg/coalescing/interference/interference.factor +++ b/basis/compiler/cfg/coalescing/interference/interference.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators combinators.short-circuit -kernel math namespaces sequences compiler.cfg.def-use -compiler.cfg.liveness ; +kernel math namespaces sequences locals compiler.cfg.def-use +compiler.cfg.liveness compiler.cfg.dominance ; IN: compiler.cfg.coalescing.interference ! Local interference testing. Requires live-out information @@ -27,30 +27,30 @@ SYMBOLS: def-index kill-index ; ! If first register is killed after second one is defined, they interfere [ kill-index get at ] [ def-index get at ] bi* >= ; -: interferes-same-block? ( vreg1 vreg2 -- ? ) +: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? ) ! If both are defined in the same basic block, they interfere if their ! local live ranges intersect. + drop compute-local-live-ranges { [ kill-after-def? ] [ swap kill-after-def? ] } 2|| ; -: interferes-first-dominates? ( vreg1 vreg2 -- ? ) +: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? ) ! If vreg1 dominates vreg2, then they interfere if vreg2's definition ! occurs before vreg1 is killed. + nip compute-local-live-ranges kill-after-def? ; -: interferes-second-dominates? ( vreg1 vreg2 -- ? ) +: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? ) ! If vreg2 dominates vreg1, then they interfere if vreg1's definition ! occurs before vreg2 is killed. + drop compute-local-live-ranges swap kill-after-def? ; PRIVATE> -SYMBOLS: +same-block+ +first-dominates+ +second-dominates+ ; - -: interferes? ( vreg1 vreg2 bb mode -- ? ) - ! local interference test - mode is one of the above symbols - [ compute-local-live-ranges ] dip - { - { +same-block+ [ interferes-same-block? ] } - { +first-dominates+ [ interferes-first-dominates? ] } - { +second-dominates+ [ interferes-second-dominates? ] } - } case ; \ No newline at end of file +: interferes? ( vreg1 vreg2 -- ? ) + 2dup [ def-of ] bi@ { + { [ 2dup eq? ] [ interferes-same-block? ] } + { [ 2dup dominates? ] [ interferes-first-dominates? ] } + { [ 2dup swap dominates? ] [ interferes-second-dominates? ] } + [ 2drop 2drop f ] + } cond ; diff --git a/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor index 6e73bb5e2f..005c71f357 100644 --- a/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor +++ b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor @@ -12,6 +12,11 @@ compiler.cfg.coalescing.forest compiler.cfg.coalescing.interference ; IN: compiler.cfg.coalescing.process-blocks +! phi-union maps a vreg to the predecessor block +! that carries it to the phi node's block + +! unioned-blocks is a set of bb's which defined +! the source vregs above SYMBOLS: phi-union unioned-blocks ; :: operand-live-into-phi-node's-block? ( bb src dst -- ? ) @@ -46,7 +51,7 @@ SYMBOLS: phi-union unioned-blocks ; src used-by-another get push ; :: add-to-renaming-set ( bb src dst -- ) - src phi-union get conjoin + bb src phi-union get set-at src def-of unioned-blocks get conjoin ; : process-phi-operand ( bb src dst -- ) @@ -101,12 +106,22 @@ SYMBOLS: visited work-list ; dup children>> [ process-df-child ] with with map [ ] any? [ work-list get pop-back* ] unless ; +: process-df-nodes ( ##phi work-list -- ) + dup deque-empty? [ 2drop ] [ + [ peek-back process-df-node ] + [ process-df-nodes ] + 2bi + ] if ; + : process-phi-union ( ##phi dom-forest -- ) H{ } clone visited set [ push-all-front ] keep - [ work-list set ] [ [ process-df-node ] with slurp-deque ] bi ; + [ work-list set ] [ process-df-nodes ] bi ; :: add-local-interferences ( bb ##phi -- ) + ! bb contains the phi node. If the input is defined in the same + ! block as the phi node, we have to check for interference. + ! This can only happen if the value is carried by a back edge. phi-union get [ drop dup def-of bb eq? [ ##phi dst>> 2array , ] [ drop ] if @@ -114,7 +129,7 @@ SYMBOLS: visited work-list ; : compute-local-interferences ( bb ##phi -- pairs ) [ - [ phi-union get compute-dom-forest process-phi-union drop ] + [ phi-union get keys compute-dom-forest process-phi-union drop ] [ add-local-interferences ] 2bi ] { } make ; @@ -124,25 +139,10 @@ SYMBOLS: visited work-list ; src src' eq? [ bb src ##phi dst>> insert-copy ] when ] assoc-each ; -:: same-block ( ##phi vreg1 vreg2 bb1 bb2 -- ) - vreg1 vreg2 bb1 +same-block+ interferes? - [ ##phi vreg1 insert-copies-for-interference ] when ; - -:: first-dominates ( ##phi vreg1 vreg2 bb1 bb2 -- ) - vreg1 vreg2 bb2 +first-dominates+ interferes? - [ ##phi vreg1 insert-copies-for-interference ] when ; - -:: second-dominates ( ##phi vreg1 vreg2 bb1 bb2 -- ) - vreg1 vreg2 bb1 +second-dominates+ interferes? - [ ##phi vreg1 insert-copies-for-interference ] when ; - : process-local-interferences ( ##phi pairs -- ) [ - first2 2dup [ def-of ] bi@ { - { [ 2dup eq? ] [ same-block ] } - { [ 2dup dominates? ] [ first-dominates ] } - [ second-dominates ] - } cond + first2 2dup interferes? + [ drop insert-copies-for-interference ] [ 3drop ] if ] with each ; : add-renaming-set ( ##phi -- ) @@ -150,11 +150,12 @@ SYMBOLS: visited work-list ; phi-union get [ drop processed-name ] assoc-each ; :: process-phi ( bb ##phi -- ) - H{ } phi-union set - H{ } unioned-blocks set + H{ } clone phi-union set + H{ } clone unioned-blocks set ##phi inputs>> ##phi dst>> '[ _ process-phi-operand ] assoc-each ##phi bb ##phi compute-local-interferences process-local-interferences ##phi add-renaming-set ; : process-block ( bb -- ) - dup [ dup ##phi? [ process-phi t ] [ 2drop f ] if ] with all? drop ; + dup instructions>> + [ dup ##phi? [ process-phi t ] [ 2drop f ] if ] with all? drop ; diff --git a/basis/compiler/cfg/coalescing/renaming/renaming.factor b/basis/compiler/cfg/coalescing/renaming/renaming.factor new file mode 100644 index 0000000000..3b26c09738 --- /dev/null +++ b/basis/compiler/cfg/coalescing/renaming/renaming.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel ; +IN: compiler.cfg.coalescing.renaming + +: perform-renaming ( -- ) + renaming-sets get [ + ! XXX + 2drop + ] assoc-each ; diff --git a/basis/compiler/cfg/coalescing/state/state.factor b/basis/compiler/cfg/coalescing/state/state.factor index b2c2f59e45..6174945ccb 100644 --- a/basis/compiler/cfg/coalescing/state/state.factor +++ b/basis/compiler/cfg/coalescing/state/state.factor @@ -6,6 +6,7 @@ IN: compiler.cfg.coalescing.state SYMBOLS: processed-names waiting used-by-another renaming-sets ; : init-coalescing ( -- ) + H{ } clone renaming-sets set H{ } clone processed-names set H{ } clone waiting set V{ } clone used-by-another set ; diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor index 6a73b349de..6eeeacd6f1 100644 --- a/basis/compiler/cfg/dominance/dominance.factor +++ b/basis/compiler/cfg/dominance/dominance.factor @@ -118,10 +118,14 @@ PRIVATE> SYMBOLS: preorder maxpreorder ; +PRIVATE> + : pre-of ( bb -- n ) [ preorder get at ] [ -1/0. ] if* ; : maxpre-of ( bb -- n ) [ maxpreorder get at ] [ 1/0. ] if* ; + ] bi* [ - [ uses-vregs [ over conjoin ] each ] + [ dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ] [ defs-vregs [ over delete-at ] each ] bi ] each ; : local-live-in ( instructions -- live-set ) - [ ##phi? not ] filter [ H{ } ] dip transfer-liveness keys ; + [ H{ } ] dip transfer-liveness keys ; M: live-analysis transfer-set drop instructions>> transfer-liveness ; diff --git a/basis/compiler/cfg/liveness/ssa/ssa.factor b/basis/compiler/cfg/liveness/ssa/ssa.factor new file mode 100644 index 0000000000..9fa22d22b1 --- /dev/null +++ b/basis/compiler/cfg/liveness/ssa/ssa.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces deques accessors sets sequences assocs fry +hashtables dlists compiler.cfg.def-use compiler.cfg.instructions +compiler.cfg.rpo compiler.cfg.liveness ; +IN: compiler.cfg.liveness.ssa + +! TODO: merge with compiler.cfg.liveness + +! Assoc mapping basic blocks to sequences of sets of vregs; each sequence +! is in conrrespondence with a predecessor +SYMBOL: phi-live-ins + +: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ; + +SYMBOL: work-list + +: add-to-work-list ( basic-blocks -- ) + work-list get '[ _ push-front ] each ; + +: compute-live-in ( basic-block -- live-in ) + [ live-out ] keep instructions>> transfer-liveness ; + +: compute-phi-live-in ( basic-block -- phi-live-in ) + instructions>> [ ##phi? ] filter [ f ] [ + H{ } clone [ + '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each + ] keep + ] if-empty ; + +: update-live-in ( basic-block -- changed? ) + [ [ compute-live-in ] keep live-ins get maybe-set-at ] + [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ] + bi and ; + +: compute-live-out ( basic-block -- live-out ) + [ successors>> [ live-in ] map ] + [ dup successors>> [ phi-live-in ] with map ] bi + append assoc-combine ; + +: update-live-out ( basic-block -- changed? ) + [ compute-live-out ] keep + live-outs get maybe-set-at ; + +: liveness-step ( basic-block -- ) + dup update-live-out [ + dup update-live-in + [ predecessors>> add-to-work-list ] [ drop ] if + ] [ drop ] if ; + +: compute-ssa-live-sets ( cfg -- cfg' ) + work-list set + H{ } clone live-ins set + H{ } clone phi-live-ins set + H{ } clone live-outs set + dup post-order add-to-work-list + work-list get [ liveness-step ] slurp-deque ; From ba696b68b82c15a6ebb8cc200e7c0dc3c169673c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 02:20:45 -0500 Subject: [PATCH 39/81] compiler.cfg.coalescing: more or less complete, now needs debugging --- .../compiler/cfg/coalescing/coalescing.factor | 26 ++++++++-- .../cfg/coalescing/copies/copies.factor | 48 ++++++------------- .../cfg/coalescing/renaming/renaming.factor | 35 +++++++++++--- basis/compiler/cfg/dominance/dominance.factor | 20 ++++---- basis/compiler/cfg/optimizer/optimizer.factor | 6 +-- basis/compiler/cfg/ssa/ssa.factor | 1 + basis/disjoint-sets/disjoint-sets.factor | 4 ++ 7 files changed, 84 insertions(+), 56 deletions(-) diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor index 05a67a230b..fe6166302f 100644 --- a/basis/compiler/cfg/coalescing/coalescing.factor +++ b/basis/compiler/cfg/coalescing/coalescing.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs fry kernel locals math math.order -sequences +sequences namespaces sets compiler.cfg.rpo +compiler.cfg.def-use compiler.cfg.utilities compiler.cfg.dominance compiler.cfg.instructions @@ -21,7 +22,24 @@ IN: compiler.cfg.coalescing : process-blocks ( cfg -- ) [ [ process-block ] if-has-phis ] each-basic-block ; -: break-interferences ( -- ) ; +SYMBOL: seen + +:: visit-renaming ( dst assoc src bb -- ) + src seen get key? [ + src dst bb waiting-for push-at + src assoc delete-at + ] [ src seen get conjoin ] if ; + +:: break-interferences ( -- ) + V{ } clone seen set + renaming-sets get [| dst assoc | + assoc [| src bb | + src seen get key? + [ dst assoc src bb visit-renaming ] + [ src seen get conjoin ] + if + ] assoc-each + ] assoc-each ; : remove-phis-from-block ( bb -- ) instructions>> [ ##phi? not ] filter-here ; @@ -31,9 +49,11 @@ IN: compiler.cfg.coalescing : coalesce ( cfg -- cfg' ) init-coalescing + dup compute-def-use + dup compute-dominance dup compute-dfs dup process-blocks break-interferences dup insert-copies - perform-renaming + dup perform-renaming dup remove-phis ; \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/coalescing/copies/copies.factor index 7293bcc802..86f9e12423 100644 --- a/basis/compiler/cfg/coalescing/copies/copies.factor +++ b/basis/compiler/cfg/coalescing/copies/copies.factor @@ -1,39 +1,21 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs combinators fry kernel namespaces sequences -compiler.cfg.def-use compiler.cfg.dominance compiler.cfg.instructions -compiler.cfg.renaming ; +USING: accessors assocs hashtables fry kernel make namespaces +sequences compiler.cfg.coalescing.state compiler.cfg.parallel-copy ; IN: compiler.cfg.coalescing.copies -SYMBOLS: stacks visited pushed ; - -: compute-renaming ( insn -- assoc ) - uses-vregs stacks get - '[ dup dup _ at [ nip last ] unless-empty ] - H{ } map>assoc ; - -: rename-operands ( bb -- ) - instructions>> [ - dup ##phi? [ drop ] [ - dup compute-renaming renamings set - [ rename-insn-uses ] [ rename-insn-defs ] bi - ] if - ] each ; - -: schedule-copies ( bb -- ) - ! FIXME - drop ; - -: pop-stacks ( -- ) - pushed get stacks get '[ drop _ at pop* ] assoc-each ; - -: (insert-copies) ( bb -- ) - H{ } clone pushed [ - [ rename-operands ] - [ schedule-copies ] - [ dom-children [ (insert-copies) ] each ] tri - pop-stacks - ] with-variable ; +: compute-copies ( assoc -- assoc' ) + dup assoc-size [ + '[ + [ _ set-at ] with each + ] assoc-each + ] keep ; : insert-copies ( cfg -- ) - entry>> (insert-copies) ; \ No newline at end of file + waiting get [ + [ instructions>> building ] dip '[ + building get pop + _ compute-copies parallel-copy + , + ] with-variable + ] assoc-each ; \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/renaming/renaming.factor b/basis/compiler/cfg/coalescing/renaming/renaming.factor index 3b26c09738..bad74807d0 100644 --- a/basis/compiler/cfg/coalescing/renaming/renaming.factor +++ b/basis/compiler/cfg/coalescing/renaming/renaming.factor @@ -1,10 +1,33 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ; +USING: accessors assocs fry kernel namespaces sequences +compiler.cfg.coalescing.state compiler.cfg.renaming compiler.cfg.rpo +disjoint-sets ; IN: compiler.cfg.coalescing.renaming -: perform-renaming ( -- ) - renaming-sets get [ - ! XXX - 2drop - ] assoc-each ; +: update-congruence-class ( dst assoc disjoint-set -- ) + [ keys swap ] dip + [ nip add-atoms ] + [ add-atom drop ] + [ equate-all-with ] 3tri ; + +: build-congruence-classes ( -- disjoint-set ) + renaming-sets get + [ + '[ + _ update-congruence-class + ] assoc-each + ] keep ; + +: compute-renaming ( disjoint-set -- assoc ) + [ parents>> ] keep + '[ drop dup _ representative ] assoc-map ; + +: perform-renaming ( cfg -- ) + build-congruence-classes compute-renaming renamings set + [ + instructions>> [ + [ rename-insn-defs ] + [ rename-insn-uses ] bi + ] each + ] each-basic-block ; diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor index 6eeeacd6f1..ebd3a981d7 100644 --- a/basis/compiler/cfg/dominance/dominance.factor +++ b/basis/compiler/cfg/dominance/dominance.factor @@ -60,21 +60,26 @@ PRIVATE> [ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep dom-childrens set ; -! Maps bb -> DF(bb) -SYMBOL: dom-frontiers - PRIVATE> -: dom-frontier ( bb -- set ) dom-frontiers get at keys ; +: compute-dominance ( cfg -- ) + compute-dom-parents compute-dom-children ; DF(bb) +SYMBOL: dom-frontiers + : compute-dom-frontier ( bb pred -- ) 2dup [ dom-parent ] dip eq? [ 2drop ] [ [ dom-frontiers get conjoin-at ] [ dom-parent compute-dom-frontier ] 2bi ] if ; +PRIVATE> + +: dom-frontier ( bb -- set ) dom-frontiers get at keys ; + : compute-dom-frontiers ( cfg -- ) H{ } clone dom-frontiers set [ @@ -83,13 +88,6 @@ PRIVATE> ] [ 2drop ] if ] each-basic-block ; -PRIVATE> - -: compute-dominance ( cfg -- ) - [ compute-dom-parents compute-dom-children ] - [ compute-dom-frontiers ] - bi ; - [ ] [ compute-live-sets ] [ compute-dominance ] + [ compute-dom-frontiers ] [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] } cleave ; \ No newline at end of file diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor index a3e5c7ceb7..80ab2f58bf 100644 --- a/basis/disjoint-sets/disjoint-sets.factor +++ b/basis/disjoint-sets/disjoint-sets.factor @@ -35,6 +35,8 @@ TUPLE: disjoint-set : representative? ( a disjoint-set -- ? ) dupd parent = ; inline +PRIVATE> + GENERIC: representative ( a disjoint-set -- p ) M: disjoint-set representative @@ -42,6 +44,8 @@ M: disjoint-set representative [ [ parent ] keep representative dup ] 2keep set-parent ] if ; + Date: Mon, 27 Jul 2009 02:20:53 -0500 Subject: [PATCH 40/81] compiler.cfg.phi-elimination: no longer needed --- .../compiler/cfg/phi-elimination/authors.txt | 2 - .../phi-elimination-tests.factor | 55 ------------------- .../phi-elimination/phi-elimination.factor | 40 -------------- 3 files changed, 97 deletions(-) delete mode 100644 basis/compiler/cfg/phi-elimination/authors.txt delete mode 100644 basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor delete mode 100644 basis/compiler/cfg/phi-elimination/phi-elimination.factor diff --git a/basis/compiler/cfg/phi-elimination/authors.txt b/basis/compiler/cfg/phi-elimination/authors.txt deleted file mode 100644 index a44f8d7f8d..0000000000 --- a/basis/compiler/cfg/phi-elimination/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Slava Pestov -Daniel Ehrenberg diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor b/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor deleted file mode 100644 index 22afc0b32b..0000000000 --- a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor +++ /dev/null @@ -1,55 +0,0 @@ -! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: compiler.cfg.instructions compiler.cfg compiler.cfg.registers -compiler.cfg.comparisons compiler.cfg.debugger locals -compiler.cfg.phi-elimination kernel accessors sequences classes -namespaces tools.test cpu.architecture arrays ; -IN: compiler.cfg.phi-elimination.tests - -V{ T{ ##branch } } 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< } -} 1 test-bb - -V{ - T{ ##load-immediate f V int-regs 1 1 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##load-immediate f V int-regs 2 2 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##phi f V int-regs 3 { } } - T{ ##replace f V int-regs 3 D 0 } - T{ ##return } -} 4 test-bb - -4 get instructions>> first -2 get V int-regs 1 2array -3 get V int-regs 2 2array 2array ->>inputs drop - -test-diamond - -3 vreg-counter set-global - -[ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test - -[ T{ ##copy f V int-regs 4 V int-regs 1 } ] [ - 2 get successors>> first instructions>> first -] unit-test - -[ T{ ##copy f V int-regs 4 V int-regs 2 } ] [ - 3 get successors>> first instructions>> first -] unit-test - -[ T{ ##copy f V int-regs 3 V int-regs 4 } ] [ - 4 get instructions>> first -] unit-test - -[ 3 ] [ 4 get instructions>> length ] unit-test diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor deleted file mode 100644 index 38e82176ca..0000000000 --- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor +++ /dev/null @@ -1,40 +0,0 @@ -! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs fry kernel sequences namespaces -compiler.cfg compiler.cfg.instructions compiler.cfg.rpo -compiler.cfg.utilities compiler.cfg.hats make -locals ; -IN: compiler.cfg.phi-elimination - -! assoc mapping predecessors to sequences -SYMBOL: added-instructions - -: add-instructions ( predecessor quot -- ) - [ - added-instructions get - [ drop V{ } clone ] cache - building - ] dip with-variable ; inline - -: insert-basic-blocks ( bb -- ) - [ added-instructions get ] dip - '[ [ _ ] dip insert-basic-block ] assoc-each ; - -: insert-copy ( predecessor input output -- ) - '[ _ _ swap ##copy ] add-instructions ; - -: eliminate-phi ( ##phi -- ##copy ) - i - [ [ inputs>> ] dip '[ _ insert-copy ] assoc-each ] - [ [ dst>> ] dip \ ##copy new-insn ] - 2bi ; - -: eliminate-phi-step ( bb -- ) - H{ } clone added-instructions set - [ instructions>> [ dup ##phi? [ eliminate-phi ] when ] change-each ] - [ insert-basic-blocks ] - bi ; - -: eliminate-phis ( cfg -- cfg' ) - dup [ eliminate-phi-step ] each-basic-block - cfg-changed ; From 9fa71959b51137c9512168d97baae103f3564c74 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 03:58:01 -0500 Subject: [PATCH 41/81] compiler.cfg.coalescing: fix shuffling bug --- basis/compiler/cfg/coalescing/coalescing.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor index fe6166302f..afb364f4fe 100644 --- a/basis/compiler/cfg/coalescing/coalescing.factor +++ b/basis/compiler/cfg/coalescing/coalescing.factor @@ -54,6 +54,6 @@ SYMBOL: seen dup compute-dfs dup process-blocks break-interferences - dup insert-copies + insert-copies dup perform-renaming dup remove-phis ; \ No newline at end of file From 31555b05cf896255ae36de4de0eacaffe68ab72f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 03:58:15 -0500 Subject: [PATCH 42/81] compiler.codegen: collect instruction statistics --- basis/compiler/codegen/codegen.factor | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index f1052da2d5..993edbf812 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -4,7 +4,7 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs alien.strings alien.arrays alien.complex alien.libraries sets libc -continuations.private fry cpu.architecture +continuations.private fry cpu.architecture classes source-files.errors compiler.errors compiler.alien @@ -18,6 +18,10 @@ compiler.codegen.fixup compiler.utilities ; IN: compiler.codegen +SYMBOL: insn-counts + +H{ } clone insn-counts set-global + GENERIC: generate-insn ( insn -- ) SYMBOL: registers @@ -54,7 +58,12 @@ SYMBOL: labels [ word>> init-generator ] [ instructions>> - [ [ regs>> registers set ] [ generate-insn ] bi ] each + [ + [ class insn-counts get inc-at ] + [ regs>> registers set ] + [ generate-insn ] + tri + ] each ] bi ] with-fixup ; From 1a765c38da7b099376e2595621697a28a96f9dbd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 16:54:47 -0500 Subject: [PATCH 43/81] compiler.cfg.parallel-copy: fix algorithm --- .../parallel-copy/parallel-copy-tests.factor | 4 +- .../parallel-copy/parallel-copy.alt.factor | 57 -------------- .../cfg/parallel-copy/parallel-copy.factor | 76 +++++++++++-------- 3 files changed, 47 insertions(+), 90 deletions(-) delete mode 100644 basis/compiler/cfg/parallel-copy/parallel-copy.alt.factor diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor b/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor index 0234c2eae7..17b043c1b7 100644 --- a/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor +++ b/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor @@ -11,9 +11,9 @@ SYMBOL: temp [ { - T{ ##copy f V int-regs 3 V int-regs 2 } + T{ ##copy f V int-regs 4 V int-regs 2 } T{ ##copy f V int-regs 2 V int-regs 1 } - T{ ##copy f V int-regs 1 V int-regs 3 } + T{ ##copy f V int-regs 1 V int-regs 4 } } ] [ H{ diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy.alt.factor b/basis/compiler/cfg/parallel-copy/parallel-copy.alt.factor deleted file mode 100644 index 534cef36d2..0000000000 --- a/basis/compiler/cfg/parallel-copy/parallel-copy.alt.factor +++ /dev/null @@ -1,57 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs compiler.cfg.hats compiler.cfg.instructions -deques dlists fry kernel locals namespaces sequences -hashtables ; -IN: compiler.cfg.parallel-copy - -! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency -! http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf, -! Algorithm 1 - - to-do set - ready set - [ preds set ] - [ [ nip dup ] H{ } assoc-map-as locs set ] - [ keys [ init-to-do ] [ init-ready ] bi ] tri ; - -:: process-ready ( b quot -- ) - b preds get at :> a - a locs get at :> c - b c quot call - b a locs get set-at - a c = a preds get at and [ a ready get push-front ] when ; inline - -:: process-to-do ( b quot -- ) - b preds get at locs get at b = [ - temp get b quot call - temp get b locs get set-at - b ready get push-front - ] unless ; inline - -PRIVATE> - -:: parallel-mapping ( mapping temp quot -- ) - [ - mapping temp init - to-do get [ - ready get [ - quot process-ready - ] slurp-deque - quot process-to-do - ] slurp-deque - ] with-scope ; - -: parallel-copy ( mapping -- ) i [ ##copy ] parallel-mapping ; \ No newline at end of file diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy.factor b/basis/compiler/cfg/parallel-copy/parallel-copy.factor index ff309c45ad..550928b8ba 100644 --- a/basis/compiler/cfg/parallel-copy/parallel-copy.factor +++ b/basis/compiler/cfg/parallel-copy/parallel-copy.factor @@ -2,45 +2,59 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs compiler.cfg.hats compiler.cfg.instructions deques dlists fry kernel locals namespaces sequences -sets hashtables ; +hashtables ; IN: compiler.cfg.parallel-copy -SYMBOLS: mapping dependency-graph work-list ; +! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency +! http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf, +! Algorithm 1 -: build-dependency-graph ( mapping -- deps ) - H{ } clone [ '[ _ conjoin-at ] assoc-each ] keep ; + [ push-all-front ] keep ; +SYMBOLS: temp locs preds to-do ready ; -: init ( mapping -- work-list ) - dup build-dependency-graph - [ [ >hashtable mapping set ] [ dependency-graph set ] bi* ] - [ build-work-list dup work-list set ] - 2bi ; +: init-to-do ( bs -- ) + to-do get push-all-back ; -:: retire-copy ( dst src -- ) - dst mapping get delete-at - src dependency-graph get at :> deps - dst deps delete-at - deps assoc-empty? [ - src mapping get key? [ - src work-list get push-front - ] when - ] when ; +: init-ready ( bs -- ) + locs get '[ _ key? not ] filter ready get push-all-front ; -: perform-copy ( dst -- ) - dup mapping get at - [ ##copy ] [ retire-copy ] 2bi ; +: init ( mapping temp -- ) + temp set + to-do set + ready set + [ preds set ] + [ [ nip dup ] H{ } assoc-map-as locs set ] + [ keys [ init-to-do ] [ init-ready ] bi ] tri ; -: break-cycle ( dst src -- dst src' ) - [ i dup ] dip ##copy ; +:: process-ready ( b quot -- ) + b preds get at :> a + a locs get at :> c + b c quot call + b a locs get set-at + a c = a preds get at and [ a ready get push-front ] when ; inline -: break-cycles ( mapping -- ) - >alist [ break-cycle ] { } assoc-map-as [ ##copy ] assoc-each ; +:: process-to-do ( b quot -- ) + ! Note that we check if b = loc(b), not b = loc(pred(b)) as the + ! paper suggests. Confirmed by one of the authors at + ! http://www.reddit.com/comments/93253/some_lecture_notes_on_ssa_form/c0bco4f + b locs get at b = [ + temp get b quot call + temp get b locs get set-at + b ready get push-front + ] when ; inline -: parallel-copy ( mapping -- ) +PRIVATE> + +:: parallel-mapping ( mapping temp quot -- ) [ - init [ perform-copy ] slurp-deque - mapping get dup assoc-empty? [ drop ] [ break-cycles ] if - ] with-scope ; \ No newline at end of file + mapping temp init + to-do get [ + ready get [ + quot process-ready + ] slurp-deque + quot process-to-do + ] slurp-deque + ] with-scope ; inline + +: parallel-copy ( mapping -- ) i [ ##copy ] parallel-mapping ; \ No newline at end of file From c5d7ed58a5451ad508a307acae4f908009717aba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 19:24:13 -0500 Subject: [PATCH 44/81] Debugging compiler.cfg.coalescing --- .../compiler/cfg/builder/builder-tests.factor | 40 ++++++++++++- .../compiler/cfg/coalescing/coalescing.factor | 2 +- .../cfg/coalescing/copies/copies.factor | 4 +- .../cfg/coalescing/renaming/renaming.factor | 36 ++++++++---- .../cfg/dominance/dominance-tests.factor | 1 + .../cfg/optimizer/optimizer-tests.factor | 58 ------------------- 6 files changed, 68 insertions(+), 73 deletions(-) diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 812ef18e86..2de7c7c3d1 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -3,7 +3,8 @@ USING: tools.test kernel sequences words sequences.private fry prettyprint alien alien.accessors math.private compiler.tree.builder compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker -arrays locals byte-arrays kernel.private math slots.private ; +arrays locals byte-arrays kernel.private math slots.private vectors sbufs +strings math.partial-dispatch strings.private ; ! Just ensure that various CFGs build correctly. : unit-test-cfg ( quot -- ) @@ -18,6 +19,13 @@ arrays locals byte-arrays kernel.private math slots.private ; ] if ] any? ; inline recursive +: more? ( x -- ? ) ; + +: test-case-1 ( -- ? ) f ; + +: test-case-2 ( -- ) + test-case-1 [ test-case-2 ] [ ] if ; inline recursive + { [ ] [ dup ] @@ -62,6 +70,36 @@ arrays locals byte-arrays kernel.private math slots.private ; [ swap - + * ] [ swap slot ] [ blahblah ] + [ 1000 [ dup [ reverse ] when ] times ] + [ 1array ] + [ 1 2 ? ] + [ { array } declare [ ] map ] + [ { array } declare dup 1 slot [ 1 slot ] when ] + [ [ dup more? ] [ dup ] produce ] + [ vector new over test-case-1 [ test-case-2 ] [ ] if ] + [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ] + [ + { fixnum sbuf } declare 2dup 3 slot fixnum> [ + over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot + ] [ ] if + ] + [ [ 2 fixnum* ] when 3 ] + [ [ 2 fixnum+ ] when 3 ] + [ [ 2 fixnum- ] when 3 ] + [ 10000 [ ] times ] + [ + over integer? [ + over dup 16 <-integer-fixnum + [ 0 >=-integer-fixnum ] [ drop f ] if [ + nip dup + [ ] [ ] if + ] [ 2drop f ] if + ] [ 2drop f ] if + ] + [ + pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if + set-string-nth-fast + ] } [ unit-test-cfg ] each diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor index afb364f4fe..28528068c2 100644 --- a/basis/compiler/cfg/coalescing/coalescing.factor +++ b/basis/compiler/cfg/coalescing/coalescing.factor @@ -54,6 +54,6 @@ SYMBOL: seen dup compute-dfs dup process-blocks break-interferences - insert-copies dup perform-renaming + insert-copies dup remove-phis ; \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/coalescing/copies/copies.factor index 86f9e12423..ab1c514c96 100644 --- a/basis/compiler/cfg/coalescing/copies/copies.factor +++ b/basis/compiler/cfg/coalescing/copies/copies.factor @@ -7,11 +7,11 @@ IN: compiler.cfg.coalescing.copies : compute-copies ( assoc -- assoc' ) dup assoc-size [ '[ - [ _ set-at ] with each + [ _ 2dup key? [ "OOPS" throw ] [ set-at ] if ] with each ] assoc-each ] keep ; -: insert-copies ( cfg -- ) +: insert-copies ( -- ) waiting get [ [ instructions>> building ] dip '[ building get pop diff --git a/basis/compiler/cfg/coalescing/renaming/renaming.factor b/basis/compiler/cfg/coalescing/renaming/renaming.factor index bad74807d0..848d0a4df0 100644 --- a/basis/compiler/cfg/coalescing/renaming/renaming.factor +++ b/basis/compiler/cfg/coalescing/renaming/renaming.factor @@ -5,29 +5,43 @@ compiler.cfg.coalescing.state compiler.cfg.renaming compiler.cfg.rpo disjoint-sets ; IN: compiler.cfg.coalescing.renaming +: build-disjoint-set ( assoc -- disjoint-set ) + dup [ + '[ + [ _ add-atom ] + [ [ drop _ add-atom ] assoc-each ] + bi* + ] assoc-each + ] keep ; + : update-congruence-class ( dst assoc disjoint-set -- ) - [ keys swap ] dip - [ nip add-atoms ] - [ add-atom drop ] - [ equate-all-with ] 3tri ; + [ keys swap ] dip equate-all-with ; : build-congruence-classes ( -- disjoint-set ) renaming-sets get - [ - '[ - _ update-congruence-class - ] assoc-each - ] keep ; + dup build-disjoint-set + [ '[ _ update-congruence-class ] assoc-each ] keep ; : compute-renaming ( disjoint-set -- assoc ) [ parents>> ] keep '[ drop dup _ representative ] assoc-map ; -: perform-renaming ( cfg -- ) - build-congruence-classes compute-renaming renamings set +: rename-blocks ( cfg -- ) [ instructions>> [ [ rename-insn-defs ] [ rename-insn-uses ] bi ] each ] each-basic-block ; + +: rename-copies ( -- ) + waiting renamings get '[ + [ + [ _ [ ?at drop ] [ '[ _ ?at drop ] map ] bi-curry bi* ] assoc-map + ] assoc-map + ] change ; + +: perform-renaming ( cfg -- ) + build-congruence-classes compute-renaming renamings set + rename-blocks + rename-copies ; diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor index 0d4513c848..3da98a5e87 100644 --- a/basis/compiler/cfg/dominance/dominance-tests.factor +++ b/basis/compiler/cfg/dominance/dominance-tests.factor @@ -7,6 +7,7 @@ compiler.cfg.predecessors ; cfg new 0 get >>entry compute-predecessors dup compute-dominance + dup compute-dom-frontiers compute-dfs ; ! Example with no back edges diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index 695a586199..e69de29bb2 100755 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -1,58 +0,0 @@ -USING: accessors arrays compiler.cfg.checker compiler.cfg.debugger -compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.optimizer -fry kernel kernel.private math math.partial-dispatch math.private -sbufs sequences sequences.private sets slots.private strings -strings.private tools.test vectors layouts ; -IN: compiler.cfg.optimizer.tests - -! Miscellaneous tests - -: more? ( x -- ? ) ; - -: test-case-1 ( -- ? ) f ; - -: test-case-2 ( -- ) - test-case-1 [ test-case-2 ] [ ] if ; inline recursive - -{ - [ 1array ] - [ 1 2 ? ] - [ { array } declare [ ] map ] - [ { array } declare dup 1 slot [ 1 slot ] when ] - [ [ dup more? ] [ dup ] produce ] - [ vector new over test-case-1 [ test-case-2 ] [ ] if ] - [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ] - [ - { fixnum sbuf } declare 2dup 3 slot fixnum> [ - over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot - ] [ ] if - ] - [ [ 2 fixnum* ] when 3 ] - [ [ 2 fixnum+ ] when 3 ] - [ [ 2 fixnum- ] when 3 ] - [ 10000 [ ] times ] - [ - over integer? [ - over dup 16 <-integer-fixnum - [ 0 >=-integer-fixnum ] [ drop f ] if [ - nip dup - [ ] [ ] if - ] [ 2drop f ] if - ] [ 2drop f ] if - ] - [ - pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if - set-string-nth-fast - ] -} [ - [ [ ] ] dip '[ _ test-cfg first optimize-cfg check-cfg ] unit-test -] each - -cell 8 = [ - [ t ] - [ - [ - 1 50 fixnum-shift-fast fixnum+fast - ] test-mr first instructions>> [ ##add? ] any? - ] unit-test -] when From 7493e07c685d906b75c90f8cf2406585eee7574a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 27 Jul 2009 22:14:26 -0500 Subject: [PATCH 45/81] disassemble method for byte-arrays. HEX{ abcd } syntax for byte-arrays --- basis/tools/disassembler/disassembler.factor | 12 ++++++++++-- core/byte-arrays/byte-arrays-docs.factor | 4 ++++ core/byte-arrays/byte-arrays.factor | 11 +++++++++-- 3 files changed, 23 insertions(+), 4 deletions(-) diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor index 744318a0a4..0a8ab0b116 100755 --- a/basis/tools/disassembler/disassembler.factor +++ b/basis/tools/disassembler/disassembler.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: tr arrays sequences io words generic system combinators -vocabs.loader kernel ; +USING: alien alien.c-types arrays byte-arrays combinators +destructors generic io kernel libc math sequences system tr +vocabs.loader words ; IN: tools.disassembler GENERIC: disassemble ( obj -- ) @@ -12,6 +13,13 @@ HOOK: disassemble* disassembler-backend ( from to -- lines ) TR: tabs>spaces "\t" "\s" ; +M: byte-array disassemble + [ + [ malloc-byte-array &free alien-address dup ] + [ length + ] bi + 2array disassemble + ] with-destructors ; + M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ; M: word disassemble word-xt 2array disassemble ; diff --git a/core/byte-arrays/byte-arrays-docs.factor b/core/byte-arrays/byte-arrays-docs.factor index f1d94a46f7..56832a56e5 100644 --- a/core/byte-arrays/byte-arrays-docs.factor +++ b/core/byte-arrays/byte-arrays-docs.factor @@ -23,6 +23,10 @@ $nl ABOUT: "byte-arrays" +HELP: HEX{ +{ $syntax "HEX{ 0123 45 67 89abcdef }" } +{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored." } ; + HELP: byte-array { $description "The class of byte arrays. See " { $link "syntax-byte-arrays" } " for syntax and " { $link "byte-arrays" } " for general information." } ; diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 72989ac447..b32060ec99 100644 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -1,9 +1,16 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel kernel.private alien.accessors sequences -sequences.private math ; +USING: accessors alien.accessors ascii grouping kernel +kernel.private lexer math math.parser parser sequences +sequences.private ; IN: byte-arrays +SYNTAX: HEX{ + "}" parse-tokens "" join + [ blank? not ] filter + 2 group [ hex> ] B{ } map-as + parsed ; + M: byte-array clone (clone) ; M: byte-array length length>> ; M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; From bfb2a4c1fc84e8d457a156b97febcb83ea40b0c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 22:27:54 -0500 Subject: [PATCH 46/81] cpu.x86: compile a load of zero, and adds, subs where dst = src1 more efficiently --- basis/cpu/x86/x86.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 6b4a93885c..258f842598 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -56,7 +56,7 @@ HOOK: param-reg-2 cpu ( -- reg ) HOOK: pic-tail-reg cpu ( -- reg ) -M: x86 %load-immediate MOV ; +M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ; M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ; @@ -108,10 +108,10 @@ M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ; M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ; M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ; -M: x86 %add [+] LEA ; -M: x86 %add-imm [+] LEA ; +M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ; +M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ; M: x86 %sub nip SUB ; -M: x86 %sub-imm neg [+] LEA ; +M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ; M: x86 %mul nip swap IMUL2 ; M: x86 %mul-imm IMUL3 ; M: x86 %and nip AND ; From 423d2996fae49f176d065de6ac6392334f25b4d9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 22:28:13 -0500 Subject: [PATCH 47/81] compiler.cfg.debugger: reset vreg counters --- basis/compiler/cfg/debugger/debugger.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 18f1b3be76..3c6ea1f0e4 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -14,9 +14,11 @@ IN: compiler.cfg.debugger GENERIC: test-cfg ( quot -- cfgs ) M: callable test-cfg + 0 vreg-counter set-global build-tree optimize-tree gensym build-cfg ; M: word test-cfg + 0 vreg-counter set-global [ build-tree optimize-tree ] keep build-cfg ; : test-mr ( quot -- mrs ) From e8cf50ac3ee99a5f1704b52e46e61d3bbfed9a6d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 22:28:29 -0500 Subject: [PATCH 48/81] compiler.cfg.two-operand: make it work in more cases --- .../cfg/two-operand/two-operand-tests.factor | 45 +++++++ .../cfg/two-operand/two-operand.factor | 127 ++++++++++++------ 2 files changed, 131 insertions(+), 41 deletions(-) create mode 100644 basis/compiler/cfg/two-operand/two-operand-tests.factor diff --git a/basis/compiler/cfg/two-operand/two-operand-tests.factor b/basis/compiler/cfg/two-operand/two-operand-tests.factor new file mode 100644 index 0000000000..0d0c57e0f7 --- /dev/null +++ b/basis/compiler/cfg/two-operand/two-operand-tests.factor @@ -0,0 +1,45 @@ +IN: compiler.cfg.two-operand.tests +USING: compiler.cfg.two-operand compiler.cfg.instructions +compiler.cfg.registers cpu.architecture namespaces tools.test ; + +3 vreg-counter set-global + +[ + V{ + T{ ##copy f V int-regs 1 V int-regs 2 } + T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 3 } + } +] [ + { + T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 3 } + } (convert-two-operand) +] unit-test + +[ + V{ + T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 } + } +] [ + { + T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 } + } (convert-two-operand) +] unit-test + +[ + V{ + T{ ##copy f V int-regs 4 V int-regs 2 } + T{ ##sub f V int-regs 4 V int-regs 4 V int-regs 1 } + T{ ##copy f V int-regs 1 V int-regs 4 } + } +] [ + { + T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 1 } + } (convert-two-operand) +] unit-test + +! This should never come up after coalescing +[ + V{ + T{ ##fixnum-add f V int-regs 2 V int-regs 4 V int-regs 2 } + } (convert-two-operand) +] must-fail diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index 0a52aa7c1a..db3462bf0d 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -1,59 +1,104 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences make compiler.cfg.instructions +USING: accessors kernel sequences make combinators +compiler.cfg.registers compiler.cfg.instructions compiler.cfg.rpo cpu.architecture ; IN: compiler.cfg.two-operand -! On x86, instructions take the form x = x op y -! Our SSA IR is x = y op z +! This pass runs after SSA coalescing and normalizes instructions +! to fit the x86 two-address scheme. Possibilities are: + +! 1) x = x op y +! 2) x = y op x +! 3) x = y op z + +! In case 1, there is nothing to do. + +! In case 2, we convert to +! z = y +! z = z op x +! x = z + +! In case 3, we convert to +! x = y +! x = x op z + +! In case 2 and case 3, linear scan coalescing will eliminate a +! copy if the value y is never used again. ! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm ! since x86 has LEA and IMUL instructions which are effectively ! three-operand addition and multiplication, respectively. -: convert-two-operand/integer ( insn -- ) - [ [ dst>> ] [ src1>> ] bi ##copy ] - [ dup dst>> >>src1 , ] - bi ; inline - -: convert-two-operand/float ( insn -- ) - [ [ dst>> ] [ src1>> ] bi ##copy-float ] - [ dup dst>> >>src1 , ] - bi ; inline +UNION: two-operand-insn + ##sub + ##mul + ##and + ##and-imm + ##or + ##or-imm + ##xor + ##xor-imm + ##shl + ##shl-imm + ##shr + ##shr-imm + ##sar + ##sar-imm + ##fixnum-overflow + ##add-float + ##sub-float + ##mul-float + ##div-float ; GENERIC: convert-two-operand* ( insn -- ) +: emit-copy ( dst src -- ) + dup reg-class>> { + { int-regs [ ##copy ] } + { double-float-regs [ ##copy-float ] } + } case ; inline + +: case-1? ( insn -- ? ) [ dst>> ] [ src1>> ] bi = ; inline + +: case-1 ( insn -- ) , ; inline + +: case-2? ( insn -- ? ) [ dst>> ] [ src2>> ] bi = ; inline + +ERROR: bad-case-2 insn ; + +: case-2 ( insn -- ) + ! This can't work with a ##fixnum-overflow since it branches + dup ##fixnum-overflow? [ bad-case-2 ] when + dup dst>> reg-class>> next-vreg + [ swap src1>> emit-copy ] + [ [ >>src1 ] [ >>dst ] bi , ] + [ [ src2>> ] dip emit-copy ] + 2tri ; inline + +: case-3 ( insn -- ) + [ [ dst>> ] [ src1>> ] bi emit-copy ] + [ dup dst>> >>src1 , ] + bi ; inline + +M: two-operand-insn convert-two-operand* + { + { [ dup case-1? ] [ case-1 ] } + { [ dup case-2? ] [ case-2 ] } + [ case-3 ] + } cond ; inline + M: ##not convert-two-operand* - [ [ dst>> ] [ src>> ] bi ##copy ] - [ dup dst>> >>src , ] - bi ; - -M: ##sub convert-two-operand* convert-two-operand/integer ; -M: ##mul convert-two-operand* convert-two-operand/integer ; -M: ##and convert-two-operand* convert-two-operand/integer ; -M: ##and-imm convert-two-operand* convert-two-operand/integer ; -M: ##or convert-two-operand* convert-two-operand/integer ; -M: ##or-imm convert-two-operand* convert-two-operand/integer ; -M: ##xor convert-two-operand* convert-two-operand/integer ; -M: ##xor-imm convert-two-operand* convert-two-operand/integer ; -M: ##shl convert-two-operand* convert-two-operand/integer ; -M: ##shl-imm convert-two-operand* convert-two-operand/integer ; -M: ##shr convert-two-operand* convert-two-operand/integer ; -M: ##shr-imm convert-two-operand* convert-two-operand/integer ; -M: ##sar convert-two-operand* convert-two-operand/integer ; -M: ##sar-imm convert-two-operand* convert-two-operand/integer ; - -M: ##fixnum-overflow convert-two-operand* convert-two-operand/integer ; - -M: ##add-float convert-two-operand* convert-two-operand/float ; -M: ##sub-float convert-two-operand* convert-two-operand/float ; -M: ##mul-float convert-two-operand* convert-two-operand/float ; -M: ##div-float convert-two-operand* convert-two-operand/float ; + dup [ dst>> ] [ src>> ] bi = [ + [ [ dst>> ] [ src>> ] bi ##copy ] + [ dup dst>> >>src ] + bi + ] unless , ; M: insn convert-two-operand* , ; +: (convert-two-operand) ( cfg -- cfg' ) + [ [ convert-two-operand* ] each ] V{ } make ; + : convert-two-operand ( cfg -- cfg' ) - two-operand? [ - [ [ [ convert-two-operand* ] each ] V{ } make ] - local-optimization - ] when ; + two-operand? [ [ (convert-two-operand) ] local-optimization ] when ; \ No newline at end of file From 3cc71a1934b20a2c1a89f0079e49c8fea39a6397 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 22:29:17 -0500 Subject: [PATCH 49/81] compiler.cfg.coalescing: precompute live intervals, add support for instructions where output cannot equal an input, split critical edges --- .../compiler/cfg/coalescing/coalescing.factor | 4 ++ .../cfg/coalescing/copies/copies.factor | 2 +- .../interference/interference.factor | 32 ++++---------- .../coalescing/live-ranges/live-ranges.factor | 42 +++++++++++++++++++ .../cfg/critical-edges/critical-edges.factor | 19 +++++++++ .../cfg/instructions/instructions.factor | 7 ++++ 6 files changed, 81 insertions(+), 25 deletions(-) create mode 100644 basis/compiler/cfg/coalescing/live-ranges/live-ranges.factor create mode 100644 basis/compiler/cfg/critical-edges/critical-edges.factor diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor index 28528068c2..a9637088a3 100644 --- a/basis/compiler/cfg/coalescing/coalescing.factor +++ b/basis/compiler/cfg/coalescing/coalescing.factor @@ -7,10 +7,12 @@ compiler.cfg.def-use compiler.cfg.utilities compiler.cfg.dominance compiler.cfg.instructions +compiler.cfg.critical-edges compiler.cfg.coalescing.state compiler.cfg.coalescing.forest compiler.cfg.coalescing.copies compiler.cfg.coalescing.renaming +compiler.cfg.coalescing.live-ranges compiler.cfg.coalescing.process-blocks ; IN: compiler.cfg.coalescing @@ -49,9 +51,11 @@ SYMBOL: seen : coalesce ( cfg -- cfg' ) init-coalescing + dup split-critical-edges dup compute-def-use dup compute-dominance dup compute-dfs + dup compute-live-ranges dup process-blocks break-interferences dup perform-renaming diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/coalescing/copies/copies.factor index ab1c514c96..5df2684f72 100644 --- a/basis/compiler/cfg/coalescing/copies/copies.factor +++ b/basis/compiler/cfg/coalescing/copies/copies.factor @@ -7,7 +7,7 @@ IN: compiler.cfg.coalescing.copies : compute-copies ( assoc -- assoc' ) dup assoc-size [ '[ - [ _ 2dup key? [ "OOPS" throw ] [ set-at ] if ] with each + [ 2dup eq? [ 2drop ] [ _ 2dup key? [ "OOPS" throw ] [ set-at ] if ] if ] with each ] assoc-each ] keep ; diff --git a/basis/compiler/cfg/coalescing/interference/interference.factor b/basis/compiler/cfg/coalescing/interference/interference.factor index 9fdf06bcb4..ff5e6319e6 100644 --- a/basis/compiler/cfg/coalescing/interference/interference.factor +++ b/basis/compiler/cfg/coalescing/interference/interference.factor @@ -2,48 +2,32 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators combinators.short-circuit kernel math namespaces sequences locals compiler.cfg.def-use -compiler.cfg.liveness compiler.cfg.dominance ; +compiler.cfg.dominance compiler.cfg.coalescing.live-ranges ; IN: compiler.cfg.coalescing.interference -! Local interference testing. Requires live-out information > [ - [ swap defs-vregs [ def-index get set-at ] with each ] - [ swap uses-vregs [ kill-index get set-at ] with each ] - 2bi - ] each-index - ] - [ live-out keys [ [ 1/0. ] dip kill-index get set-at ] each ] - bi ; - -: kill-after-def? ( vreg1 vreg2 -- ? ) +: kill-after-def? ( vreg1 vreg2 bb -- ? ) ! If first register is killed after second one is defined, they interfere - [ kill-index get at ] [ def-index get at ] bi* >= ; + [ kill-index ] [ def-index ] bi-curry bi* >= ; : interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? ) ! If both are defined in the same basic block, they interfere if their ! local live ranges intersect. - drop compute-local-live-ranges - { [ kill-after-def? ] [ swap kill-after-def? ] } 2|| ; + drop + { [ kill-after-def? ] [ swapd kill-after-def? ] } 3|| ; : interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? ) ! If vreg1 dominates vreg2, then they interfere if vreg2's definition ! occurs before vreg1 is killed. - nip compute-local-live-ranges + nip kill-after-def? ; : interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? ) ! If vreg2 dominates vreg1, then they interfere if vreg1's definition ! occurs before vreg2 is killed. - drop compute-local-live-ranges - swap kill-after-def? ; + drop + swapd kill-after-def? ; PRIVATE> diff --git a/basis/compiler/cfg/coalescing/live-ranges/live-ranges.factor b/basis/compiler/cfg/coalescing/live-ranges/live-ranges.factor new file mode 100644 index 0000000000..f35a752ea6 --- /dev/null +++ b/basis/compiler/cfg/coalescing/live-ranges/live-ranges.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel namespaces sequences +compiler.cfg.def-use compiler.cfg.instructions +compiler.cfg.liveness compiler.cfg.rpo ; +IN: compiler.cfg.coalescing.live-ranges + +! Live ranges for interference testing + +> [ visit-insn ] each-index ; + +PRIVATE> + +: compute-live-ranges ( cfg -- ) + [ compute-local-live-ranges ] each-basic-block ; + +: def-index ( vreg bb -- n ) + def-indices get at at ; + +: kill-index ( vreg bb -- n ) + 2dup live-out key? [ 2drop 1/0. ] [ kill-indices get at at ] if ; diff --git a/basis/compiler/cfg/critical-edges/critical-edges.factor b/basis/compiler/cfg/critical-edges/critical-edges.factor new file mode 100644 index 0000000000..92b4f801d6 --- /dev/null +++ b/basis/compiler/cfg/critical-edges/critical-edges.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math accessors sequences +compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ; +IN: compiler.cfg.critical-edges + +: critical-edge? ( from to -- ? ) + [ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ; + +: split-critical-edge ( from to -- ) + f insert-basic-block ; + +: split-critical-edges ( cfg -- ) + [ + dup successors>> [ + 2dup critical-edge? + [ split-critical-edge ] [ 2drop ] if + ] with each + ] each-basic-block ; \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 07ebcc3ba9..066d20ddec 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -251,3 +251,10 @@ UNION: kill-vreg-insn ##alien-invoke ##alien-indirect ##alien-callback ; + +! Instructions that have complex expansions and require that the +! output registers are not equal to any of the input registers +UNION: def-is-use-insn + ##integer>bignum + ##bignum>integer + ##unbox-any-c-ptr ; \ No newline at end of file From cf90945b4c9ee9bbecf37ab36bed734ed675757a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 27 Jul 2009 22:29:33 -0500 Subject: [PATCH 50/81] Add some tests that directly generate low level IR --- basis/compiler/tests/low-level-ir.factor | 133 +++++++++++++++++++++++ 1 file changed, 133 insertions(+) create mode 100644 basis/compiler/tests/low-level-ir.factor diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor new file mode 100644 index 0000000000..313fd65dac --- /dev/null +++ b/basis/compiler/tests/low-level-ir.factor @@ -0,0 +1,133 @@ +USING: accessors assocs compiler compiler.cfg +compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr +compiler.cfg.registers compiler.codegen compiler.units +cpu.architecture hashtables kernel namespaces sequences +tools.test vectors words layouts literals math arrays +alien.syntax ; +IN: compiler.tests + +: compile-cfg ( cfg -- word ) + gensym + [ build-mr generate code>> ] dip + [ associate >alist modify-code-heap ] keep ; + +: compile-test-cfg ( -- word ) + cfg new + 0 get >>entry + compile-cfg ; + +: compile-test-bb ( insns -- result ) + V{ T{ ##prologue } T{ ##branch } } 0 test-bb + V{ + T{ ##inc-d f 1 } + T{ ##replace f V int-regs 0 D 0 } + T{ ##branch } + } append 1 test-bb + V{ + T{ ##epilogue } + T{ ##return } + } 2 test-bb + 0 get 1 get 1vector >>successors drop + 1 get 2 get 1vector >>successors drop + compile-test-cfg + execute( -- result ) ; + +! loading immediates +[ f ] [ + V{ + T{ ##load-immediate f V int-regs 0 5 } + } compile-test-bb +] unit-test + +[ "hello" ] [ + V{ + T{ ##load-reference f V int-regs 0 "hello" } + } compile-test-bb +] unit-test + +! make sure slot access works when the destination is +! one of the sources +[ t ] [ + V{ + T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] } + T{ ##load-reference f V int-regs 0 { t f t } } + T{ ##slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 } + } compile-test-bb +] unit-test + +[ t ] [ + V{ + T{ ##load-reference f V int-regs 0 { t f t } } + T{ ##slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] V int-regs 2 } + } compile-test-bb +] unit-test + +[ t ] [ + V{ + T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] } + T{ ##load-reference f V int-regs 0 { t f t } } + T{ ##set-slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 } + } compile-test-bb + dup first eq? +] unit-test + +[ t ] [ + V{ + T{ ##load-reference f V int-regs 0 { t f t } } + T{ ##set-slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] } + } compile-test-bb + dup first eq? +] unit-test + +[ 8 ] [ + V{ + T{ ##load-immediate f V int-regs 0 4 } + T{ ##shl f V int-regs 0 V int-regs 0 V int-regs 0 } + } compile-test-bb +] unit-test + +[ 4 ] [ + V{ + T{ ##load-immediate f V int-regs 0 4 } + T{ ##shl-imm f V int-regs 0 V int-regs 0 3 } + } compile-test-bb +] unit-test + +[ 31 ] [ + V{ + T{ ##load-reference f V int-regs 1 B{ 31 67 52 } } + T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 1 V int-regs 2 } + T{ ##alien-unsigned-1 f V int-regs 0 V int-regs 0 } + T{ ##shl-imm f V int-regs 0 V int-regs 0 3 } + } compile-test-bb +] unit-test + +[ CHAR: l ] [ + V{ + T{ ##load-reference f V int-regs 0 "hello world" } + T{ ##load-immediate f V int-regs 1 3 } + T{ ##string-nth f V int-regs 0 V int-regs 0 V int-regs 1 V int-regs 2 } + T{ ##shl-imm f V int-regs 0 V int-regs 0 3 } + } compile-test-bb +] unit-test + +! These are def-is-use-insns +USE: multiline + +/* + +[ 100 ] [ + V{ + T{ ##load-immediate f V int-regs 0 100 } + T{ ##integer>bignum f V int-regs 0 V int-regs 0 V int-regs 1 } + } compile-test-bb +] unit-test + +[ 1 ] [ + V{ + T{ ##load-reference f V int-regs 0 ALIEN: 8 } + T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 0 V int-regs 1 } + } compile-test-bb +] unit-test + +*/ \ No newline at end of file From 5372113fce5fbb8005a6f00662b5d82d638da1d4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 28 Jul 2009 00:22:27 -0500 Subject: [PATCH 51/81] =?UTF-8?q?SSE1=E2=80=93SSSE3=20opcodes=20+=20branch?= =?UTF-8?q?=20hints=20for=20x86=20assembler?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../cpu/x86/assembler/assembler-tests.factor | 53 ++++ basis/cpu/x86/assembler/assembler.factor | 265 ++++++++++++++++-- 2 files changed, 299 insertions(+), 19 deletions(-) diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index a8c54fa65e..d2dd73779a 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -8,6 +8,32 @@ IN: cpu.x86.assembler.tests [ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test [ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test +! r-rm / m-r sse instruction +[ { HEX: 0f HEX: 10 HEX: c1 } ] [ [ XMM0 XMM1 MOVUPS ] { } make ] unit-test +[ { HEX: 0f HEX: 10 HEX: 01 } ] [ [ XMM0 ECX [] MOVUPS ] { } make ] unit-test +[ { HEX: 0f HEX: 11 HEX: 08 } ] [ [ EAX [] XMM1 MOVUPS ] { } make ] unit-test + +[ { HEX: f3 HEX: 0f HEX: 10 HEX: c1 } ] [ [ XMM0 XMM1 MOVSS ] { } make ] unit-test +[ { HEX: f3 HEX: 0f HEX: 10 HEX: 01 } ] [ [ XMM0 ECX [] MOVSS ] { } make ] unit-test +[ { HEX: f3 HEX: 0f HEX: 11 HEX: 08 } ] [ [ EAX [] XMM1 MOVSS ] { } make ] unit-test + +[ { HEX: 66 HEX: 0f HEX: 6f HEX: c1 } ] [ [ XMM0 XMM1 MOVDQA ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 6f HEX: 01 } ] [ [ XMM0 ECX [] MOVDQA ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 7f HEX: 08 } ] [ [ EAX [] XMM1 MOVDQA ] { } make ] unit-test + +! r-rm only sse instruction +[ { HEX: 66 HEX: 0f HEX: 2e HEX: c1 } ] [ [ XMM0 XMM1 UCOMISD ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 2e HEX: 01 } ] [ [ XMM0 ECX [] UCOMISD ] { } make ] unit-test +[ [ EAX [] XMM1 UCOMISD ] { } make ] must-fail + +! rm-r only sse instructions +[ { HEX: 0f HEX: 2b HEX: 08 } ] [ [ EAX [] XMM1 MOVNTPS ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: e7 HEX: 08 } ] [ [ EAX [] XMM1 MOVNTDQ ] { } make ] unit-test + +! three-byte-opcode ssse3 instruction +[ { HEX: 66 HEX: 0f HEX: 38 HEX: 02 HEX: c1 } ] [ [ XMM0 XMM1 PHADDD ] { } make ] unit-test + +! int/sse conversion instruction [ { HEX: f2 HEX: 0f HEX: 2c HEX: c0 } ] [ [ EAX XMM0 CVTTSD2SI ] { } make ] unit-test [ { HEX: f2 HEX: 48 HEX: 0f HEX: 2c HEX: c0 } ] [ [ RAX XMM0 CVTTSD2SI ] { } make ] unit-test [ { HEX: f2 HEX: 4c HEX: 0f HEX: 2c HEX: e0 } ] [ [ R12 XMM0 CVTTSD2SI ] { } make ] unit-test @@ -25,6 +51,32 @@ IN: cpu.x86.assembler.tests ! [ { HEX: f2 HEX: 0f HEX: 11 HEX: 00 } ] [ [ RAX [] XMM0 MOVSD ] { } make ] unit-test ! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 11 HEX: 04 HEX: 24 } ] [ [ R12 [] XMM0 MOVSD ] { } make ] unit-test +! 3-operand r-rm-imm sse instructions +[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test +[ { HEX: 0f HEX: c6 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 SHUFPS ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: c4 HEX: c1 HEX: 02 } ] [ [ XMM0 ECX 2 PINSRW ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: c5 HEX: c1 HEX: 02 } ] [ [ EAX XMM1 2 PEXTRW ] { } make ] unit-test + +! sse shift instructions +[ { HEX: 66 HEX: 0f HEX: 71 HEX: d0 HEX: 05 } ] [ [ XMM0 5 PSRLW ] { } make ] unit-test + +! sse comparison instructions +[ { HEX: 66 HEX: 0f HEX: c2 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 CMPLEPD ] { } make ] unit-test + +! unique sse instructions +[ { HEX: 0f HEX: 18 HEX: 00 } ] [ [ EAX [] PREFETCHNTA ] { } make ] unit-test +[ { HEX: 0f HEX: 18 HEX: 08 } ] [ [ EAX [] PREFETCHT0 ] { } make ] unit-test +[ { HEX: 0f HEX: 18 HEX: 10 } ] [ [ EAX [] PREFETCHT1 ] { } make ] unit-test +[ { HEX: 0f HEX: 18 HEX: 18 } ] [ [ EAX [] PREFETCHT2 ] { } make ] unit-test +[ { HEX: 0f HEX: ae HEX: 10 } ] [ [ EAX [] LDMXCSR ] { } make ] unit-test +[ { HEX: 0f HEX: ae HEX: 18 } ] [ [ EAX [] STMXCSR ] { } make ] unit-test + +[ { HEX: 0f HEX: c3 HEX: 08 } ] [ [ EAX [] ECX MOVNTI ] { } make ] unit-test + +[ { HEX: 0f HEX: 50 HEX: c1 } ] [ [ EAX XMM1 MOVMSKPS ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 50 HEX: c1 } ] [ [ EAX XMM1 MOVMSKPD ] { } make ] unit-test + +! memory address modes [ { HEX: 8a HEX: 18 } ] [ [ BL RAX [] MOV ] { } make ] unit-test [ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX RAX [] MOV ] { } make ] unit-test [ { HEX: 8b HEX: 18 } ] [ [ EBX RAX [] MOV ] { } make ] unit-test @@ -72,3 +124,4 @@ IN: cpu.x86.assembler.tests [ { HEX: 48 HEX: 69 HEX: c1 HEX: 44 HEX: 03 HEX: 00 HEX: 00 } ] [ [ RAX RCX HEX: 344 IMUL3 ] { } make ] unit-test [ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test + diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 95b85ac2dd..237ef8154d 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -3,6 +3,7 @@ USING: arrays io.binary kernel combinators kernel.private math namespaces make sequences words system layouts math.order accessors cpu.x86.assembler.syntax ; +QUALIFIED: sequences IN: cpu.x86.assembler ! A postfix assembler for x86-32 and x86-64. @@ -12,11 +13,16 @@ IN: cpu.x86.assembler ! Beware! ! Register operands -- eg, ECX -REGISTERS: 8 AL CL DL BL ; +REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ; -REGISTERS: 16 AX CX DX BX SP BP SI DI ; +ALIAS: AH SPL +ALIAS: CH BPL +ALIAS: DH SIL +ALIAS: BH DIL -REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ; +REGISTERS: 16 AX CX DX BX SP BP SI DI R8W R9W R10W R11W R12W R13W R14W R15W ; + +REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI R8D R9D R10D R11D R12D R13D R14D R15D ; REGISTERS: 64 RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ; @@ -214,6 +220,8 @@ M: object operand-64? drop f ; : extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ; +: ssse3-opcode ( opcode -- opcode' ) OCT: 17 sequences:prefix ; + : extended-opcode, ( opcode -- ) extended-opcode opcode, ; : opcode-or ( opcode mask -- opcode' ) @@ -451,6 +459,9 @@ M: operand TEST OCT: 204 2-operand ; ! Misc : NOP ( -- ) HEX: 90 , ; +: PAUSE ( -- ) HEX: f3 , HEX: 90 , ; + +: RDPMC ( -- ) HEX: 0f , HEX: 33 , ; ! x87 Floating Point Unit @@ -468,26 +479,242 @@ M: operand TEST OCT: 204 2-operand ; pick register-128? [ swapd ] [ BIN: 1 bitor ] if ; : 2-operand-sse ( dst src op1 op2 -- ) - , direction-bit-sse extended-opcode (2-operand) ; + [ , ] when* direction-bit-sse extended-opcode (2-operand) ; + +: direction-op-sse ( dst src op1s -- dst' src' op1' ) + pick register-128? [ swapd first ] [ second ] if ; + +: 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- ) + [ , ] when* direction-op-sse extended-opcode (2-operand) ; + +: 2-operand-ssse3 ( dst src op1 op2 -- ) + [ , ] when* swapd ssse3-opcode (2-operand) ; + +: 2-operand-rm-sse ( dst src op1 op2 -- ) + [ , ] when* swapd extended-opcode (2-operand) ; + +: 2-operand-mr-sse ( dst src op1 op2 -- ) + [ , ] when* extended-opcode (2-operand) ; : 2-operand-int/sse ( dst src op1 op2 -- ) - , swapd extended-opcode (2-operand) ; + [ , ] when* swapd extended-opcode (2-operand) ; + +: 3-operand-sse ( dst src imm op1 op2 -- ) + rot [ 2-operand-rm-sse ] dip , ; + +: 2-operand-sse-cmp ( dst src cmp op1 op2 -- ) + 3-operand-sse ; inline + +: 2-operand-sse-shift ( dst imm reg op1 op2 -- ) + [ , ] when* + [ f HEX: 0f ] dip 2array 3array + swapd 1-operand , ; PRIVATE> -: MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ; -: MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ; -: ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-sse ; -: MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-sse ; -: SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-sse ; -: DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-sse ; -: SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-sse ; -: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-sse ; -: COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-sse ; +: MOVUPS ( dest src -- ) HEX: 10 f 2-operand-sse ; +: MOVUPD ( dest src -- ) HEX: 10 HEX: 66 2-operand-sse ; +: MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ; +: MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ; +: MOVLPS ( dest src -- ) HEX: 12 f 2-operand-sse ; +: MOVLPD ( dest src -- ) HEX: 12 HEX: 66 2-operand-sse ; +: MOVDDUP ( dest src -- ) HEX: 12 HEX: f2 2-operand-rm-sse ; +: MOVSLDUP ( dest src -- ) HEX: 12 HEX: f3 2-operand-rm-sse ; +: UNPCKLPS ( dest src -- ) HEX: 14 f 2-operand-rm-sse ; +: UNPCKLPD ( dest src -- ) HEX: 14 HEX: 66 2-operand-rm-sse ; +: UNPCKHPS ( dest src -- ) HEX: 15 f 2-operand-rm-sse ; +: UNPCKHPD ( dest src -- ) HEX: 15 HEX: 66 2-operand-rm-sse ; +: MOVHPS ( dest src -- ) HEX: 16 f 2-operand-sse ; +: MOVHPD ( dest src -- ) HEX: 16 HEX: 66 2-operand-sse ; +: MOVSHDUP ( dest src -- ) HEX: 16 HEX: f3 2-operand-rm-sse ; -: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ; -: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-sse ; +: PREFETCHNTA ( mem -- ) { BIN: 000 f { HEX: 0f HEX: 18 } } 1-operand ; +: PREFETCHT0 ( mem -- ) { BIN: 001 f { HEX: 0f HEX: 18 } } 1-operand ; +: PREFETCHT1 ( mem -- ) { BIN: 010 f { HEX: 0f HEX: 18 } } 1-operand ; +: PREFETCHT2 ( mem -- ) { BIN: 011 f { HEX: 0f HEX: 18 } } 1-operand ; + +: MOVAPS ( dest src -- ) HEX: 28 f 2-operand-sse ; +: MOVAPD ( dest src -- ) HEX: 28 HEX: 66 2-operand-sse ; +: CVTSI2SD ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ; +: CVTSI2SS ( dest src -- ) HEX: 2a HEX: f3 2-operand-int/sse ; +: MOVNTPS ( dest src -- ) HEX: 2b f 2-operand-mr-sse ; +: MOVNTPD ( dest src -- ) HEX: 2b HEX: 66 2-operand-mr-sse ; +: CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ; +: CVTTSS2SI ( dest src -- ) HEX: 2c HEX: f3 2-operand-int/sse ; +: CVTSD2SI ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ; +: CVTSS2SI ( dest src -- ) HEX: 2d HEX: f3 2-operand-int/sse ; +: UCOMISS ( dest src -- ) HEX: 2e f 2-operand-rm-sse ; +: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-rm-sse ; +: COMISS ( dest src -- ) HEX: 2f f 2-operand-rm-sse ; +: COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-rm-sse ; +: PSHUFB ( dest src -- ) { HEX: 38 HEX: 00 } HEX: 66 2-operand-ssse3 ; +: PHADDW ( dest src -- ) { HEX: 38 HEX: 01 } HEX: 66 2-operand-ssse3 ; +: PHADDD ( dest src -- ) { HEX: 38 HEX: 02 } HEX: 66 2-operand-ssse3 ; +: PHADDSW ( dest src -- ) { HEX: 38 HEX: 03 } HEX: 66 2-operand-ssse3 ; +: PMADDUBSW ( dest src -- ) { HEX: 38 HEX: 04 } HEX: 66 2-operand-ssse3 ; +: PHSUBW ( dest src -- ) { HEX: 38 HEX: 05 } HEX: 66 2-operand-ssse3 ; +: PHSUBD ( dest src -- ) { HEX: 38 HEX: 06 } HEX: 66 2-operand-ssse3 ; +: PHSUBSW ( dest src -- ) { HEX: 38 HEX: 07 } HEX: 66 2-operand-ssse3 ; +: PSIGNB ( dest src -- ) { HEX: 38 HEX: 08 } HEX: 66 2-operand-ssse3 ; +: PSIGNW ( dest src -- ) { HEX: 38 HEX: 09 } HEX: 66 2-operand-ssse3 ; +: PSIGND ( dest src -- ) { HEX: 38 HEX: 0A } HEX: 66 2-operand-ssse3 ; +: PMULHRSW ( dest src -- ) { HEX: 38 HEX: 0B } HEX: 66 2-operand-ssse3 ; +: PABSB ( dest src -- ) { HEX: 38 HEX: 1C } HEX: 66 2-operand-ssse3 ; +: PABSW ( dest src -- ) { HEX: 38 HEX: 1D } HEX: 66 2-operand-ssse3 ; +: PABSD ( dest src -- ) { HEX: 38 HEX: 1E } HEX: 66 2-operand-ssse3 ; +: PALIGNR ( dest src -- ) { HEX: 3A HEX: 0F } HEX: 66 2-operand-ssse3 ; +: MOVMSKPS ( dest src -- ) HEX: 50 f 2-operand-int/sse ; +: MOVMSKPD ( dest src -- ) HEX: 50 HEX: 66 2-operand-int/sse ; +: SQRTPS ( dest src -- ) HEX: 51 f 2-operand-rm-sse ; +: SQRTPD ( dest src -- ) HEX: 51 HEX: 66 2-operand-rm-sse ; +: SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-rm-sse ; +: SQRTSS ( dest src -- ) HEX: 51 HEX: f3 2-operand-rm-sse ; +: RSQRTPS ( dest src -- ) HEX: 52 f 2-operand-rm-sse ; +: RSQRTSS ( dest src -- ) HEX: 52 HEX: f3 2-operand-rm-sse ; +: RCPPS ( dest src -- ) HEX: 53 f 2-operand-rm-sse ; +: RCPSS ( dest src -- ) HEX: 53 HEX: f3 2-operand-rm-sse ; +: ANDPS ( dest src -- ) HEX: 54 f 2-operand-rm-sse ; +: ANDPD ( dest src -- ) HEX: 54 HEX: 66 2-operand-rm-sse ; +: ANDNPS ( dest src -- ) HEX: 55 f 2-operand-rm-sse ; +: ANDNPD ( dest src -- ) HEX: 55 HEX: 66 2-operand-rm-sse ; +: ORPS ( dest src -- ) HEX: 56 f 2-operand-rm-sse ; +: ORPD ( dest src -- ) HEX: 56 HEX: 66 2-operand-rm-sse ; +: XORPS ( dest src -- ) HEX: 57 f 2-operand-rm-sse ; +: XORPD ( dest src -- ) HEX: 57 HEX: 66 2-operand-rm-sse ; +: ADDPS ( dest src -- ) HEX: 58 f 2-operand-rm-sse ; +: ADDPD ( dest src -- ) HEX: 58 HEX: 66 2-operand-rm-sse ; +: ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-rm-sse ; +: ADDSS ( dest src -- ) HEX: 58 HEX: f3 2-operand-rm-sse ; +: MULPS ( dest src -- ) HEX: 59 f 2-operand-rm-sse ; +: MULPD ( dest src -- ) HEX: 59 HEX: 66 2-operand-rm-sse ; +: MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-rm-sse ; +: MULSS ( dest src -- ) HEX: 59 HEX: f3 2-operand-rm-sse ; +: CVTPS2PD ( dest src -- ) HEX: 5a f 2-operand-rm-sse ; +: CVTPD2PS ( dest src -- ) HEX: 5a HEX: 66 2-operand-rm-sse ; +: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-rm-sse ; +: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-rm-sse ; +: CVTDQ2PS ( dest src -- ) HEX: 5b f 2-operand-rm-sse ; +: CVTPS2DQ ( dest src -- ) HEX: 5b HEX: 66 2-operand-rm-sse ; +: CVTTPS2DQ ( dest src -- ) HEX: 5b HEX: f3 2-operand-rm-sse ; +: SUBPS ( dest src -- ) HEX: 5c f 2-operand-rm-sse ; +: SUBPD ( dest src -- ) HEX: 5c HEX: 66 2-operand-rm-sse ; +: SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-rm-sse ; +: SUBSS ( dest src -- ) HEX: 5c HEX: f3 2-operand-rm-sse ; +: MINPS ( dest src -- ) HEX: 5d f 2-operand-rm-sse ; +: MINPD ( dest src -- ) HEX: 5d HEX: 66 2-operand-rm-sse ; +: MINSD ( dest src -- ) HEX: 5d HEX: f2 2-operand-rm-sse ; +: MINSS ( dest src -- ) HEX: 5d HEX: f3 2-operand-rm-sse ; +: DIVPS ( dest src -- ) HEX: 5e f 2-operand-rm-sse ; +: DIVPD ( dest src -- ) HEX: 5e HEX: 66 2-operand-rm-sse ; +: DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-rm-sse ; +: DIVSS ( dest src -- ) HEX: 5e HEX: f3 2-operand-rm-sse ; +: MAXPS ( dest src -- ) HEX: 5f f 2-operand-rm-sse ; +: MAXPD ( dest src -- ) HEX: 5f HEX: 66 2-operand-rm-sse ; +: MAXSD ( dest src -- ) HEX: 5f HEX: f2 2-operand-rm-sse ; +: MAXSS ( dest src -- ) HEX: 5f HEX: f3 2-operand-rm-sse ; +: PUNPCKLQDQ ( dest src -- ) HEX: 6c HEX: 66 2-operand-rm-sse ; +: PUNPCKHQDQ ( dest src -- ) HEX: 6d HEX: 66 2-operand-rm-sse ; + +: MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ; +: MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ; + +: PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-sse ; +: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-sse ; +: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-sse ; +: PSRLW ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ; +: PSRAW ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ; +: PSLLW ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ; +: PSRLD ( dest imm -- ) BIN: 010 HEX: 72 HEX: 66 2-operand-sse-shift ; +: PSRAD ( dest imm -- ) BIN: 100 HEX: 72 HEX: 66 2-operand-sse-shift ; +: PSLLD ( dest imm -- ) BIN: 110 HEX: 72 HEX: 66 2-operand-sse-shift ; +: PSRLQ ( dest imm -- ) BIN: 010 HEX: 73 HEX: 66 2-operand-sse-shift ; +: PSRLDQ ( dest imm -- ) BIN: 011 HEX: 73 HEX: 66 2-operand-sse-shift ; +: PSLLQ ( dest imm -- ) BIN: 110 HEX: 73 HEX: 66 2-operand-sse-shift ; +: PSLLDQ ( dest imm -- ) BIN: 111 HEX: 73 HEX: 66 2-operand-sse-shift ; + +: PCMPEQB ( dest src -- ) HEX: 74 HEX: 66 2-operand-rm-sse ; +: PCMPEQW ( dest src -- ) HEX: 75 HEX: 66 2-operand-rm-sse ; +: PCMPEQD ( dest src -- ) HEX: 76 HEX: 66 2-operand-rm-sse ; +: HADDPD ( dest src -- ) HEX: 7c HEX: 66 2-operand-rm-sse ; +: HADDPS ( dest src -- ) HEX: 7c HEX: f2 2-operand-rm-sse ; +: HSUBPD ( dest src -- ) HEX: 7d HEX: 66 2-operand-rm-sse ; +: HSUBPS ( dest src -- ) HEX: 7d HEX: f2 2-operand-rm-sse ; + +: LDMXCSR ( src -- ) { BIN: 010 f { HEX: 0f HEX: ae } } 1-operand ; +: STMXCSR ( dest -- ) { BIN: 011 f { HEX: 0f HEX: ae } } 1-operand ; +: LFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 350 , ; +: MFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 360 , ; +: SFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 370 , ; + +: CMPEQPS ( dest src -- ) 0 HEX: c2 f 2-operand-sse-cmp ; +: CMPLTPS ( dest src -- ) 1 HEX: c2 f 2-operand-sse-cmp ; +: CMPLEPS ( dest src -- ) 2 HEX: c2 f 2-operand-sse-cmp ; +: CMPUNORDPS ( dest src -- ) 3 HEX: c2 f 2-operand-sse-cmp ; +: CMPNEQPS ( dest src -- ) 4 HEX: c2 f 2-operand-sse-cmp ; +: CMPNLTPS ( dest src -- ) 5 HEX: c2 f 2-operand-sse-cmp ; +: CMPNLEPS ( dest src -- ) 6 HEX: c2 f 2-operand-sse-cmp ; +: CMPORDPS ( dest src -- ) 7 HEX: c2 f 2-operand-sse-cmp ; + +: CMPEQPD ( dest src -- ) 0 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPLTPD ( dest src -- ) 1 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPLEPD ( dest src -- ) 2 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPUNORDPD ( dest src -- ) 3 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPNEQPD ( dest src -- ) 4 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPNLTPD ( dest src -- ) 5 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPNLEPD ( dest src -- ) 6 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPORDPD ( dest src -- ) 7 HEX: c2 HEX: 66 2-operand-sse-cmp ; + +: CMPEQSD ( dest src -- ) 0 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPLTSD ( dest src -- ) 1 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPLESD ( dest src -- ) 2 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPUNORDSD ( dest src -- ) 3 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPNEQSD ( dest src -- ) 4 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPNLTSD ( dest src -- ) 5 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPNLESD ( dest src -- ) 6 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPORDSD ( dest src -- ) 7 HEX: c2 HEX: f2 2-operand-sse-cmp ; + +: CMPEQSS ( dest src -- ) 0 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPLTSS ( dest src -- ) 1 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPLESS ( dest src -- ) 2 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPUNORDSS ( dest src -- ) 3 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPNEQSS ( dest src -- ) 4 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPNLTSS ( dest src -- ) 5 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPNLESS ( dest src -- ) 6 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPORDSS ( dest src -- ) 7 HEX: c2 HEX: f3 2-operand-sse-cmp ; + +: MOVNTI ( dest src -- ) { HEX: 0f HEX: c3 } (2-operand) ; + +: PINSRW ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-sse ; +: PEXTRW ( dest src imm -- ) HEX: c5 HEX: 66 3-operand-sse ; +: SHUFPS ( dest src imm -- ) HEX: c6 f 3-operand-sse ; +: SHUFPD ( dest src imm -- ) HEX: c6 HEX: 66 3-operand-sse ; + +: ADDSUBPD ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ; +: ADDSUBPS ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ; +: PADDQ ( dest src -- ) HEX: d4 HEX: 66 2-operand-rm-sse ; +: PMINUB ( dest src -- ) HEX: da HEX: 66 2-operand-rm-sse ; +: PMAXUB ( dest src -- ) HEX: de HEX: 66 2-operand-rm-sse ; +: PAVGB ( dest src -- ) HEX: e0 HEX: 66 2-operand-rm-sse ; +: PAVGW ( dest src -- ) HEX: e3 HEX: 66 2-operand-rm-sse ; +: PMULHUW ( dest src -- ) HEX: e4 HEX: 66 2-operand-rm-sse ; +: CVTTPD2DQ ( dest src -- ) HEX: e6 HEX: 66 2-operand-rm-sse ; +: CVTPD2DQ ( dest src -- ) HEX: e6 HEX: f2 2-operand-rm-sse ; +: CVTDQ2PD ( dest src -- ) HEX: e6 HEX: f3 2-operand-rm-sse ; + +: MOVNTDQ ( dest src -- ) HEX: e7 HEX: 66 2-operand-mr-sse ; + +: PMINSW ( dest src -- ) HEX: ea HEX: 66 2-operand-rm-sse ; +: PMAXSW ( dest src -- ) HEX: ee HEX: 66 2-operand-rm-sse ; +: LDDQU ( dest src -- ) HEX: f0 HEX: f2 2-operand-rm-sse ; +: PMULUDQ ( dest src -- ) HEX: f4 HEX: 66 2-operand-rm-sse ; +: PSADBW ( dest src -- ) HEX: f6 HEX: 66 2-operand-rm-sse ; + +: MASKMOVDQU ( dest src -- ) HEX: f7 HEX: 66 2-operand-rm-sse ; + +: PSUBQ ( dest src -- ) HEX: fb HEX: 66 2-operand-rm-sse ; + +! x86-64 branch prediction hints + +: HWNT ( -- ) HEX: 2e , ; ! Hint branch Weakly Not Taken +: HST ( -- ) HEX: 3e , ; ! Hint branch Strongly Taken -: CVTSI2SD ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ; -: CVTSD2SI ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ; -: CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ; From d2b158c8e40e07eb5ce3af751b24fea2e0addfc6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 01:04:13 -0500 Subject: [PATCH 52/81] compiler.cfg.critical-edges: reset RPO --- basis/compiler/cfg/critical-edges/critical-edges.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/compiler/cfg/critical-edges/critical-edges.factor b/basis/compiler/cfg/critical-edges/critical-edges.factor index 92b4f801d6..1000c24752 100644 --- a/basis/compiler/cfg/critical-edges/critical-edges.factor +++ b/basis/compiler/cfg/critical-edges/critical-edges.factor @@ -11,9 +11,11 @@ IN: compiler.cfg.critical-edges f insert-basic-block ; : split-critical-edges ( cfg -- ) - [ + dup [ dup successors>> [ 2dup critical-edge? [ split-critical-edge ] [ 2drop ] if ] with each - ] each-basic-block ; \ No newline at end of file + ] each-basic-block + cfg-changed + drop ; \ No newline at end of file From 41c5f0d94174f0d8b2c6ea9966df5ca3a746c768 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 06:41:29 -0500 Subject: [PATCH 53/81] compiler.cfg.graphviz: A utility for rendering CFGs with graphviz --- extra/compiler/cfg/graphviz/graphviz.factor | 22 +++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 extra/compiler/cfg/graphviz/graphviz.factor diff --git a/extra/compiler/cfg/graphviz/graphviz.factor b/extra/compiler/cfg/graphviz/graphviz.factor new file mode 100644 index 0000000000..d4513c8394 --- /dev/null +++ b/extra/compiler/cfg/graphviz/graphviz.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license +USING: accessors compiler.cfg.rpo images.viewer io +io.encodings.ascii io.files io.files.unique io.launcher kernel +math.parser sequences ; +IN: compiler.cfg.graphviz + +: cfg>dot ( cfg -- ) + "digraph CFG {" print + [ + [ number>> ] [ successors>> ] bi [ + number>> [ number>string ] bi@ " -> " glue write ";" print + ] with each + ] each-basic-block + "}" print ; + +: render-cfg ( cfg -- ) + "cfg" "dot" make-unique-file + [ ascii [ cfg>dot ] with-file-writer ] + [ { "dot" "-Tpng" "-O" } swap suffix try-process ] + [ ".png" append { "open" } swap suffix try-process ] + tri ; From 1878b0dc32da2c93b85bcb23998b6a15735af3c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 06:45:02 -0500 Subject: [PATCH 54/81] compiler.cfg.liveness: fix liveness computation in case where instruction uses a register it defines --- .../cfg/liveness/liveness-tests.factor | 34 ++++++++++++++++--- basis/compiler/cfg/liveness/liveness.factor | 11 +++--- 2 files changed, 36 insertions(+), 9 deletions(-) diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor index 697a1f8a7b..eb497a9bae 100644 --- a/basis/compiler/cfg/liveness/liveness-tests.factor +++ b/basis/compiler/cfg/liveness/liveness-tests.factor @@ -1,9 +1,14 @@ USING: compiler.cfg.liveness compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.predecessors compiler.cfg.registers compiler.cfg cpu.architecture -accessors namespaces sequences kernel tools.test ; +accessors namespaces sequences kernel tools.test vectors ; IN: compiler.cfg.liveness.tests +: test-liveness ( -- ) + cfg new 1 get >>entry + compute-predecessors + compute-live-sets ; + ! Sanity check... V{ @@ -11,21 +16,22 @@ V{ T{ ##replace f V int-regs 0 D 0 } T{ ##replace f V int-regs 1 D 1 } T{ ##peek f V int-regs 1 D 1 } + T{ ##branch } } 1 test-bb V{ T{ ##replace f V int-regs 2 D 0 } + T{ ##branch } } 2 test-bb V{ T{ ##replace f V int-regs 3 D 0 } + T{ ##return } } 3 test-bb 1 get 2 get 3 get V{ } 2sequence >>successors drop -cfg new 1 get >>entry -compute-predecessors -compute-live-sets +test-liveness [ H{ @@ -35,4 +41,22 @@ compute-live-sets } ] [ 1 get live-in ] -unit-test \ No newline at end of file +unit-test + +! Tricky case; defs must be killed before uses + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##add-imm f V int-regs 0 V int-regs 0 10 } + T{ ##return } +} 2 test-bb + +1 get 2 get 1vector >>successors drop + +test-liveness + +[ H{ { V int-regs 0 V int-regs 0 } } ] [ 2 get live-in ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index 30b145332f..eef9296b4b 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -12,11 +12,14 @@ BACKWARD-ANALYSIS: live GENERIC: insn-liveness ( live-set insn -- ) +: kill-defs ( live-set insn -- live-set ) + defs-vregs [ over delete-at ] each ; + +: gen-uses ( live-set insn -- live-set ) + dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ; + : transfer-liveness ( live-set instructions -- live-set' ) - [ clone ] [ ] bi* [ - [ dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ] - [ defs-vregs [ over delete-at ] each ] bi - ] each ; + [ clone ] [ ] bi* [ [ kill-defs ] [ gen-uses ] bi ] each ; : local-live-in ( instructions -- live-set ) [ H{ } ] dip transfer-liveness keys ; From cb07256ff51c61e33e2a5af1c3790c897c3bc24e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 06:45:31 -0500 Subject: [PATCH 55/81] Add some compiler tests --- basis/compiler/tests/codegen.factor | 14 +++++++++++++- basis/compiler/tests/low-level-ir.factor | 7 +++++++ 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index c93e20294e..f1d17fe4a2 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -333,4 +333,16 @@ cell 4 = [ ] if ] any? ; inline recursive -[ t ] [ 3 [ return-recursive-bug ] compile-call ] unit-test \ No newline at end of file +[ t ] [ 3 [ return-recursive-bug ] compile-call ] unit-test + +! Coalescing reductions +[ f ] [ V{ } 0 [ [ vector? ] both? ] compile-call ] unit-test +[ f ] [ 0 V{ } [ [ vector? ] both? ] compile-call ] unit-test + +[ f ] [ + f vector [ + [ dup [ \ vector eq? ] [ drop f ] if ] dip + dup [ \ vector eq? ] [ drop f ] if + over rot [ drop ] [ nip ] if + ] compile-call +] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor index 313fd65dac..706a404330 100644 --- a/basis/compiler/tests/low-level-ir.factor +++ b/basis/compiler/tests/low-level-ir.factor @@ -111,6 +111,13 @@ IN: compiler.tests } compile-test-bb ] unit-test +[ 1 ] [ + V{ + T{ ##load-immediate f V int-regs 0 16 } + T{ ##add-imm f V int-regs 0 V int-regs 0 -8 } + } compile-test-bb +] unit-test + ! These are def-is-use-insns USE: multiline From a4cb242396bc129a5b92559b476e994f7b2408c8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 06:48:20 -0500 Subject: [PATCH 56/81] compiler.cfg.coalescing: Only run if CFG has ##phi nodes, fix interference for case where value is not used in a block and is not live-in, forgot to run liveness analysis first --- .../compiler/cfg/coalescing/coalescing.factor | 31 ++++++++++--------- .../interference/interference.factor | 8 +++-- .../coalescing/live-ranges/live-ranges.factor | 26 +++++++++++++--- basis/compiler/cfg/utilities/utilities.factor | 3 ++ 4 files changed, 47 insertions(+), 21 deletions(-) diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor index a9637088a3..86dee8a3be 100644 --- a/basis/compiler/cfg/coalescing/coalescing.factor +++ b/basis/compiler/cfg/coalescing/coalescing.factor @@ -7,6 +7,7 @@ compiler.cfg.def-use compiler.cfg.utilities compiler.cfg.dominance compiler.cfg.instructions +compiler.cfg.liveness.ssa compiler.cfg.critical-edges compiler.cfg.coalescing.state compiler.cfg.coalescing.forest @@ -36,10 +37,7 @@ SYMBOL: seen V{ } clone seen set renaming-sets get [| dst assoc | assoc [| src bb | - src seen get key? - [ dst assoc src bb visit-renaming ] - [ src seen get conjoin ] - if + dst assoc src bb visit-renaming ] assoc-each ] assoc-each ; @@ -50,14 +48,17 @@ SYMBOL: seen [ [ remove-phis-from-block ] if-has-phis ] each-basic-block ; : coalesce ( cfg -- cfg' ) - init-coalescing - dup split-critical-edges - dup compute-def-use - dup compute-dominance - dup compute-dfs - dup compute-live-ranges - dup process-blocks - break-interferences - dup perform-renaming - insert-copies - dup remove-phis ; \ No newline at end of file + dup cfg-has-phis? [ + init-coalescing + compute-ssa-live-sets + dup split-critical-edges + dup compute-def-use + dup compute-dominance + dup compute-dfs + dup compute-live-ranges + dup process-blocks + break-interferences + dup perform-renaming + insert-copies + dup remove-phis + ] when ; \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/interference/interference.factor b/basis/compiler/cfg/coalescing/interference/interference.factor index ff5e6319e6..4e0ca99834 100644 --- a/basis/compiler/cfg/coalescing/interference/interference.factor +++ b/basis/compiler/cfg/coalescing/interference/interference.factor @@ -8,8 +8,12 @@ IN: compiler.cfg.coalescing.interference = ; + ! If first register is used after second one is defined, they interfere. + ! If they are used in the same instruction, no interference. If the + ! instruction is a def-is-use-insn, then there will be a use at +1 + ! (instructions are 2 apart) and so outputs will interfere with + ! inputs. + [ kill-index ] [ def-index ] bi-curry bi* > ; : interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? ) ! If both are defined in the same basic block, they interfere if their diff --git a/basis/compiler/cfg/coalescing/live-ranges/live-ranges.factor b/basis/compiler/cfg/coalescing/live-ranges/live-ranges.factor index f35a752ea6..c0eafc00fd 100644 --- a/basis/compiler/cfg/coalescing/live-ranges/live-ranges.factor +++ b/basis/compiler/cfg/coalescing/live-ranges/live-ranges.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs fry kernel namespaces sequences +USING: accessors assocs fry kernel namespaces sequences math compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.liveness compiler.cfg.rpo ; IN: compiler.cfg.coalescing.live-ranges @@ -18,9 +18,15 @@ SYMBOLS: local-def-indices local-kill-indices ; local-kill-indices get '[ _ set-at ] with each ; : visit-insn ( insn n -- ) + ! Instructions are numbered 2 apart. If the instruction requires + ! that outputs are in different registers than the inputs, then + ! a use will be registered for every output immediately after + ! this instruction and before the next one, ensuring that outputs + ! interfere with inputs. + 2 * [ swap defs-vregs record-defs ] [ swap uses-vregs record-uses ] - [ over def-is-use-insn? [ swap defs-vregs record-uses ] [ 2drop ] if ] + [ over def-is-use-insn? [ 1 + swap defs-vregs record-uses ] [ 2drop ] if ] 2tri ; SYMBOLS: def-indices kill-indices ; @@ -28,15 +34,27 @@ SYMBOLS: def-indices kill-indices ; : compute-local-live-ranges ( bb -- ) H{ } clone local-def-indices set H{ } clone local-kill-indices set - instructions>> [ visit-insn ] each-index ; + [ instructions>> [ visit-insn ] each-index ] + [ [ local-def-indices get ] dip def-indices get set-at ] + [ [ local-kill-indices get ] dip kill-indices get set-at ] + tri ; PRIVATE> : compute-live-ranges ( cfg -- ) + H{ } clone def-indices set + H{ } clone kill-indices set [ compute-local-live-ranges ] each-basic-block ; : def-index ( vreg bb -- n ) def-indices get at at ; +ERROR: bad-kill-index vreg bb ; + : kill-index ( vreg bb -- n ) - 2dup live-out key? [ 2drop 1/0. ] [ kill-indices get at at ] if ; + 2dup live-out key? [ 2drop 1/0. ] [ + 2dup kill-indices get at at* [ 2nip ] [ + drop 2dup live-in key? + [ bad-kill-index ] [ 2drop -1/0. ] if + ] if + ] if ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 2be805bd20..48c8ce06b3 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -48,5 +48,8 @@ SYMBOL: visited : has-phis? ( bb -- ? ) instructions>> first ##phi? ; +: cfg-has-phis? ( cfg -- ) + post-order [ has-phis? ] any? ; + : if-has-phis ( bb quot: ( bb -- ) -- ) [ dup has-phis? ] dip [ drop ] if ; inline From 7c5e2f2933524920e39400fcfa9564e72fcda8c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 06:49:03 -0500 Subject: [PATCH 57/81] tools.annotations: doc addition --- basis/tools/annotations/annotations-docs.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor index 07ad79f867..ba6572c202 100644 --- a/basis/tools/annotations/annotations-docs.factor +++ b/basis/tools/annotations/annotations-docs.factor @@ -60,3 +60,6 @@ HELP: reset-word-timing HELP: word-timing. { $description "Prints the word timing table." } ; + +HELP: cannot-annotate-twice +{ $error-description "Thrown when attempting to annotate a word that's already been annotated. If a word already has an annotation such as a watch or a breakpoint, you must first " { $link reset } " the word before adding another annotation." } ; \ No newline at end of file From fb33ee300278227c3e2acbe7d4fa25dbbfa5a9eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 06:49:09 -0500 Subject: [PATCH 58/81] classes.algebra: stack effect fix --- core/classes/algebra/algebra.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 3c39848d02..6d221c1380 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -106,7 +106,7 @@ PREDICATE: empty-union < anonymous-union members>> empty? ; PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; -: (class<=) ( first second -- -1/0/1 ) +: (class<=) ( first second -- ? ) 2dup eq? [ 2drop t ] [ 2dup superclass<= [ 2drop t ] [ [ normalize-class ] bi@ { From 3e6e5278a4eef20d62e501cb87711e2f78e42b2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 06:51:03 -0500 Subject: [PATCH 59/81] compiler.cfg.utilities: fix load error --- basis/compiler/cfg/utilities/utilities.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 48c8ce06b3..9d6927b143 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators combinators.short-circuit -compiler.cfg compiler.cfg.instructions cpu.architecture kernel -layouts locals make math namespaces sequences sets vectors fry ; +cpu.architecture kernel layouts locals make math namespaces sequences +sets vectors fry compiler.cfg compiler.cfg.instructions +compiler.cfg.rpo ; IN: compiler.cfg.utilities PREDICATE: kill-block < basic-block From f2c8f2824a364d6e547e8303591c4e1985dfd097 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 07:37:50 -0500 Subject: [PATCH 60/81] compiler.cfg.coalescing: some cleanups --- .../compiler/cfg/coalescing/coalescing.factor | 15 +++++++-- .../cfg/coalescing/copies/copies.factor | 21 ------------ .../process-blocks/process-blocks.factor | 32 ++++++++++--------- .../cfg/coalescing/renaming/renaming.factor | 2 +- 4 files changed, 30 insertions(+), 40 deletions(-) delete mode 100644 basis/compiler/cfg/coalescing/copies/copies.factor diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor index 86dee8a3be..5deb375572 100644 --- a/basis/compiler/cfg/coalescing/coalescing.factor +++ b/basis/compiler/cfg/coalescing/coalescing.factor @@ -1,17 +1,17 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs fry kernel locals math math.order -sequences namespaces sets +sequences namespaces sets make compiler.cfg.rpo compiler.cfg.def-use compiler.cfg.utilities compiler.cfg.dominance compiler.cfg.instructions compiler.cfg.liveness.ssa +compiler.cfg.parallel-copy compiler.cfg.critical-edges compiler.cfg.coalescing.state compiler.cfg.coalescing.forest -compiler.cfg.coalescing.copies compiler.cfg.coalescing.renaming compiler.cfg.coalescing.live-ranges compiler.cfg.coalescing.process-blocks ; @@ -29,7 +29,7 @@ SYMBOL: seen :: visit-renaming ( dst assoc src bb -- ) src seen get key? [ - src dst bb waiting-for push-at + dst src bb waiting-for set-at src assoc delete-at ] [ src seen get conjoin ] if ; @@ -41,6 +41,15 @@ SYMBOL: seen ] assoc-each ] assoc-each ; +: insert-copies ( -- ) + waiting get [ + [ instructions>> building ] dip '[ + building get pop + _ parallel-copy + , + ] with-variable + ] assoc-each ; + : remove-phis-from-block ( bb -- ) instructions>> [ ##phi? not ] filter-here ; diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/coalescing/copies/copies.factor deleted file mode 100644 index 5df2684f72..0000000000 --- a/basis/compiler/cfg/coalescing/copies/copies.factor +++ /dev/null @@ -1,21 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs hashtables fry kernel make namespaces -sequences compiler.cfg.coalescing.state compiler.cfg.parallel-copy ; -IN: compiler.cfg.coalescing.copies - -: compute-copies ( assoc -- assoc' ) - dup assoc-size [ - '[ - [ 2dup eq? [ 2drop ] [ _ 2dup key? [ "OOPS" throw ] [ set-at ] if ] if ] with each - ] assoc-each - ] keep ; - -: insert-copies ( -- ) - waiting get [ - [ instructions>> building ] dip '[ - building get pop - _ compute-copies parallel-copy - , - ] with-variable - ] assoc-each ; \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor index 005c71f357..cc7b923105 100644 --- a/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor +++ b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor @@ -47,7 +47,7 @@ SYMBOLS: phi-union unioned-blocks ; 2nip processed-name ; :: trivial-interference ( bb src dst -- ) - dst src bb waiting-for push-at + src dst bb waiting-for set-at src used-by-another get push ; :: add-to-renaming-set ( bb src dst -- ) @@ -118,20 +118,21 @@ SYMBOLS: visited work-list ; [ push-all-front ] keep [ work-list set ] [ process-df-nodes ] bi ; -:: add-local-interferences ( bb ##phi -- ) +: add-local-interferences ( ##phi -- ) ! bb contains the phi node. If the input is defined in the same ! block as the phi node, we have to check for interference. ! This can only happen if the value is carried by a back edge. - phi-union get [ - drop dup def-of bb eq? - [ ##phi dst>> 2array , ] [ drop ] if - ] assoc-each ; + + ! XXX: in the LLVM version they only add an interference if + ! the operand is defined in the same block as the ##phi, but + ! this doesn't work here. Investigate + [ phi-union get ] dip dst>> '[ drop _ 2array , ] assoc-each ; -: compute-local-interferences ( bb ##phi -- pairs ) +: compute-local-interferences ( ##phi -- pairs ) [ - [ phi-union get keys compute-dom-forest process-phi-union drop ] + [ phi-union get keys compute-dom-forest process-phi-union ] [ add-local-interferences ] - 2bi + bi ] { } make ; :: insert-copies-for-interference ( ##phi src -- ) @@ -149,13 +150,14 @@ SYMBOLS: visited work-list ; dst>> phi-union get swap renaming-sets get set-at phi-union get [ drop processed-name ] assoc-each ; -:: process-phi ( bb ##phi -- ) +: process-phi ( ##phi -- ) H{ } clone phi-union set H{ } clone unioned-blocks set - ##phi inputs>> ##phi dst>> '[ _ process-phi-operand ] assoc-each - ##phi bb ##phi compute-local-interferences process-local-interferences - ##phi add-renaming-set ; + [ [ inputs>> ] [ dst>> ] bi '[ _ process-phi-operand ] assoc-each ] + [ dup compute-local-interferences process-local-interferences ] + [ add-renaming-set ] + tri ; : process-block ( bb -- ) - dup instructions>> - [ dup ##phi? [ process-phi t ] [ 2drop f ] if ] with all? drop ; + instructions>> + [ dup ##phi? [ process-phi t ] [ drop f ] if ] all? drop ; diff --git a/basis/compiler/cfg/coalescing/renaming/renaming.factor b/basis/compiler/cfg/coalescing/renaming/renaming.factor index 848d0a4df0..15062d17c4 100644 --- a/basis/compiler/cfg/coalescing/renaming/renaming.factor +++ b/basis/compiler/cfg/coalescing/renaming/renaming.factor @@ -37,7 +37,7 @@ IN: compiler.cfg.coalescing.renaming : rename-copies ( -- ) waiting renamings get '[ [ - [ _ [ ?at drop ] [ '[ _ ?at drop ] map ] bi-curry bi* ] assoc-map + [ [ _ ?at drop ] bi@ ] assoc-map ] assoc-map ] change ; From 857ef94acc817996cca4f9ede827c20aad58ba5d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 07:39:46 -0500 Subject: [PATCH 61/81] compiler.cfg.linear-scan: use compiler.cfg.parallel-copy in resolve pass --- .../linear-scan/assignment/assignment.factor | 34 +--- .../cfg/linear-scan/linear-scan.factor | 4 +- .../linear-scan/mapping/mapping-tests.factor | 145 ------------------ .../cfg/linear-scan/mapping/mapping.factor | 142 ----------------- .../cfg/linear-scan/resolve/resolve.factor | 53 +++++-- .../cfg/parallel-copy/parallel-copy.factor | 2 +- 6 files changed, 50 insertions(+), 330 deletions(-) delete mode 100644 basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor delete mode 100644 basis/compiler/cfg/linear-scan/mapping/mapping.factor diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 8e21e7e3fb..370f562fc4 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -9,7 +9,6 @@ compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.linear-scan.mapping compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.live-intervals ; @@ -44,44 +43,25 @@ SYMBOL: register-live-outs H{ } clone register-live-outs set init-unhandled ; +: insert-spill ( live-interval -- ) + [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ; + : handle-spill ( live-interval -- ) - dup spill-to>> [ - [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri - register->memory - ] [ drop ] if ; - -: first-split ( live-interval -- live-interval' ) - dup split-before>> [ first-split ] [ ] ?if ; - -: next-interval ( live-interval -- live-interval' ) - split-next>> first-split ; - -: handle-copy ( live-interval -- ) - dup split-next>> [ - [ reg>> ] [ next-interval reg>> ] [ vreg>> reg-class>> ] tri - register->register - ] [ drop ] if ; + dup spill-to>> [ insert-spill ] [ drop ] if ; : (expire-old-intervals) ( n heap -- ) dup heap-empty? [ 2drop ] [ 2dup heap-peek nip <= [ 2drop ] [ - dup heap-pop drop [ handle-spill ] [ handle-copy ] bi + dup heap-pop drop handle-spill (expire-old-intervals) ] if ] if ; : expire-old-intervals ( n -- ) - [ - pending-intervals get (expire-old-intervals) - ] { } make mapping-instructions % ; + pending-intervals get (expire-old-intervals) ; : insert-reload ( live-interval -- ) - { - [ reg>> ] - [ vreg>> reg-class>> ] - [ reload-from>> ] - [ start>> ] - } cleave f swap \ _reload boa , ; + [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ; : handle-reload ( live-interval -- ) dup reload-from>> [ insert-reload ] [ drop ] if ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index b081f2ca6e..51b2f6db1b 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -11,8 +11,7 @@ compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.assignment -compiler.cfg.linear-scan.resolve -compiler.cfg.linear-scan.mapping ; +compiler.cfg.linear-scan.resolve ; IN: compiler.cfg.linear-scan ! References: @@ -39,7 +38,6 @@ IN: compiler.cfg.linear-scan : linear-scan ( cfg -- cfg' ) [ - init-mapping dup machine-registers (linear-scan) spill-counts get >>spill-counts cfg-changed diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor b/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor deleted file mode 100644 index d12167574a..0000000000 --- a/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor +++ /dev/null @@ -1,145 +0,0 @@ -USING: compiler.cfg.instructions -compiler.cfg.linear-scan.allocation.state -compiler.cfg.linear-scan.mapping cpu.architecture kernel -namespaces tools.test ; -IN: compiler.cfg.linear-scan.mapping.tests - -H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set -init-mapping - -[ - { - T{ _copy { dst 5 } { src 4 } { class int-regs } } - T{ _spill { src 1 } { class int-regs } { n 10 } } - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n 10 } } - T{ _spill { src 1 } { class float-regs } { n 20 } } - T{ _copy { dst 1 } { src 0 } { class float-regs } } - T{ _reload { dst 0 } { class float-regs } { n 20 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 1 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 1 } { reg-class float-regs } } - T{ register->register { from 1 } { to 0 } { reg-class float-regs } } - T{ register->register { from 4 } { to 5 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _spill { src 2 } { class int-regs } { n 10 } } - T{ _copy { dst 2 } { src 1 } { class int-regs } } - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 1 } { to 2 } { reg-class int-regs } } - T{ register->register { from 2 } { to 0 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _spill { src 0 } { class int-regs } { n 10 } } - T{ _copy { dst 0 } { src 2 } { class int-regs } } - T{ _copy { dst 2 } { src 1 } { class int-regs } } - T{ _reload { dst 1 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 1 } { to 2 } { reg-class int-regs } } - T{ register->register { from 2 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _copy { dst 2 } { src 0 } { class int-regs } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { } -] [ - { - T{ register->register { from 4 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _spill { src 3 } { class int-regs } { n 4 } } - T{ _reload { dst 2 } { class int-regs } { n 1 } } - } -] [ - { - T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } } - T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - - -[ - { - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _copy { dst 0 } { src 3 } { class int-regs } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _spill { src 4 } { class int-regs } { n 10 } } - T{ _copy { dst 4 } { src 0 } { class int-regs } } - T{ _copy { dst 0 } { src 3 } { class int-regs } } - T{ _reload { dst 3 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 4 } { to 3 } { reg-class int-regs } } - T{ register->register { from 0 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _copy { dst 9 } { src 1 } { class int-regs } } - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _spill { src 4 } { class int-regs } { n 10 } } - T{ _copy { dst 4 } { src 0 } { class int-regs } } - T{ _copy { dst 0 } { src 3 } { class int-regs } } - T{ _reload { dst 3 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - T{ register->register { from 1 } { to 9 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 4 } { to 3 } { reg-class int-regs } } - T{ register->register { from 0 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping.factor b/basis/compiler/cfg/linear-scan/mapping/mapping.factor deleted file mode 100644 index 36678a2f53..0000000000 --- a/basis/compiler/cfg/linear-scan/mapping/mapping.factor +++ /dev/null @@ -1,142 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs classes.parser classes.tuple -combinators compiler.cfg.instructions -compiler.cfg.linear-scan.allocation.state fry hashtables kernel -locals make namespaces parser sequences sets words ; -IN: compiler.cfg.linear-scan.mapping - -SYMBOL: spill-temps - -: spill-temp ( reg-class -- n ) - spill-temps get [ next-spill-slot ] cache ; - -<< - -TUPLE: operation from to reg-class ; - -SYNTAX: OPERATION: - CREATE-CLASS dup save-location - [ operation { } define-tuple-class ] - [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ; - ->> - -OPERATION: register->memory -OPERATION: memory->register -OPERATION: register->register - -! This should never come up because of how spill slots are assigned, -! so make it an error. -: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ; - -GENERIC: >insn ( operation -- ) - -M: register->memory >insn - [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ; - -M: memory->register >insn - [ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ; - -M: register->register >insn - [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; - -SYMBOL: froms -SYMBOL: tos - -: from-reg ( operation -- seq ) - [ from>> ] [ reg-class>> ] bi 2array ; - -: to-reg ( operation -- seq ) - [ to>> ] [ reg-class>> ] bi 2array ; - -: start? ( operations -- pair ) - from-reg tos get key? not ; - -: independent-assignment? ( operations -- pair ) - to-reg froms get key? not ; - -: set-tos/froms ( operations -- ) - [ [ [ from-reg ] keep ] H{ } map>assoc froms set ] - [ [ [ to-reg ] keep ] H{ } map>assoc tos set ] - bi ; - -:: (trace-chain) ( obj hashtable -- ) - obj to-reg froms get at* [ - dup , - obj over hashtable clone [ maybe-set-at ] keep swap - [ (trace-chain) ] [ 2drop ] if - ] [ - drop - ] if ; - -: trace-chain ( obj -- seq ) - [ - dup , - dup dup associate (trace-chain) - ] { } make prune reverse ; - -: trace-chains ( seq -- seq' ) - [ trace-chain ] map concat ; - -ERROR: resolve-error ; - -: split-cycle ( operations -- chain spilled-operation ) - unclip [ - [ set-tos/froms ] - [ - [ start? ] find nip - [ resolve-error ] unless* trace-chain - ] bi - ] dip ; - -: break-cycle-n ( operations -- operations' ) - split-cycle [ - [ from>> ] - [ reg-class>> spill-temp ] - [ reg-class>> ] - tri \ register->memory boa - ] [ - [ reg-class>> spill-temp ] - [ to>> ] - [ reg-class>> ] - tri \ memory->register boa - ] bi [ 1array ] bi@ surround ; - -: break-cycle ( operations -- operations' ) - dup length { - { 1 [ ] } - [ drop break-cycle-n ] - } case ; - -: (group-cycles) ( seq -- ) - [ - dup set-tos/froms - unclip trace-chain - [ diff ] keep , (group-cycles) - ] unless-empty ; - -: group-cycles ( seq -- seqs ) - [ (group-cycles) ] { } make ; - -: remove-dead-mappings ( seq -- seq' ) - prune [ [ from-reg ] [ to-reg ] bi = not ] filter ; - -: parallel-mappings ( operations -- seq ) - [ - [ independent-assignment? not ] partition % - [ start? not ] partition - [ trace-chain ] map concat dup % - diff group-cycles [ break-cycle ] map concat % - ] { } make remove-dead-mappings ; - -: mapping-instructions ( mappings -- insns ) - [ { } ] [ - [ - [ set-tos/froms ] [ parallel-mappings ] bi - [ [ >insn ] each ] { } make - ] with-scope - ] if-empty ; - -: init-mapping ( -- ) - H{ } clone spill-temps set ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 56beaa5379..baa5099d8f 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -1,26 +1,24 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators -combinators.short-circuit fry kernel locals -make math sequences +combinators.short-circuit fry kernel locals namespaces +make math sequences hashtables compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities compiler.cfg.instructions +compiler.cfg.parallel-copy compiler.cfg.linear-scan.assignment -compiler.cfg.linear-scan.mapping ; +compiler.cfg.linear-scan.allocation.state ; IN: compiler.cfg.linear-scan.resolve +SYMBOL: spill-temps + +: spill-temp ( reg-class -- n ) + spill-temps get [ next-spill-slot ] cache ; + : add-mapping ( from to reg-class -- ) - over spill-slot? [ - pick spill-slot? - [ memory->memory ] - [ register->memory ] if - ] [ - pick spill-slot? - [ memory->register ] - [ register->register ] if - ] if ; + '[ _ 2array ] bi@ 2array , ; :: resolve-value-data-flow ( bb to vreg -- ) vreg bb vreg-at-end @@ -33,6 +31,36 @@ IN: compiler.cfg.linear-scan.resolve [ resolve-value-data-flow ] with with each ] { } make ; +: memory->register ( from to -- ) + swap [ first2 ] [ first n>> ] bi* _reload ; + +: register->memory ( from to -- ) + [ first2 ] [ first n>> ] bi* _spill ; + +: temp->register ( from to -- ) + nip [ first ] [ second ] [ second spill-temp ] tri _reload ; + +: register->temp ( from to -- ) + drop [ first2 ] [ second spill-temp ] bi _spill ; + +: register->register ( from to -- ) + swap [ first ] [ first2 ] bi* _copy ; + +SYMBOL: temp + +: >insn ( from to -- ) + { + { [ over temp eq? ] [ temp->register ] } + { [ dup temp eq? ] [ register->temp ] } + { [ over first spill-slot? ] [ memory->register ] } + { [ dup first spill-slot? ] [ register->memory ] } + [ register->register ] + } cond ; + +: mapping-instructions ( alist -- insns ) + >hashtable + [ temp [ swap >insn ] parallel-mapping ] { } make ; + : perform-mappings ( bb to mappings -- ) dup empty? [ 3drop ] [ mapping-instructions @@ -46,4 +74,5 @@ IN: compiler.cfg.linear-scan.resolve dup successors>> [ resolve-edge-data-flow ] with each ; : resolve-data-flow ( cfg -- ) + H{ } clone spill-temps set [ resolve-block-data-flow ] each-basic-block ; diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy.factor b/basis/compiler/cfg/parallel-copy/parallel-copy.factor index 550928b8ba..f5abc4be60 100644 --- a/basis/compiler/cfg/parallel-copy/parallel-copy.factor +++ b/basis/compiler/cfg/parallel-copy/parallel-copy.factor @@ -23,7 +23,7 @@ SYMBOLS: temp locs preds to-do ready ; temp set to-do set ready set - [ preds set ] + [ [ eq? not ] assoc-filter preds set ] [ [ nip dup ] H{ } assoc-map-as locs set ] [ keys [ init-to-do ] [ init-ready ] bi ] tri ; From 009cfbfc8d2d4af48ce98e376aa1d43a6ae23c12 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 07:40:09 -0500 Subject: [PATCH 62/81] compiler.cfg.utilities: fix stack effect declaration --- basis/compiler/cfg/utilities/utilities.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 9d6927b143..8cb70cc649 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -49,7 +49,7 @@ SYMBOL: visited : has-phis? ( bb -- ? ) instructions>> first ##phi? ; -: cfg-has-phis? ( cfg -- ) +: cfg-has-phis? ( cfg -- ? ) post-order [ has-phis? ] any? ; : if-has-phis ( bb quot: ( bb -- ) -- ) From 18717a449fda1419f036068410e27b75d74e216e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 07:41:41 -0500 Subject: [PATCH 63/81] compiler.cfg.linear-scan.resolve: unit tests --- .../linear-scan/resolve/resolve-tests.factor | 58 +++++++++++++++++++ 1 file changed, 58 insertions(+) create mode 100644 basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor new file mode 100644 index 0000000000..7c1b99dfda --- /dev/null +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -0,0 +1,58 @@ +IN: compiler.cfg.linear-scan.resolve.tests +USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces +compiler.cfg.instructions cpu.architecture make +compiler.cfg.linear-scan.allocation.state ; + +[ + { + { { T{ spill-slot f 0 } int-regs } { 1 int-regs } } + } +] [ + [ + 0 1 int-regs add-mapping + ] { } make +] unit-test + +[ + { + T{ _reload { dst 1 } { class int-regs } { n 0 } } + } +] [ + [ + { T{ spill-slot f 0 } int-regs } { 1 int-regs } >insn + ] { } make +] unit-test + +[ + { + T{ _spill { src 1 } { class int-regs } { n 0 } } + } +] [ + [ + { 1 int-regs } { T{ spill-slot f 0 } int-regs } >insn + ] { } make +] unit-test + +[ + { + T{ _copy { src 1 } { dst 2 } { class int-regs } } + } +] [ + [ + { 1 int-regs } { 2 int-regs } >insn + ] { } make +] unit-test + +H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set +H{ } clone spill-temps set + +[ + { + T{ _spill { src 1 } { class int-regs } { n 10 } } + T{ _copy { dst 1 } { src 0 } { class int-regs } } + T{ _reload { dst 0 } { class int-regs } { n 10 } } + } +] [ + { { { 0 int-regs } { 1 int-regs } } { { 1 int-regs } { 0 int-regs } } } + mapping-instructions +] unit-test \ No newline at end of file From cf26800dbda10250129cb4d362b120b08b6ec117 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 07:51:44 -0500 Subject: [PATCH 64/81] Revert "compiler.cfg.coalescing: some cleanups" This reverts commit e5834c4ba7bb52c720d9bd90b4a15f34274aee1b. --- .../compiler/cfg/coalescing/coalescing.factor | 15 ++------- .../cfg/coalescing/copies/copies.factor | 21 ++++++++++++ .../process-blocks/process-blocks.factor | 32 +++++++++---------- .../cfg/coalescing/renaming/renaming.factor | 2 +- 4 files changed, 40 insertions(+), 30 deletions(-) create mode 100644 basis/compiler/cfg/coalescing/copies/copies.factor diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor index 5deb375572..86dee8a3be 100644 --- a/basis/compiler/cfg/coalescing/coalescing.factor +++ b/basis/compiler/cfg/coalescing/coalescing.factor @@ -1,17 +1,17 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs fry kernel locals math math.order -sequences namespaces sets make +sequences namespaces sets compiler.cfg.rpo compiler.cfg.def-use compiler.cfg.utilities compiler.cfg.dominance compiler.cfg.instructions compiler.cfg.liveness.ssa -compiler.cfg.parallel-copy compiler.cfg.critical-edges compiler.cfg.coalescing.state compiler.cfg.coalescing.forest +compiler.cfg.coalescing.copies compiler.cfg.coalescing.renaming compiler.cfg.coalescing.live-ranges compiler.cfg.coalescing.process-blocks ; @@ -29,7 +29,7 @@ SYMBOL: seen :: visit-renaming ( dst assoc src bb -- ) src seen get key? [ - dst src bb waiting-for set-at + src dst bb waiting-for push-at src assoc delete-at ] [ src seen get conjoin ] if ; @@ -41,15 +41,6 @@ SYMBOL: seen ] assoc-each ] assoc-each ; -: insert-copies ( -- ) - waiting get [ - [ instructions>> building ] dip '[ - building get pop - _ parallel-copy - , - ] with-variable - ] assoc-each ; - : remove-phis-from-block ( bb -- ) instructions>> [ ##phi? not ] filter-here ; diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/coalescing/copies/copies.factor new file mode 100644 index 0000000000..5df2684f72 --- /dev/null +++ b/basis/compiler/cfg/coalescing/copies/copies.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs hashtables fry kernel make namespaces +sequences compiler.cfg.coalescing.state compiler.cfg.parallel-copy ; +IN: compiler.cfg.coalescing.copies + +: compute-copies ( assoc -- assoc' ) + dup assoc-size [ + '[ + [ 2dup eq? [ 2drop ] [ _ 2dup key? [ "OOPS" throw ] [ set-at ] if ] if ] with each + ] assoc-each + ] keep ; + +: insert-copies ( -- ) + waiting get [ + [ instructions>> building ] dip '[ + building get pop + _ compute-copies parallel-copy + , + ] with-variable + ] assoc-each ; \ No newline at end of file diff --git a/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor index cc7b923105..005c71f357 100644 --- a/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor +++ b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor @@ -47,7 +47,7 @@ SYMBOLS: phi-union unioned-blocks ; 2nip processed-name ; :: trivial-interference ( bb src dst -- ) - src dst bb waiting-for set-at + dst src bb waiting-for push-at src used-by-another get push ; :: add-to-renaming-set ( bb src dst -- ) @@ -118,21 +118,20 @@ SYMBOLS: visited work-list ; [ push-all-front ] keep [ work-list set ] [ process-df-nodes ] bi ; -: add-local-interferences ( ##phi -- ) +:: add-local-interferences ( bb ##phi -- ) ! bb contains the phi node. If the input is defined in the same ! block as the phi node, we have to check for interference. ! This can only happen if the value is carried by a back edge. - - ! XXX: in the LLVM version they only add an interference if - ! the operand is defined in the same block as the ##phi, but - ! this doesn't work here. Investigate - [ phi-union get ] dip dst>> '[ drop _ 2array , ] assoc-each ; + phi-union get [ + drop dup def-of bb eq? + [ ##phi dst>> 2array , ] [ drop ] if + ] assoc-each ; -: compute-local-interferences ( ##phi -- pairs ) +: compute-local-interferences ( bb ##phi -- pairs ) [ - [ phi-union get keys compute-dom-forest process-phi-union ] + [ phi-union get keys compute-dom-forest process-phi-union drop ] [ add-local-interferences ] - bi + 2bi ] { } make ; :: insert-copies-for-interference ( ##phi src -- ) @@ -150,14 +149,13 @@ SYMBOLS: visited work-list ; dst>> phi-union get swap renaming-sets get set-at phi-union get [ drop processed-name ] assoc-each ; -: process-phi ( ##phi -- ) +:: process-phi ( bb ##phi -- ) H{ } clone phi-union set H{ } clone unioned-blocks set - [ [ inputs>> ] [ dst>> ] bi '[ _ process-phi-operand ] assoc-each ] - [ dup compute-local-interferences process-local-interferences ] - [ add-renaming-set ] - tri ; + ##phi inputs>> ##phi dst>> '[ _ process-phi-operand ] assoc-each + ##phi bb ##phi compute-local-interferences process-local-interferences + ##phi add-renaming-set ; : process-block ( bb -- ) - instructions>> - [ dup ##phi? [ process-phi t ] [ drop f ] if ] all? drop ; + dup instructions>> + [ dup ##phi? [ process-phi t ] [ 2drop f ] if ] with all? drop ; diff --git a/basis/compiler/cfg/coalescing/renaming/renaming.factor b/basis/compiler/cfg/coalescing/renaming/renaming.factor index 15062d17c4..848d0a4df0 100644 --- a/basis/compiler/cfg/coalescing/renaming/renaming.factor +++ b/basis/compiler/cfg/coalescing/renaming/renaming.factor @@ -37,7 +37,7 @@ IN: compiler.cfg.coalescing.renaming : rename-copies ( -- ) waiting renamings get '[ [ - [ [ _ ?at drop ] bi@ ] assoc-map + [ _ [ ?at drop ] [ '[ _ ?at drop ] map ] bi-curry bi* ] assoc-map ] assoc-map ] change ; From 3edf4a2b757a477a64721bd92c3a0dc851871d49 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 08:47:03 -0500 Subject: [PATCH 65/81] compiler.cfg.coalescing: cleanups --- .../cfg/coalescing/copies/copies.factor | 9 ++- .../process-blocks/process-blocks.factor | 75 +++++++------------ 2 files changed, 34 insertions(+), 50 deletions(-) diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/coalescing/copies/copies.factor index 5df2684f72..f691002d64 100644 --- a/basis/compiler/cfg/coalescing/copies/copies.factor +++ b/basis/compiler/cfg/coalescing/copies/copies.factor @@ -4,10 +4,17 @@ USING: accessors assocs hashtables fry kernel make namespaces sequences compiler.cfg.coalescing.state compiler.cfg.parallel-copy ; IN: compiler.cfg.coalescing.copies +ERROR: bad-copy ; + : compute-copies ( assoc -- assoc' ) dup assoc-size [ '[ - [ 2dup eq? [ 2drop ] [ _ 2dup key? [ "OOPS" throw ] [ set-at ] if ] if ] with each + [ + 2dup eq? [ 2drop ] [ + _ 2dup key? + [ bad-copy ] [ set-at ] if + ] if + ] with each ] assoc-each ] keep ; diff --git a/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor index 005c71f357..bba40a66f4 100644 --- a/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor +++ b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs fry kernel locals math math.order arrays -namespaces sequences sorting sets combinators combinators.short-circuit -dlists deques make +namespaces sequences sorting sets combinators combinators.short-circuit make compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.liveness @@ -61,8 +60,6 @@ SYMBOLS: phi-union unioned-blocks ; [ add-to-renaming-set ] } cond ; -SYMBOLS: visited work-list ; - : node-is-live-in-of-child? ( node child -- ? ) [ vreg>> ] [ bb>> live-in ] bi* key? ; @@ -86,52 +83,31 @@ SYMBOLS: visited work-list ; : add-interference ( ##phi node child -- ) [ vreg>> ] bi@ 2array , drop ; -: add-to-work-list ( child -- inserted? ) - dup visited get key? [ drop f ] [ work-list get push-back t ] if ; - -: process-df-child ( ##phi node child -- inserted? ) - [ - { - { [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] } - { [ 2dup node-is-live-in-of-child? ] [ add-interference ] } - { [ 2dup defined-in-same-block? ] [ add-interference ] } - [ 3drop ] - } cond - ] - [ add-to-work-list ] - bi ; +: process-df-child ( ##phi node child -- ) + { + { [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] } + { [ 2dup node-is-live-in-of-child? ] [ add-interference ] } + { [ 2dup defined-in-same-block? ] [ add-interference ] } + [ 3drop ] + } cond ; : process-df-node ( ##phi node -- ) - dup visited get conjoin - dup children>> [ process-df-child ] with with map - [ ] any? [ work-list get pop-back* ] unless ; - -: process-df-nodes ( ##phi work-list -- ) - dup deque-empty? [ 2drop ] [ - [ peek-back process-df-node ] - [ process-df-nodes ] - 2bi - ] if ; + dup children>> + [ [ process-df-child ] with with each ] + [ nip [ process-df-node ] with each ] + 3bi ; : process-phi-union ( ##phi dom-forest -- ) - H{ } clone visited set - [ push-all-front ] keep - [ work-list set ] [ process-df-nodes ] bi ; + [ process-df-node ] with each ; -:: add-local-interferences ( bb ##phi -- ) - ! bb contains the phi node. If the input is defined in the same - ! block as the phi node, we have to check for interference. - ! This can only happen if the value is carried by a back edge. - phi-union get [ - drop dup def-of bb eq? - [ ##phi dst>> 2array , ] [ drop ] if - ] assoc-each ; +: add-local-interferences ( ##phi -- ) + [ phi-union get ] dip dst>> '[ drop _ 2array , ] assoc-each ; -: compute-local-interferences ( bb ##phi -- pairs ) +: compute-local-interferences ( ##phi -- pairs ) [ - [ phi-union get keys compute-dom-forest process-phi-union drop ] + [ phi-union get keys compute-dom-forest process-phi-union ] [ add-local-interferences ] - 2bi + bi ] { } make ; :: insert-copies-for-interference ( ##phi src -- ) @@ -146,16 +122,17 @@ SYMBOLS: visited work-list ; ] with each ; : add-renaming-set ( ##phi -- ) - dst>> phi-union get swap renaming-sets get set-at + [ phi-union get ] dip dst>> renaming-sets get set-at phi-union get [ drop processed-name ] assoc-each ; -:: process-phi ( bb ##phi -- ) +: process-phi ( ##phi -- ) H{ } clone phi-union set H{ } clone unioned-blocks set - ##phi inputs>> ##phi dst>> '[ _ process-phi-operand ] assoc-each - ##phi bb ##phi compute-local-interferences process-local-interferences - ##phi add-renaming-set ; + [ [ inputs>> ] [ dst>> ] bi '[ _ process-phi-operand ] assoc-each ] + [ dup compute-local-interferences process-local-interferences ] + [ add-renaming-set ] + tri ; : process-block ( bb -- ) - dup instructions>> - [ dup ##phi? [ process-phi t ] [ 2drop f ] if ] with all? drop ; + instructions>> + [ dup ##phi? [ process-phi t ] [ drop f ] if ] all? drop ; From e6f5eab59847a5566d28254d5aea86afed430162 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 08:47:35 -0500 Subject: [PATCH 66/81] compiler.cfg.linear-scan: fix resolve pass --- basis/compiler/cfg/linear-scan/resolve/resolve.factor | 4 ++-- basis/compiler/cfg/parallel-copy/parallel-copy.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index baa5099d8f..932e3dc6d6 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -23,7 +23,7 @@ SYMBOL: spill-temps :: resolve-value-data-flow ( bb to vreg -- ) vreg bb vreg-at-end vreg to vreg-at-start - 2dup eq? [ 2drop ] [ vreg reg-class>> add-mapping ] if ; + 2dup = [ 2drop ] [ vreg reg-class>> add-mapping ] if ; : compute-mappings ( bb to -- mappings ) [ @@ -58,7 +58,7 @@ SYMBOL: temp } cond ; : mapping-instructions ( alist -- insns ) - >hashtable + [ swap ] H{ } assoc-map-as [ temp [ swap >insn ] parallel-mapping ] { } make ; : perform-mappings ( bb to mappings -- ) diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy.factor b/basis/compiler/cfg/parallel-copy/parallel-copy.factor index f5abc4be60..5a1bfcd111 100644 --- a/basis/compiler/cfg/parallel-copy/parallel-copy.factor +++ b/basis/compiler/cfg/parallel-copy/parallel-copy.factor @@ -23,7 +23,7 @@ SYMBOLS: temp locs preds to-do ready ; temp set to-do set ready set - [ [ eq? not ] assoc-filter preds set ] + [ preds set ] [ [ nip dup ] H{ } assoc-map-as locs set ] [ keys [ init-to-do ] [ init-ready ] bi ] tri ; From ff81b055a503e346682be1748075be02088ab6fe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 08:47:50 -0500 Subject: [PATCH 67/81] compiler.cfg.utilities: add loop-entry? word --- basis/compiler/cfg/linearization/linearization.factor | 3 +-- basis/compiler/cfg/utilities/utilities.factor | 3 +++ 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index f9e0e54afc..cc148d34d8 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -26,8 +26,7 @@ M: insn linearize-insn , drop ; [ number>> ] bi@ 1 - = ; inline : emit-loop-entry? ( bb successor -- ? ) - [ back-edge? not ] - [ nip dup predecessors>> [ swap back-edge? ] with any? ] 2bi and ; + [ back-edge? not ] [ nip loop-entry? ] 2bi and ; : emit-branch ( bb successor -- ) 2dup emit-loop-entry? [ _loop-entry ] when diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 8cb70cc649..d242d5d90d 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -15,6 +15,9 @@ PREDICATE: kill-block < basic-block : back-edge? ( from to -- ? ) [ number>> ] bi@ >= ; +: loop-entry? ( bb -- ? ) + dup predecessors>> [ swap back-edge? ] with any? ; + : empty-block? ( bb -- ? ) instructions>> { [ length 1 = ] From d394dd3c36bf2a37327476484adbb328c207a214 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 08:48:05 -0500 Subject: [PATCH 68/81] compiler.cfg.branch-splitting: re-enable with a better heuristic --- .../branch-splitting/branch-splitting.factor | 26 ++++++++++++++++--- basis/compiler/cfg/optimizer/optimizer.factor | 2 +- 2 files changed, 23 insertions(+), 5 deletions(-) diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index 89e3604aec..8618932e14 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -54,13 +54,31 @@ UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ; : split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ; -: split-branch? ( bb -- ? ) +: short-tail-block? ( bb -- ? ) + [ successors>> empty? ] [ instructions>> length 2 = ] bi and ; + +: short-block? ( bb -- ? ) + ! If block is empty, always split + [ predecessors>> length ] [ instructions>> length 1 - ] bi * 10 <= ; + +: cond-cond-block? ( bb -- ? ) { - [ dup successors>> [ back-edge? ] with any? not ] - [ predecessors>> length 2 4 between? ] - [ instructions>> split-instructions? ] + [ predecessors>> length 2 = ] + [ successors>> length 2 = ] + [ instructions>> length 20 <= ] } 1&& ; +: split-branch? ( bb -- ? ) + dup loop-entry? [ drop f ] [ + dup predecessors>> length 1 <= [ drop f ] [ + { + [ short-block? ] + [ short-tail-block? ] + [ cond-cond-block? ] + } 1|| + ] if + ] if ; + : split-branches ( cfg -- cfg' ) dup [ dup split-branch? [ split-branch ] [ drop ] if diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index cbccf42c34..b411c42a35 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -32,7 +32,7 @@ SYMBOL: check-optimizer? optimize-tail-calls delete-useless-conditionals compute-predecessors - ! split-branches + split-branches join-blocks compute-predecessors construct-ssa From 80e10f1bd033e65fd5b17e634d0bb52b28f05e8e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 08:56:14 -0500 Subject: [PATCH 69/81] compiler.cfg: Fix some unit tests --- basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor | 6 +++--- .../cfg/value-numbering/value-numbering-tests.factor | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index 7c1b99dfda..68f7544e8e 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -48,9 +48,9 @@ H{ } clone spill-temps set [ { - T{ _spill { src 1 } { class int-regs } { n 10 } } - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n 10 } } + T{ _spill { src 0 } { class int-regs } { n 10 } } + T{ _copy { dst 0 } { src 1 } { class int-regs } } + T{ _reload { dst 1 } { class int-regs } { n 10 } } } ] [ { { { 0 int-regs } { 1 int-regs } } { { 1 int-regs } { 0 int-regs } } } diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 60d06fcde4..bec0c27aeb 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -3,7 +3,7 @@ USING: compiler.cfg.value-numbering compiler.cfg.instructions compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons cpu.architecture tools.test kernel math combinators.short-circuit accessors sequences compiler.cfg.predecessors locals -compiler.cfg.phi-elimination compiler.cfg.dce +compiler.cfg.dce compiler.cfg.coalescing compiler.cfg assocs vectors arrays layouts namespaces ; : trim-temps ( insns -- insns ) @@ -1191,14 +1191,14 @@ test-diamond cfg new 0 get >>entry value-numbering compute-predecessors - eliminate-phis drop + coalesce drop ] unit-test [ 1 ] [ 1 get successors>> length ] unit-test [ t ] [ 1 get successors>> first 3 get eq? ] unit-test -[ 3 ] [ 4 get instructions>> length ] unit-test +[ 2 ] [ 4 get instructions>> length ] unit-test V{ T{ ##peek f V int-regs 0 D 0 } From d10993b837276f6641937dba3f16647d67bdb42d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 09:34:08 -0500 Subject: [PATCH 70/81] compiler.cfg: Rename ssa to ssa.construction, coalescing to ssa.destruction --- basis/compiler/cfg/builder/builder.factor | 2 +- basis/compiler/cfg/optimizer/optimizer.factor | 4 ++-- .../construction-tests.factor} | 4 ++-- .../construction.factor} | 2 +- .../destruction}/copies/copies.factor | 4 ++-- .../destruction/destruction.factor} | 16 ++++++++-------- .../destruction}/forest/forest-tests.factor | 4 ++-- .../destruction}/forest/forest.factor | 0 .../interference/interference.factor | 4 ++-- .../destruction}/live-ranges/live-ranges.factor | 2 +- .../process-blocks/process-blocks.factor | 8 ++++---- .../destruction}/renaming/renaming.factor | 4 ++-- .../destruction}/state/state.factor | 2 +- .../value-numbering/value-numbering-tests.factor | 2 +- 14 files changed, 29 insertions(+), 29 deletions(-) rename basis/compiler/cfg/ssa/{ssa-tests.factor => construction/construction-tests.factor} (95%) rename basis/compiler/cfg/ssa/{ssa.factor => construction/construction.factor} (98%) rename basis/compiler/cfg/{coalescing => ssa/destruction}/copies/copies.factor (83%) rename basis/compiler/cfg/{coalescing/coalescing.factor => ssa/destruction/destruction.factor} (81%) rename basis/compiler/cfg/{coalescing => ssa/destruction}/forest/forest-tests.factor (94%) rename basis/compiler/cfg/{coalescing => ssa/destruction}/forest/forest.factor (100%) rename basis/compiler/cfg/{coalescing => ssa/destruction}/interference/interference.factor (93%) rename basis/compiler/cfg/{coalescing => ssa/destruction}/live-ranges/live-ranges.factor (97%) rename basis/compiler/cfg/{coalescing => ssa/destruction}/process-blocks/process-blocks.factor (96%) rename basis/compiler/cfg/{coalescing => ssa/destruction}/renaming/renaming.factor (91%) rename basis/compiler/cfg/{coalescing => ssa/destruction}/state/state.factor (92%) diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index ed1069d043..0c40b93ba6 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -23,7 +23,7 @@ compiler.alien ; IN: compiler.cfg.builder ! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is -! constructed later by calling compiler.cfg.ssa:construct-ssa. +! constructed later by calling compiler.cfg.ssa.construction:construct-ssa. SYMBOL: procedures SYMBOL: loops diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index b411c42a35..52c4c40c09 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -5,13 +5,13 @@ compiler.cfg.tco compiler.cfg.useless-conditionals compiler.cfg.branch-splitting compiler.cfg.block-joining -compiler.cfg.ssa +compiler.cfg.ssa.construction compiler.cfg.alias-analysis compiler.cfg.value-numbering compiler.cfg.copy-prop compiler.cfg.dce compiler.cfg.write-barrier -compiler.cfg.coalescing +compiler.cfg.ssa.destruction compiler.cfg.empty-blocks compiler.cfg.predecessors compiler.cfg.rpo diff --git a/basis/compiler/cfg/ssa/ssa-tests.factor b/basis/compiler/cfg/ssa/construction/construction-tests.factor similarity index 95% rename from basis/compiler/cfg/ssa/ssa-tests.factor rename to basis/compiler/cfg/ssa/construction/construction-tests.factor index 6a3a014f78..da0f320130 100644 --- a/basis/compiler/cfg/ssa/ssa-tests.factor +++ b/basis/compiler/cfg/ssa/construction/construction-tests.factor @@ -1,9 +1,9 @@ USING: accessors compiler.cfg compiler.cfg.debugger compiler.cfg.dominance compiler.cfg.instructions -compiler.cfg.predecessors compiler.cfg.ssa assocs +compiler.cfg.predecessors compiler.cfg.ssa.construction assocs compiler.cfg.registers cpu.architecture kernel namespaces sequences tools.test vectors ; -IN: compiler.cfg.ssa.tests +IN: compiler.cfg.ssa.construction.tests : reset-counters ( -- ) ! Reset counters so that results are deterministic w.r.t. hash order diff --git a/basis/compiler/cfg/ssa/ssa.factor b/basis/compiler/cfg/ssa/construction/construction.factor similarity index 98% rename from basis/compiler/cfg/ssa/ssa.factor rename to basis/compiler/cfg/ssa/construction/construction.factor index 410d8fd951..23bed8bce0 100644 --- a/basis/compiler/cfg/ssa/ssa.factor +++ b/basis/compiler/cfg/ssa/construction/construction.factor @@ -10,7 +10,7 @@ compiler.cfg.liveness compiler.cfg.registers compiler.cfg.dominance compiler.cfg.instructions ; -IN: compiler.cfg.ssa +IN: compiler.cfg.ssa.construction ! SSA construction. Predecessors must be computed first. diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/ssa/destruction/copies/copies.factor similarity index 83% rename from basis/compiler/cfg/coalescing/copies/copies.factor rename to basis/compiler/cfg/ssa/destruction/copies/copies.factor index f691002d64..063704e0f6 100644 --- a/basis/compiler/cfg/coalescing/copies/copies.factor +++ b/basis/compiler/cfg/ssa/destruction/copies/copies.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs hashtables fry kernel make namespaces -sequences compiler.cfg.coalescing.state compiler.cfg.parallel-copy ; -IN: compiler.cfg.coalescing.copies +sequences compiler.cfg.ssa.destruction.state compiler.cfg.parallel-copy ; +IN: compiler.cfg.ssa.destruction.copies ERROR: bad-copy ; diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor similarity index 81% rename from basis/compiler/cfg/coalescing/coalescing.factor rename to basis/compiler/cfg/ssa/destruction/destruction.factor index 86dee8a3be..2d0cd26798 100644 --- a/basis/compiler/cfg/coalescing/coalescing.factor +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -9,15 +9,15 @@ compiler.cfg.dominance compiler.cfg.instructions compiler.cfg.liveness.ssa compiler.cfg.critical-edges -compiler.cfg.coalescing.state -compiler.cfg.coalescing.forest -compiler.cfg.coalescing.copies -compiler.cfg.coalescing.renaming -compiler.cfg.coalescing.live-ranges -compiler.cfg.coalescing.process-blocks ; -IN: compiler.cfg.coalescing +compiler.cfg.ssa.destruction.state +compiler.cfg.ssa.destruction.forest +compiler.cfg.ssa.destruction.copies +compiler.cfg.ssa.destruction.renaming +compiler.cfg.ssa.destruction.live-ranges +compiler.cfg.ssa.destruction.process-blocks ; +IN: compiler.cfg.ssa.destruction -! Fast Copy Coalescing and Live-Range Identification +! Based on "Fast Copy Coalescing and Live-Range Identification" ! http://www.cs.ucsd.edu/classes/sp02/cse231/kenpldi.pdf ! Dominance, liveness and def-use need to be computed diff --git a/basis/compiler/cfg/coalescing/forest/forest-tests.factor b/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor similarity index 94% rename from basis/compiler/cfg/coalescing/forest/forest-tests.factor rename to basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor index 3cbcbb186a..a74947e5df 100644 --- a/basis/compiler/cfg/coalescing/forest/forest-tests.factor +++ b/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor @@ -1,9 +1,9 @@ -USING: accessors compiler.cfg compiler.cfg.coalescing.forest +USING: accessors compiler.cfg compiler.cfg.ssa.destruction.forest compiler.cfg.debugger compiler.cfg.dominance compiler.cfg.instructions compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.def-use cpu.architecture kernel namespaces sequences tools.test vectors sorting math.order ; -IN: compiler.cfg.coalescing.forest.tests +IN: compiler.cfg.ssa.destruction.forest.tests V{ T{ ##peek f V int-regs 0 D 0 } } clone 0 test-bb V{ T{ ##peek f V int-regs 1 D 0 } } clone 1 test-bb diff --git a/basis/compiler/cfg/coalescing/forest/forest.factor b/basis/compiler/cfg/ssa/destruction/forest/forest.factor similarity index 100% rename from basis/compiler/cfg/coalescing/forest/forest.factor rename to basis/compiler/cfg/ssa/destruction/forest/forest.factor diff --git a/basis/compiler/cfg/coalescing/interference/interference.factor b/basis/compiler/cfg/ssa/destruction/interference/interference.factor similarity index 93% rename from basis/compiler/cfg/coalescing/interference/interference.factor rename to basis/compiler/cfg/ssa/destruction/interference/interference.factor index 4e0ca99834..4bb55a00aa 100644 --- a/basis/compiler/cfg/coalescing/interference/interference.factor +++ b/basis/compiler/cfg/ssa/destruction/interference/interference.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators combinators.short-circuit kernel math namespaces sequences locals compiler.cfg.def-use -compiler.cfg.dominance compiler.cfg.coalescing.live-ranges ; -IN: compiler.cfg.coalescing.interference +compiler.cfg.dominance compiler.cfg.ssa.destruction.live-ranges ; +IN: compiler.cfg.ssa.destruction.interference dup [ diff --git a/basis/compiler/cfg/coalescing/state/state.factor b/basis/compiler/cfg/ssa/destruction/state/state.factor similarity index 92% rename from basis/compiler/cfg/coalescing/state/state.factor rename to basis/compiler/cfg/ssa/destruction/state/state.factor index 6174945ccb..30e69521b9 100644 --- a/basis/compiler/cfg/coalescing/state/state.factor +++ b/basis/compiler/cfg/ssa/destruction/state/state.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces sets kernel assocs ; -IN: compiler.cfg.coalescing.state +IN: compiler.cfg.ssa.destruction.state SYMBOLS: processed-names waiting used-by-another renaming-sets ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index bec0c27aeb..c5b064b2d3 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -3,7 +3,7 @@ USING: compiler.cfg.value-numbering compiler.cfg.instructions compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons cpu.architecture tools.test kernel math combinators.short-circuit accessors sequences compiler.cfg.predecessors locals -compiler.cfg.dce compiler.cfg.coalescing +compiler.cfg.dce compiler.cfg.ssa.destruction compiler.cfg assocs vectors arrays layouts namespaces ; : trim-temps ( insns -- insns ) From 5fe3bcff4d4ae6ae8977bcdad500bd5c1a611382 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 11:14:57 -0500 Subject: [PATCH 71/81] Faster bit-array equality, add bit-set-subset? word --- basis/bit-arrays/bit-arrays.factor | 2 +- basis/bit-sets/bit-sets.factor | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 17c391636f..42655aceb8 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -61,7 +61,7 @@ M: bit-array like drop dup bit-array? [ >bit-array ] unless ; M: bit-array new-sequence drop ; M: bit-array equal? - over bit-array? [ sequence= ] [ 2drop f ] if ; + over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ; M: bit-array resize [ drop ] [ diff --git a/basis/bit-sets/bit-sets.factor b/basis/bit-sets/bit-sets.factor index 0e97968965..34b7f13dc2 100644 --- a/basis/bit-sets/bit-sets.factor +++ b/basis/bit-sets/bit-sets.factor @@ -26,4 +26,6 @@ HINTS: bit-set-intersect bit-array bit-array ; : bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ; -HINTS: bit-set-diff bit-array bit-array ; \ No newline at end of file +HINTS: bit-set-diff bit-array bit-array ; + +: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ; \ No newline at end of file From 62fe3087769f299d4b17f475551345c978f40dc8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 11:16:10 -0500 Subject: [PATCH 72/81] compiler.cfg.ssa.construction: Use TDMSC algorithm to compute Phi placement --- .../cfg/dominance/dominance-tests.factor | 31 +---- basis/compiler/cfg/dominance/dominance.factor | 77 +++---------- .../cfg/ssa/construction/construction.factor | 9 +- .../ssa/construction/tdmsc/tdmsc-tests.factor | 75 ++++++++++++ .../cfg/ssa/construction/tdmsc/tdmsc.factor | 109 ++++++++++++++++++ .../cfg/ssa/destruction/destruction.factor | 1 - .../destruction/forest/forest-tests.factor | 3 +- .../cfg/ssa/destruction/forest/forest.factor | 3 +- 8 files changed, 210 insertions(+), 98 deletions(-) create mode 100644 basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor create mode 100644 basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor index 3da98a5e87..07bcd7bc84 100644 --- a/basis/compiler/cfg/dominance/dominance-tests.factor +++ b/basis/compiler/cfg/dominance/dominance-tests.factor @@ -6,9 +6,7 @@ compiler.cfg.predecessors ; : test-dominance ( -- ) cfg new 0 get >>entry compute-predecessors - dup compute-dominance - dup compute-dom-frontiers - compute-dfs ; + compute-dominance ; ! Example with no back edges V{ } 0 test-bb @@ -35,11 +33,6 @@ V{ } 5 test-bb [ t ] [ 0 get dom-children 1 get 2 get 4 get 3array set= ] unit-test -[ { 4 } ] [ 1 get dom-frontier [ number>> ] map ] unit-test -[ { 4 } ] [ 2 get dom-frontier [ number>> ] map ] unit-test -[ { } ] [ 0 get dom-frontier ] unit-test -[ { } ] [ 4 get dom-frontier ] unit-test - [ t ] [ 0 get 3 get dominates? ] unit-test [ f ] [ 3 get 4 get dominates? ] unit-test [ f ] [ 1 get 4 get dominates? ] unit-test @@ -81,25 +74,3 @@ V{ } 5 test-bb [ ] [ test-dominance ] unit-test [ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test - -V{ } 0 test-bb -V{ } 1 test-bb -V{ } 2 test-bb -V{ } 3 test-bb -V{ } 4 test-bb -V{ } 5 test-bb -V{ } 6 test-bb - -0 get 1 get 5 get V{ } 2sequence >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 6 get 1vector >>successors drop -5 get 6 get 1vector >>successors drop - -[ ] [ test-dominance ] unit-test - -[ t ] [ - 2 get 3 get 2array iterated-dom-frontier - 4 get 6 get 2array set= -] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor index ebd3a981d7..325bed74ff 100644 --- a/basis/compiler/cfg/dominance/dominance.factor +++ b/basis/compiler/cfg/dominance/dominance.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators sets math fry kernel math.order -dlists deques namespaces sequences sorting compiler.cfg.rpo ; +dlists deques vectors namespaces sequences sorting locals +compiler.cfg.rpo ; IN: compiler.cfg.dominance ! Reference: @@ -60,60 +61,6 @@ PRIVATE> [ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep dom-childrens set ; -PRIVATE> - -: compute-dominance ( cfg -- ) - compute-dom-parents compute-dom-children ; - - DF(bb) -SYMBOL: dom-frontiers - -: compute-dom-frontier ( bb pred -- ) - 2dup [ dom-parent ] dip eq? [ 2drop ] [ - [ dom-frontiers get conjoin-at ] - [ dom-parent compute-dom-frontier ] 2bi - ] if ; - -PRIVATE> - -: dom-frontier ( bb -- set ) dom-frontiers get at keys ; - -: compute-dom-frontiers ( cfg -- ) - H{ } clone dom-frontiers set - [ - dup predecessors>> dup length 2 >= [ - [ compute-dom-frontier ] with each - ] [ 2drop ] if - ] each-basic-block ; - - - -: iterated-dom-frontier ( bbs -- bbs' ) - [ - work-list set - H{ } clone visited set - [ add-to-work-list ] each - work-list get [ iterated-dom-frontier-step ] slurp-deque - visited get keys - ] with-scope ; - - @@ -131,13 +78,25 @@ PRIVATE> [ dupd maxpreorder get set-at ] tri ; -PRIVATE> - : compute-dfs ( cfg -- ) H{ } clone preorder set H{ } clone maxpreorder set [ 0 ] dip entry>> (compute-dfs) drop ; +PRIVATE> + +: compute-dominance ( cfg -- ) + [ compute-dom-parents compute-dom-children ] [ compute-dfs ] bi ; + : dominates? ( bb1 bb2 -- ? ) - ! Requires DFS to be computed - swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ; \ No newline at end of file + swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ; + +:: breadth-first-order ( cfg -- bfo ) + :> work-list + cfg post-order length :> accum + cfg entry>> work-list push-front + work-list [ + [ accum push ] + [ dom-children work-list push-all-front ] bi + ] slurp-deque + accum ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/construction.factor b/basis/compiler/cfg/ssa/construction/construction.factor index 23bed8bce0..3f131f4782 100644 --- a/basis/compiler/cfg/ssa/construction/construction.factor +++ b/basis/compiler/cfg/ssa/construction/construction.factor @@ -9,7 +9,8 @@ compiler.cfg.renaming compiler.cfg.liveness compiler.cfg.registers compiler.cfg.dominance -compiler.cfg.instructions ; +compiler.cfg.instructions +compiler.cfg.ssa.construction.tdmsc ; IN: compiler.cfg.ssa.construction ! SSA construction. Predecessors must be computed first. @@ -34,9 +35,9 @@ SYMBOL: inserting-phi-nodes : compute-phi-nodes-for ( vreg bbs -- ) dup length 2 >= [ - iterated-dom-frontier [ + [ insert-phi-node-later - ] with each + ] with merge-set-each ] [ 2drop ] if ; : compute-phi-nodes ( -- ) @@ -113,7 +114,7 @@ PRIVATE> [ ] [ compute-live-sets ] [ compute-dominance ] - [ compute-dom-frontiers ] + [ compute-merge-sets ] [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor new file mode 100644 index 0000000000..7691d0e6ce --- /dev/null +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor @@ -0,0 +1,75 @@ +USING: accessors arrays compiler.cfg compiler.cfg.debugger +compiler.cfg.dominance compiler.cfg.predecessors +compiler.cfg.ssa.construction.tdmsc kernel namespaces sequences +tools.test vectors sets ; +IN: compiler.cfg.ssa.construction.tdmsc.tests + +: test-tdmsc ( -- ) + cfg new 0 get >>entry + compute-predecessors + dup compute-dominance + compute-merge-sets ; + +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop +1 get 3 get 1vector >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop + +[ ] [ test-tdmsc ] unit-test + +[ V{ 4 } ] [ 1 get 1array merge-set [ number>> ] map ] unit-test +[ V{ 4 } ] [ 2 get 1array merge-set [ number>> ] map ] unit-test +[ V{ } ] [ 0 get 1array merge-set ] unit-test +[ V{ } ] [ 4 get 1array merge-set ] unit-test + +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb +V{ } 6 test-bb + +0 get 1 get 5 get V{ } 2sequence >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 6 get 1vector >>successors drop +5 get 6 get 1vector >>successors drop + +[ ] [ test-tdmsc ] unit-test + +[ t ] [ + 2 get 3 get 2array merge-set + 4 get 6 get 2array set= +] unit-test + +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb +V{ } 6 test-bb +V{ } 7 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 1vector >>successors drop +2 get 3 get 6 get V{ } 2sequence >>successors drop +3 get 4 get 1vector >>successors drop +6 get 7 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop +5 get 2 get 1vector >>successors drop + +[ ] [ test-tdmsc ] unit-test + +[ V{ 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test +[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor new file mode 100644 index 0000000000..1c1abefe1b --- /dev/null +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor @@ -0,0 +1,109 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs bit-arrays bit-sets fry +hashtables hints kernel locals math namespaces sequences sets +compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ; +IN: compiler.cfg.ssa.construction.tdmsc + +! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for +! Phi-Function Computation Using DJ Graphs" + +! http://portal.acm.org/citation.cfm?id=1065887.1065890 + + ] H{ } map>assoc merge-sets set ; + +: compute-levels ( cfg -- ) + 0 over entry>> associate [ + '[ + _ [ [ dom-parent ] dip at 1 + ] 2keep set-at + ] each-basic-block + ] keep levels set ; + +: j-edge? ( from to -- ? ) + 2dup eq? [ 2drop f ] [ dominates? not ] if ; + +: level ( bb -- n ) levels get at ; inline + +: set-bit ( bit-array n -- ) + [ t ] 2dip swap set-nth ; + +: update-merge-set ( tmp to -- ) + [ merge-sets get ] dip + '[ + _ + [ merge-sets get at bit-set-union ] + [ dupd number>> set-bit ] + bi + ] change-at ; + +:: walk ( tmp to lnode -- lnode ) + tmp level to level >= [ + tmp to update-merge-set + tmp dom-parent to tmp walk + ] [ lnode ] if ; + +: each-incoming-j-edge ( bb quot: ( from to -- ) -- ) + [ [ predecessors>> ] keep ] dip + '[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline + +: visited? ( pair -- ? ) visited get key? ; + +: consistent? ( snode lnode -- ? ) + [ merge-sets get at ] bi@ swap bit-set-subset? ; + +: (process-edge) ( from to -- ) + f walk [ + 2dup 2array visited? [ + consistent? [ again? on ] unless + ] [ 2drop ] if + ] each-incoming-j-edge ; + +: process-edge ( from to -- ) + 2dup 2array dup visited? [ 3drop ] [ + visited get conjoin + (process-edge) + ] if ; + +: process-block ( bb -- ) + [ process-edge ] each-incoming-j-edge ; + +: compute-merge-set-step ( bfo -- ) + visited get clear-assoc + [ process-block ] each ; + +: compute-merge-set-loop ( cfg -- ) + breadth-first-order + '[ again? off _ compute-merge-set-step again? get ] + loop ; + +: (merge-set) ( bbs -- flags rpo ) + merge-sets get '[ _ at ] [ bit-set-union ] map-reduce + cfg get reverse-post-order ; inline + +: filter-by ( flags seq -- seq' ) + [ drop ] pusher [ 2each ] dip ; + +HINTS: filter-by { bit-array object } ; + +PRIVATE> + +: compute-merge-sets ( cfg -- ) + dup cfg set + H{ } clone visited set + [ compute-levels ] + [ init-merge-sets ] + [ compute-merge-set-loop ] + tri ; + +: merge-set-each ( bbs quot: ( bb -- ) -- ) + [ (merge-set) ] dip '[ + swap _ [ drop ] if + ] 2each ; inline + +: merge-set ( bbs -- bbs' ) + (merge-set) filter-by ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor index 2d0cd26798..00f461d6f2 100644 --- a/basis/compiler/cfg/ssa/destruction/destruction.factor +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -54,7 +54,6 @@ SYMBOL: seen dup split-critical-edges dup compute-def-use dup compute-dominance - dup compute-dfs dup compute-live-ranges dup process-blocks break-interferences diff --git a/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor b/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor index a74947e5df..64c04b79f2 100644 --- a/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor +++ b/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor @@ -31,8 +31,7 @@ V{ T{ ##peek f V int-regs 6 D 0 } } clone 6 test-bb cfg new 0 get >>entry compute-predecessors dup compute-dominance - dup compute-def-use - compute-dfs + compute-def-use compute-dom-forest clean-up-forest ; diff --git a/basis/compiler/cfg/ssa/destruction/forest/forest.factor b/basis/compiler/cfg/ssa/destruction/forest/forest.factor index fa0aa6e6d3..8226e2787b 100644 --- a/basis/compiler/cfg/ssa/destruction/forest/forest.factor +++ b/basis/compiler/cfg/ssa/destruction/forest/forest.factor @@ -3,7 +3,7 @@ USING: accessors assocs fry kernel math math.order namespaces sequences sorting vectors compiler.cfg.def-use compiler.cfg.dominance compiler.cfg.registers ; -IN: compiler.cfg.coalescing.forest +IN: compiler.cfg.ssa.destruction.forest TUPLE: dom-forest-node vreg bb children ; @@ -31,7 +31,6 @@ TUPLE: dom-forest-node vreg bb children ; PRIVATE> : compute-dom-forest ( vregs -- forest ) - ! compute-dfs must be called on the CFG first [ 1vector [ sort-vregs-by-bb ] dip From 7a6bdffaaa568282bf5923c9b8af86867670f232 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 11:16:21 -0500 Subject: [PATCH 73/81] IN: fix for compiler test --- basis/compiler/tests/low-level-ir.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor index 706a404330..649a72cd20 100644 --- a/basis/compiler/tests/low-level-ir.factor +++ b/basis/compiler/tests/low-level-ir.factor @@ -4,7 +4,7 @@ compiler.cfg.registers compiler.codegen compiler.units cpu.architecture hashtables kernel namespaces sequences tools.test vectors words layouts literals math arrays alien.syntax ; -IN: compiler.tests +IN: compiler.tests.low-level-ir : compile-cfg ( cfg -- word ) gensym From 5344302040f46338957b0f306562c10865050ab0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 11:16:32 -0500 Subject: [PATCH 74/81] compiler.cfg.graphviz: add render-dom word --- extra/compiler/cfg/graphviz/graphviz.factor | 50 +++++++++++++++------ 1 file changed, 36 insertions(+), 14 deletions(-) diff --git a/extra/compiler/cfg/graphviz/graphviz.factor b/extra/compiler/cfg/graphviz/graphviz.factor index d4513c8394..0aade1301f 100644 --- a/extra/compiler/cfg/graphviz/graphviz.factor +++ b/extra/compiler/cfg/graphviz/graphviz.factor @@ -1,22 +1,44 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license -USING: accessors compiler.cfg.rpo images.viewer io -io.encodings.ascii io.files io.files.unique io.launcher kernel -math.parser sequences ; +USING: accessors compiler.cfg.rpo compiler.cfg.dominance +compiler.cfg.dominance.private compiler.cfg.predecessors images.viewer +io io.encodings.ascii io.files io.files.unique io.launcher kernel +math.parser sequences assocs arrays make namespaces ; IN: compiler.cfg.graphviz -: cfg>dot ( cfg -- ) - "digraph CFG {" print - [ - [ number>> ] [ successors>> ] bi [ - number>> [ number>string ] bi@ " -> " glue write ";" print - ] with each - ] each-basic-block - "}" print ; - -: render-cfg ( cfg -- ) +: render-graph ( edges -- ) "cfg" "dot" make-unique-file - [ ascii [ cfg>dot ] with-file-writer ] + [ + ascii [ + "digraph CFG {" print + [ [ number>> number>string ] bi@ " -> " glue write ";" print ] assoc-each + "}" print + ] with-file-writer + ] [ { "dot" "-Tpng" "-O" } swap suffix try-process ] [ ".png" append { "open" } swap suffix try-process ] tri ; + +: cfg-edges ( cfg -- edges ) + [ + [ + dup successors>> [ + 2array , + ] with each + ] each-basic-block + ] { } make ; + +: render-cfg ( cfg -- ) cfg-edges render-graph ; + +: dom-edges ( cfg -- edges ) + [ + compute-predecessors + compute-dominance + dom-childrens get [ + [ + 2array , + ] with each + ] assoc-each + ] { } make ; + +: render-dom ( cfg -- ) dom-edges render-graph ; \ No newline at end of file From 037fa69a21ab16e87761149f4fba56b2bfbc8a78 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 11:20:28 -0500 Subject: [PATCH 75/81] Move Joe's HEX{ syntax to byte-arrays.hex in basis --- basis/byte-arrays/hex/authors.txt | 1 + basis/byte-arrays/hex/hex-docs.factor | 6 ++++++ basis/byte-arrays/hex/hex.factor | 11 +++++++++++ core/byte-arrays/byte-arrays-docs.factor | 4 ---- core/byte-arrays/byte-arrays.factor | 11 ++--------- 5 files changed, 20 insertions(+), 13 deletions(-) create mode 100644 basis/byte-arrays/hex/authors.txt create mode 100644 basis/byte-arrays/hex/hex-docs.factor create mode 100644 basis/byte-arrays/hex/hex.factor diff --git a/basis/byte-arrays/hex/authors.txt b/basis/byte-arrays/hex/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/byte-arrays/hex/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/byte-arrays/hex/hex-docs.factor b/basis/byte-arrays/hex/hex-docs.factor new file mode 100644 index 0000000000..8c60dc2646 --- /dev/null +++ b/basis/byte-arrays/hex/hex-docs.factor @@ -0,0 +1,6 @@ +IN: byte-arrays.hex +USING: byte-arrays help.markup help.syntax ; + +HELP: HEX{ +{ $syntax "HEX{ 0123 45 67 89abcdef }" } +{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored." } ; diff --git a/basis/byte-arrays/hex/hex.factor b/basis/byte-arrays/hex/hex.factor new file mode 100644 index 0000000000..054c35dcfa --- /dev/null +++ b/basis/byte-arrays/hex/hex.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2009 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: grouping lexer ascii parser sequences kernel math.parser ; +IN: byte-arrays.hex + +SYNTAX: HEX{ + "}" parse-tokens "" join + [ blank? not ] filter + 2 group [ hex> ] B{ } map-as + parsed ; + diff --git a/core/byte-arrays/byte-arrays-docs.factor b/core/byte-arrays/byte-arrays-docs.factor index 56832a56e5..f1d94a46f7 100644 --- a/core/byte-arrays/byte-arrays-docs.factor +++ b/core/byte-arrays/byte-arrays-docs.factor @@ -23,10 +23,6 @@ $nl ABOUT: "byte-arrays" -HELP: HEX{ -{ $syntax "HEX{ 0123 45 67 89abcdef }" } -{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored." } ; - HELP: byte-array { $description "The class of byte arrays. See " { $link "syntax-byte-arrays" } " for syntax and " { $link "byte-arrays" } " for general information." } ; diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index b32060ec99..72989ac447 100644 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -1,16 +1,9 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.accessors ascii grouping kernel -kernel.private lexer math math.parser parser sequences -sequences.private ; +USING: accessors kernel kernel.private alien.accessors sequences +sequences.private math ; IN: byte-arrays -SYNTAX: HEX{ - "}" parse-tokens "" join - [ blank? not ] filter - 2 group [ hex> ] B{ } map-as - parsed ; - M: byte-array clone (clone) ; M: byte-array length length>> ; M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; From f1683f9fcf4ff1551c5186f4bcb82215bb7be97b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 11:51:47 -0500 Subject: [PATCH 76/81] Move set-last from circular.private to sequences --- basis/circular/circular.factor | 3 +-- basis/hints/hints.factor | 4 ++++ core/sequences/sequences.factor | 2 ++ 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index d47b954ecf..9995567ec8 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -43,11 +43,10 @@ TUPLE: growing-circular < circular length ; M: growing-circular length length>> ; > length ] bi = ; -: set-last ( elt seq -- ) - [ length 1- ] keep set-nth ; PRIVATE> : push-growing-circular ( elt circular -- ) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index cfd6329b1d..d10bd5f8a9 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -83,6 +83,10 @@ SYNTAX: HINTS: \ push { { vector } { sbuf } } "specializer" set-word-prop +\ last { { vector } } "specializer" set-word-prop + +\ set-last { { object vector } } "specializer" set-word-prop + \ push-all { { string sbuf } { array vector } { byte-array byte-vector } } "specializer" set-word-prop diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 6eea872343..55d4bc9be9 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -633,6 +633,8 @@ PRIVATE> : last ( seq -- elt ) [ length 1 - ] [ nth ] bi ; +: set-last ( elt seq -- ) [ length 1 - ] keep set-nth ; + : pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ; Date: Tue, 28 Jul 2009 11:52:42 -0500 Subject: [PATCH 77/81] compiler.cfg.ssa.construction: use the optimization from the pruned-SSA paper to minimize stack pushing and popping --- .../cfg/renaming/functor/functor.factor | 116 ++++++++++++++++++ basis/compiler/cfg/renaming/renaming.factor | 106 +--------------- .../cfg/ssa/construction/construction.factor | 59 ++++----- 3 files changed, 152 insertions(+), 129 deletions(-) create mode 100644 basis/compiler/cfg/renaming/functor/functor.factor diff --git a/basis/compiler/cfg/renaming/functor/functor.factor b/basis/compiler/cfg/renaming/functor/functor.factor new file mode 100644 index 0000000000..2a9d8d4911 --- /dev/null +++ b/basis/compiler/cfg/renaming/functor/functor.factor @@ -0,0 +1,116 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: functors assocs kernel accessors compiler.cfg.instructions +lexer parser ; +IN: compiler.cfg.renaming.functor + +FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT -- ) + +rename-insn-defs DEFINES ${NAME}-insn-defs +rename-insn-uses DEFINES ${NAME}-insn-uses + +WHERE + +GENERIC: rename-insn-defs ( insn -- ) + +M: ##flushable rename-insn-defs + DEF-QUOT change-dst + drop ; + +M: ##fixnum-overflow rename-insn-defs + DEF-QUOT change-dst + drop ; + +M: _fixnum-overflow rename-insn-defs + DEF-QUOT change-dst + drop ; + +M: insn rename-insn-defs drop ; + +GENERIC: rename-insn-uses ( insn -- ) + +M: ##effect rename-insn-uses + USE-QUOT change-src + drop ; + +M: ##unary rename-insn-uses + USE-QUOT change-src + drop ; + +M: ##binary rename-insn-uses + USE-QUOT change-src1 + USE-QUOT change-src2 + drop ; + +M: ##binary-imm rename-insn-uses + USE-QUOT change-src1 + drop ; + +M: ##slot rename-insn-uses + USE-QUOT change-obj + USE-QUOT change-slot + drop ; + +M: ##slot-imm rename-insn-uses + USE-QUOT change-obj + drop ; + +M: ##set-slot rename-insn-uses + dup call-next-method + USE-QUOT change-obj + USE-QUOT change-slot + drop ; + +M: ##string-nth rename-insn-uses + USE-QUOT change-obj + USE-QUOT change-index + drop ; + +M: ##set-string-nth-fast rename-insn-uses + dup call-next-method + USE-QUOT change-obj + USE-QUOT change-index + drop ; + +M: ##set-slot-imm rename-insn-uses + dup call-next-method + USE-QUOT change-obj + drop ; + +M: ##alien-getter rename-insn-uses + dup call-next-method + USE-QUOT change-src + drop ; + +M: ##alien-setter rename-insn-uses + dup call-next-method + USE-QUOT change-value + drop ; + +M: ##conditional-branch rename-insn-uses + USE-QUOT change-src1 + USE-QUOT change-src2 + drop ; + +M: ##compare-imm-branch rename-insn-uses + USE-QUOT change-src1 + drop ; + +M: ##dispatch rename-insn-uses + USE-QUOT change-src + drop ; + +M: ##fixnum-overflow rename-insn-uses + USE-QUOT change-src1 + USE-QUOT change-src2 + drop ; + +M: ##phi rename-insn-uses + [ USE-QUOT assoc-map ] change-inputs + drop ; + +M: insn rename-insn-uses drop ; + +;FUNCTOR + +SYNTAX: RENAMING: scan scan-object scan-object define-renaming ; \ No newline at end of file diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor index eb8538256a..9de3fdd8d8 100644 --- a/basis/compiler/cfg/renaming/renaming.factor +++ b/basis/compiler/cfg/renaming/renaming.factor @@ -1,112 +1,16 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel namespaces sequences -compiler.cfg.instructions compiler.cfg.registers ; +compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.renaming.functor ; IN: compiler.cfg.renaming SYMBOL: renamings -: rename-value ( vreg -- vreg' ) renamings get ?at drop ; +: rename-value ( vreg -- vreg' ) + renamings get ?at drop ; -GENERIC: rename-insn-defs ( insn -- ) - -M: ##flushable rename-insn-defs - [ rename-value ] change-dst - drop ; - -M: ##fixnum-overflow rename-insn-defs - [ rename-value ] change-dst - drop ; - -M: _fixnum-overflow rename-insn-defs - [ rename-value ] change-dst - drop ; - -M: insn rename-insn-defs drop ; - -GENERIC: rename-insn-uses ( insn -- ) - -M: ##effect rename-insn-uses - [ rename-value ] change-src - drop ; - -M: ##unary rename-insn-uses - [ rename-value ] change-src - drop ; - -M: ##binary rename-insn-uses - [ rename-value ] change-src1 - [ rename-value ] change-src2 - drop ; - -M: ##binary-imm rename-insn-uses - [ rename-value ] change-src1 - drop ; - -M: ##slot rename-insn-uses - [ rename-value ] change-obj - [ rename-value ] change-slot - drop ; - -M: ##slot-imm rename-insn-uses - [ rename-value ] change-obj - drop ; - -M: ##set-slot rename-insn-uses - dup call-next-method - [ rename-value ] change-obj - [ rename-value ] change-slot - drop ; - -M: ##string-nth rename-insn-uses - [ rename-value ] change-obj - [ rename-value ] change-index - drop ; - -M: ##set-string-nth-fast rename-insn-uses - dup call-next-method - [ rename-value ] change-obj - [ rename-value ] change-index - drop ; - -M: ##set-slot-imm rename-insn-uses - dup call-next-method - [ rename-value ] change-obj - drop ; - -M: ##alien-getter rename-insn-uses - dup call-next-method - [ rename-value ] change-src - drop ; - -M: ##alien-setter rename-insn-uses - dup call-next-method - [ rename-value ] change-value - drop ; - -M: ##conditional-branch rename-insn-uses - [ rename-value ] change-src1 - [ rename-value ] change-src2 - drop ; - -M: ##compare-imm-branch rename-insn-uses - [ rename-value ] change-src1 - drop ; - -M: ##dispatch rename-insn-uses - [ rename-value ] change-src - drop ; - -M: ##fixnum-overflow rename-insn-uses - [ rename-value ] change-src1 - [ rename-value ] change-src2 - drop ; - -M: ##phi rename-insn-uses - [ [ rename-value ] assoc-map ] change-inputs - drop ; - -M: insn rename-insn-uses drop ; +RENAMING: rename [ rename-value ] [ rename-value ] : fresh-vreg ( vreg -- vreg' ) reg-class>> next-vreg ; diff --git a/basis/compiler/cfg/ssa/construction/construction.factor b/basis/compiler/cfg/ssa/construction/construction.factor index 3f131f4782..b6aea8bb17 100644 --- a/basis/compiler/cfg/ssa/construction/construction.factor +++ b/basis/compiler/cfg/ssa/construction/construction.factor @@ -5,22 +5,24 @@ sets math combinators compiler.cfg compiler.cfg.rpo compiler.cfg.def-use -compiler.cfg.renaming compiler.cfg.liveness compiler.cfg.registers compiler.cfg.dominance compiler.cfg.instructions +compiler.cfg.renaming.functor compiler.cfg.ssa.construction.tdmsc ; IN: compiler.cfg.ssa.construction ! SSA construction. Predecessors must be computed first. -! This is the classical algorithm based on dominance frontiers, except -! we consult liveness information to build pruned SSA: -! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.25.8240 +! The phi placement algorithm is implemented in +! compiler.cfg.ssa.construction.tdmsc. -! Eventually might be worth trying something fancier: -! http://portal.acm.org/citation.cfm?id=1065887.1065890 +! The renaming algorithm is based on "Practical Improvements to +! the Construction and Destruction of Static Single Assignment Form", +! however we construct pruned SSA, not semi-pruned SSA. + +! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.49.9683 > next-vreg ] keep - [ stacks get push-at ] - [ swap originals get set-at ] - [ drop ] - 2tri ; + [ reg-class>> next-vreg dup ] keep + dup pushed get 2dup key? + [ 2drop stacks get at set-last ] + [ conjoin stacks get push-at ] + if ; : top-name ( vreg -- vreg' ) stacks get at last ; +RENAMING: ssa-rename [ gen-name ] [ top-name ] + GENERIC: rename-insn ( insn -- ) M: insn rename-insn - [ dup uses-vregs [ dup top-name ] { } map>assoc renamings set rename-insn-uses ] - [ dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ] + [ ssa-rename-insn-uses ] + [ ssa-rename-insn-defs ] bi ; M: ##phi rename-insn - dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ; + ssa-rename-insn-defs ; : rename-insns ( bb -- ) instructions>> [ rename-insn ] each ; @@ -89,19 +92,19 @@ M: ##phi rename-insn : rename-successors-phis ( bb -- ) [ successors>> ] keep '[ _ rename-successor-phis ] each ; -: pop-stacks ( bb -- ) - instructions>> [ - defs-vregs originals get stacks get - '[ _ at _ at pop* ] each - ] each ; +: pop-stacks ( -- ) + pushed get stacks get '[ drop _ at pop* ] assoc-each ; : rename-in-block ( bb -- ) - { - [ rename-insns ] - [ rename-successors-phis ] - [ dom-children [ rename-in-block ] each ] - [ pop-stacks ] - } cleave ; + H{ } clone pushed set + [ rename-insns ] + [ rename-successors-phis ] + [ + pushed get + [ dom-children [ rename-in-block ] each ] dip + pushed set + ] tri + pop-stacks ; : rename ( cfg -- ) init-renaming From 9f3c8a99597d0c4952ad5786c128df4d341a4fdb Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 28 Jul 2009 12:19:37 -0500 Subject: [PATCH 78/81] SSE4 opcodes for x86 assembler --- .../cpu/x86/assembler/assembler-tests.factor | 19 +++ basis/cpu/x86/assembler/assembler.factor | 132 ++++++++++++++---- 2 files changed, 120 insertions(+), 31 deletions(-) diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index d2dd73779a..66adee6bf6 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -25,6 +25,7 @@ IN: cpu.x86.assembler.tests [ { HEX: 66 HEX: 0f HEX: 2e HEX: c1 } ] [ [ XMM0 XMM1 UCOMISD ] { } make ] unit-test [ { HEX: 66 HEX: 0f HEX: 2e HEX: 01 } ] [ [ XMM0 ECX [] UCOMISD ] { } make ] unit-test [ [ EAX [] XMM1 UCOMISD ] { } make ] must-fail +[ { HEX: 66 HEX: 0f HEX: 38 HEX: 2a HEX: 01 } ] [ [ XMM0 ECX [] MOVNTDQA ] { } make ] unit-test ! rm-r only sse instructions [ { HEX: 0f HEX: 2b HEX: 08 } ] [ [ EAX [] XMM1 MOVNTPS ] { } make ] unit-test @@ -54,8 +55,16 @@ IN: cpu.x86.assembler.tests ! 3-operand r-rm-imm sse instructions [ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test [ { HEX: 0f HEX: c6 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 SHUFPS ] { } make ] unit-test + +! scalar register insert/extract sse instructions [ { HEX: 66 HEX: 0f HEX: c4 HEX: c1 HEX: 02 } ] [ [ XMM0 ECX 2 PINSRW ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: c4 HEX: 04 HEX: 11 HEX: 03 } ] [ [ XMM0 ECX EDX [+] 3 PINSRW ] { } make ] unit-test + [ { HEX: 66 HEX: 0f HEX: c5 HEX: c1 HEX: 02 } ] [ [ EAX XMM1 2 PEXTRW ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 3a HEX: 15 HEX: 08 HEX: 02 } ] [ [ EAX [] XMM1 2 PEXTRW ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 3a HEX: 15 HEX: 14 HEX: 08 HEX: 03 } ] [ [ EAX ECX [+] XMM2 3 PEXTRW ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 3a HEX: 14 HEX: c8 HEX: 02 } ] [ [ EAX XMM1 2 PEXTRB ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 3a HEX: 14 HEX: 08 HEX: 02 } ] [ [ EAX [] XMM1 2 PEXTRB ] { } make ] unit-test ! sse shift instructions [ { HEX: 66 HEX: 0f HEX: 71 HEX: d0 HEX: 05 } ] [ [ XMM0 5 PSRLW ] { } make ] unit-test @@ -76,6 +85,16 @@ IN: cpu.x86.assembler.tests [ { HEX: 0f HEX: 50 HEX: c1 } ] [ [ EAX XMM1 MOVMSKPS ] { } make ] unit-test [ { HEX: 66 HEX: 0f HEX: 50 HEX: c1 } ] [ [ EAX XMM1 MOVMSKPD ] { } make ] unit-test +[ { HEX: f3 HEX: 0f HEX: b8 HEX: c1 } ] [ [ EAX ECX POPCNT ] { } make ] unit-test +[ { HEX: f3 HEX: 48 HEX: 0f HEX: b8 HEX: c1 } ] [ [ RAX RCX POPCNT ] { } make ] unit-test +[ { HEX: f3 HEX: 0f HEX: b8 HEX: 01 } ] [ [ EAX ECX [] POPCNT ] { } make ] unit-test +[ { HEX: f3 HEX: 0f HEX: b8 HEX: 04 HEX: 11 } ] [ [ EAX ECX EDX [+] POPCNT ] { } make ] unit-test + +[ { HEX: f2 HEX: 0f HEX: 38 HEX: f0 HEX: c1 } ] [ [ EAX CL CRC32B ] { } make ] unit-test +[ { HEX: f2 HEX: 0f HEX: 38 HEX: f0 HEX: 01 } ] [ [ EAX ECX [] CRC32B ] { } make ] unit-test +[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: c1 } ] [ [ EAX ECX CRC32 ] { } make ] unit-test +[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: 01 } ] [ [ EAX ECX [] CRC32 ] { } make ] unit-test + ! memory address modes [ { HEX: 8a HEX: 18 } ] [ [ BL RAX [] MOV ] { } make ] unit-test [ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX RAX [] MOV ] { } make ] unit-test diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 237ef8154d..e91ebdcb1a 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -218,9 +218,8 @@ M: object operand-64? drop f ; : opcode, ( opcode -- ) dup array? [ % ] [ , ] if ; -: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ; - -: ssse3-opcode ( opcode -- opcode' ) OCT: 17 sequences:prefix ; +: extended-opcode ( opcode -- opcode' ) + dup array? [ OCT: 17 sequences:prefix ] [ OCT: 17 swap 2array ] if ; : extended-opcode, ( opcode -- ) extended-opcode opcode, ; @@ -487,9 +486,6 @@ M: operand TEST OCT: 204 2-operand ; : 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- ) [ , ] when* direction-op-sse extended-opcode (2-operand) ; -: 2-operand-ssse3 ( dst src op1 op2 -- ) - [ , ] when* swapd ssse3-opcode (2-operand) ; - : 2-operand-rm-sse ( dst src op1 op2 -- ) [ , ] when* swapd extended-opcode (2-operand) ; @@ -499,11 +495,17 @@ M: operand TEST OCT: 204 2-operand ; : 2-operand-int/sse ( dst src op1 op2 -- ) [ , ] when* swapd extended-opcode (2-operand) ; -: 3-operand-sse ( dst src imm op1 op2 -- ) +: 3-operand-rm-sse ( dst src imm op1 op2 -- ) rot [ 2-operand-rm-sse ] dip , ; +: 3-operand-mr-sse ( dst src imm op1 op2 -- ) + rot [ 2-operand-mr-sse ] dip , ; + +: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- ) + rot [ 2-operand-rm-mr-sse ] dip , ; + : 2-operand-sse-cmp ( dst src cmp op1 op2 -- ) - 3-operand-sse ; inline + 3-operand-rm-sse ; inline : 2-operand-sse-shift ( dst imm reg op1 op2 -- ) [ , ] when* @@ -547,22 +549,89 @@ PRIVATE> : UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-rm-sse ; : COMISS ( dest src -- ) HEX: 2f f 2-operand-rm-sse ; : COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-rm-sse ; -: PSHUFB ( dest src -- ) { HEX: 38 HEX: 00 } HEX: 66 2-operand-ssse3 ; -: PHADDW ( dest src -- ) { HEX: 38 HEX: 01 } HEX: 66 2-operand-ssse3 ; -: PHADDD ( dest src -- ) { HEX: 38 HEX: 02 } HEX: 66 2-operand-ssse3 ; -: PHADDSW ( dest src -- ) { HEX: 38 HEX: 03 } HEX: 66 2-operand-ssse3 ; -: PMADDUBSW ( dest src -- ) { HEX: 38 HEX: 04 } HEX: 66 2-operand-ssse3 ; -: PHSUBW ( dest src -- ) { HEX: 38 HEX: 05 } HEX: 66 2-operand-ssse3 ; -: PHSUBD ( dest src -- ) { HEX: 38 HEX: 06 } HEX: 66 2-operand-ssse3 ; -: PHSUBSW ( dest src -- ) { HEX: 38 HEX: 07 } HEX: 66 2-operand-ssse3 ; -: PSIGNB ( dest src -- ) { HEX: 38 HEX: 08 } HEX: 66 2-operand-ssse3 ; -: PSIGNW ( dest src -- ) { HEX: 38 HEX: 09 } HEX: 66 2-operand-ssse3 ; -: PSIGND ( dest src -- ) { HEX: 38 HEX: 0A } HEX: 66 2-operand-ssse3 ; -: PMULHRSW ( dest src -- ) { HEX: 38 HEX: 0B } HEX: 66 2-operand-ssse3 ; -: PABSB ( dest src -- ) { HEX: 38 HEX: 1C } HEX: 66 2-operand-ssse3 ; -: PABSW ( dest src -- ) { HEX: 38 HEX: 1D } HEX: 66 2-operand-ssse3 ; -: PABSD ( dest src -- ) { HEX: 38 HEX: 1E } HEX: 66 2-operand-ssse3 ; -: PALIGNR ( dest src -- ) { HEX: 3A HEX: 0F } HEX: 66 2-operand-ssse3 ; + +: PSHUFB ( dest src -- ) { HEX: 38 HEX: 00 } HEX: 66 2-operand-rm-sse ; +: PHADDW ( dest src -- ) { HEX: 38 HEX: 01 } HEX: 66 2-operand-rm-sse ; +: PHADDD ( dest src -- ) { HEX: 38 HEX: 02 } HEX: 66 2-operand-rm-sse ; +: PHADDSW ( dest src -- ) { HEX: 38 HEX: 03 } HEX: 66 2-operand-rm-sse ; +: PMADDUBSW ( dest src -- ) { HEX: 38 HEX: 04 } HEX: 66 2-operand-rm-sse ; +: PHSUBW ( dest src -- ) { HEX: 38 HEX: 05 } HEX: 66 2-operand-rm-sse ; +: PHSUBD ( dest src -- ) { HEX: 38 HEX: 06 } HEX: 66 2-operand-rm-sse ; +: PHSUBSW ( dest src -- ) { HEX: 38 HEX: 07 } HEX: 66 2-operand-rm-sse ; +: PSIGNB ( dest src -- ) { HEX: 38 HEX: 08 } HEX: 66 2-operand-rm-sse ; +: PSIGNW ( dest src -- ) { HEX: 38 HEX: 09 } HEX: 66 2-operand-rm-sse ; +: PSIGND ( dest src -- ) { HEX: 38 HEX: 0a } HEX: 66 2-operand-rm-sse ; +: PMULHRSW ( dest src -- ) { HEX: 38 HEX: 0b } HEX: 66 2-operand-rm-sse ; +: PBLENDVB ( dest src -- ) { HEX: 38 HEX: 10 } HEX: 66 2-operand-rm-sse ; +: BLENDVPS ( dest src -- ) { HEX: 38 HEX: 14 } HEX: 66 2-operand-rm-sse ; +: BLENDVPD ( dest src -- ) { HEX: 38 HEX: 15 } HEX: 66 2-operand-rm-sse ; +: PTEST ( dest src -- ) { HEX: 38 HEX: 17 } HEX: 66 2-operand-rm-sse ; +: PABSB ( dest src -- ) { HEX: 38 HEX: 1c } HEX: 66 2-operand-rm-sse ; +: PABSW ( dest src -- ) { HEX: 38 HEX: 1d } HEX: 66 2-operand-rm-sse ; +: PABSD ( dest src -- ) { HEX: 38 HEX: 1e } HEX: 66 2-operand-rm-sse ; +: PMOVSXBW ( dest src -- ) { HEX: 38 HEX: 20 } HEX: 66 2-operand-rm-sse ; +: PMOVSXBD ( dest src -- ) { HEX: 38 HEX: 21 } HEX: 66 2-operand-rm-sse ; +: PMOVSXBQ ( dest src -- ) { HEX: 38 HEX: 22 } HEX: 66 2-operand-rm-sse ; +: PMOVSXWD ( dest src -- ) { HEX: 38 HEX: 23 } HEX: 66 2-operand-rm-sse ; +: PMOVSXWQ ( dest src -- ) { HEX: 38 HEX: 24 } HEX: 66 2-operand-rm-sse ; +: PMOVSXDQ ( dest src -- ) { HEX: 38 HEX: 25 } HEX: 66 2-operand-rm-sse ; +: PMULDQ ( dest src -- ) { HEX: 38 HEX: 28 } HEX: 66 2-operand-rm-sse ; +: PCMPEQQ ( dest src -- ) { HEX: 38 HEX: 29 } HEX: 66 2-operand-rm-sse ; +: MOVNTDQA ( dest src -- ) { HEX: 38 HEX: 2a } HEX: 66 2-operand-rm-sse ; +: PACKUSDW ( dest src -- ) { HEX: 38 HEX: 2b } HEX: 66 2-operand-rm-sse ; +: PMOVZXBW ( dest src -- ) { HEX: 38 HEX: 30 } HEX: 66 2-operand-rm-sse ; +: PMOVZXBD ( dest src -- ) { HEX: 38 HEX: 31 } HEX: 66 2-operand-rm-sse ; +: PMOVZXBQ ( dest src -- ) { HEX: 38 HEX: 32 } HEX: 66 2-operand-rm-sse ; +: PMOVZXWD ( dest src -- ) { HEX: 38 HEX: 33 } HEX: 66 2-operand-rm-sse ; +: PMOVZXWQ ( dest src -- ) { HEX: 38 HEX: 34 } HEX: 66 2-operand-rm-sse ; +: PMOVZXDQ ( dest src -- ) { HEX: 38 HEX: 35 } HEX: 66 2-operand-rm-sse ; +: PCMPGTQ ( dest src -- ) { HEX: 38 HEX: 37 } HEX: 66 2-operand-rm-sse ; +: PMINSB ( dest src -- ) { HEX: 38 HEX: 38 } HEX: 66 2-operand-rm-sse ; +: PMINSD ( dest src -- ) { HEX: 38 HEX: 39 } HEX: 66 2-operand-rm-sse ; +: PMINUW ( dest src -- ) { HEX: 38 HEX: 3a } HEX: 66 2-operand-rm-sse ; +: PMINUD ( dest src -- ) { HEX: 38 HEX: 3b } HEX: 66 2-operand-rm-sse ; +: PMAXSB ( dest src -- ) { HEX: 38 HEX: 3c } HEX: 66 2-operand-rm-sse ; +: PMAXSD ( dest src -- ) { HEX: 38 HEX: 3d } HEX: 66 2-operand-rm-sse ; +: PMAXUW ( dest src -- ) { HEX: 38 HEX: 3e } HEX: 66 2-operand-rm-sse ; +: PMAXUD ( dest src -- ) { HEX: 38 HEX: 3f } HEX: 66 2-operand-rm-sse ; +: PMULLD ( dest src -- ) { HEX: 38 HEX: 40 } HEX: 66 2-operand-rm-sse ; +: PHMINPOSUW ( dest src -- ) { HEX: 38 HEX: 41 } HEX: 66 2-operand-rm-sse ; +: CRC32B ( dest src -- ) { HEX: 38 HEX: f0 } HEX: f2 2-operand-rm-sse ; +: CRC32 ( dest src -- ) { HEX: 38 HEX: f1 } HEX: f2 2-operand-rm-sse ; + +: ROUNDPS ( dest src imm -- ) { HEX: 3a HEX: 08 } HEX: 66 3-operand-rm-sse ; +: ROUNDPD ( dest src imm -- ) { HEX: 3a HEX: 09 } HEX: 66 3-operand-rm-sse ; +: ROUNDSS ( dest src imm -- ) { HEX: 3a HEX: 0a } HEX: 66 3-operand-rm-sse ; +: ROUNDSD ( dest src imm -- ) { HEX: 3a HEX: 0b } HEX: 66 3-operand-rm-sse ; +: BLENDPS ( dest src imm -- ) { HEX: 3a HEX: 0c } HEX: 66 3-operand-rm-sse ; +: BLENDPD ( dest src imm -- ) { HEX: 3a HEX: 0d } HEX: 66 3-operand-rm-sse ; +: PBLENDW ( dest src imm -- ) { HEX: 3a HEX: 0e } HEX: 66 3-operand-rm-sse ; +: PALIGNR ( dest src imm -- ) { HEX: 3a HEX: 0f } HEX: 66 3-operand-rm-sse ; + +: PEXTRB ( dest src imm -- ) { HEX: 3a HEX: 14 } HEX: 66 3-operand-mr-sse ; + + + +: PEXTRW ( dest src imm -- ) pick indirect? [ (PEXTRW-sse4) ] [ (PEXTRW-sse1) ] if ; +: PEXTRD ( dest src imm -- ) { HEX: 3a HEX: 16 } HEX: 66 3-operand-mr-sse ; +ALIAS: PEXTRQ PEXTRD +: EXTRACTPS ( dest src imm -- ) { HEX: 3a HEX: 17 } HEX: 66 3-operand-mr-sse ; + +: PINSRB ( dest src imm -- ) { HEX: 3a HEX: 20 } HEX: 66 3-operand-rm-sse ; +: INSERTPS ( dest src imm -- ) { HEX: 3a HEX: 21 } HEX: 66 3-operand-rm-sse ; +: PINSRD ( dest src imm -- ) { HEX: 3a HEX: 22 } HEX: 66 3-operand-rm-sse ; +ALIAS: PINSRQ PINSRD +: DPPS ( dest src imm -- ) { HEX: 3a HEX: 40 } HEX: 66 3-operand-rm-sse ; +: DPPD ( dest src imm -- ) { HEX: 3a HEX: 41 } HEX: 66 3-operand-rm-sse ; +: MPSADBW ( dest src imm -- ) { HEX: 3a HEX: 42 } HEX: 66 3-operand-rm-sse ; +: PCMPESTRM ( dest src imm -- ) { HEX: 3a HEX: 60 } HEX: 66 3-operand-rm-sse ; +: PCMPESTRI ( dest src imm -- ) { HEX: 3a HEX: 61 } HEX: 66 3-operand-rm-sse ; +: PCMPISTRM ( dest src imm -- ) { HEX: 3a HEX: 62 } HEX: 66 3-operand-rm-sse ; +: PCMPISTRI ( dest src imm -- ) { HEX: 3a HEX: 63 } HEX: 66 3-operand-rm-sse ; + : MOVMSKPS ( dest src -- ) HEX: 50 f 2-operand-int/sse ; : MOVMSKPD ( dest src -- ) HEX: 50 HEX: 66 2-operand-int/sse ; : SQRTPS ( dest src -- ) HEX: 51 f 2-operand-rm-sse ; @@ -618,9 +687,9 @@ PRIVATE> : MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ; : MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ; -: PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-sse ; -: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-sse ; -: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-sse ; +: PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-rm-sse ; +: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ; +: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ; : PSRLW ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ; : PSRAW ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ; : PSLLW ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ; @@ -646,6 +715,8 @@ PRIVATE> : MFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 360 , ; : SFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 370 , ; +: POPCNT ( dest src -- ) HEX: b8 HEX: f3 2-operand-rm-sse ; + : CMPEQPS ( dest src -- ) 0 HEX: c2 f 2-operand-sse-cmp ; : CMPLTPS ( dest src -- ) 1 HEX: c2 f 2-operand-sse-cmp ; : CMPLEPS ( dest src -- ) 2 HEX: c2 f 2-operand-sse-cmp ; @@ -684,10 +755,9 @@ PRIVATE> : MOVNTI ( dest src -- ) { HEX: 0f HEX: c3 } (2-operand) ; -: PINSRW ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-sse ; -: PEXTRW ( dest src imm -- ) HEX: c5 HEX: 66 3-operand-sse ; -: SHUFPS ( dest src imm -- ) HEX: c6 f 3-operand-sse ; -: SHUFPD ( dest src imm -- ) HEX: c6 HEX: 66 3-operand-sse ; +: PINSRW ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-rm-sse ; +: SHUFPS ( dest src imm -- ) HEX: c6 f 3-operand-rm-sse ; +: SHUFPD ( dest src imm -- ) HEX: c6 HEX: 66 3-operand-rm-sse ; : ADDSUBPD ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ; : ADDSUBPS ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ; From d913d7331f76f1f1974dc279da72b3fa7e3a83b2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 12:29:07 -0500 Subject: [PATCH 79/81] compiler.cfg: Minor optimization. Instructions can now only ever produce a single value; this eliminates 1array constructions and some iterations --- basis/compiler/cfg/checker/checker.factor | 2 +- basis/compiler/cfg/def-use/def-use.factor | 63 +++++++++---------- .../linear-scan/assignment/assignment.factor | 4 +- .../live-intervals/live-intervals.factor | 2 +- basis/compiler/cfg/liveness/liveness.factor | 2 +- .../cfg/ssa/construction/construction.factor | 29 +++++++-- .../cfg/ssa/destruction/forest/forest.factor | 2 +- .../live-ranges/live-ranges.factor | 10 +-- 8 files changed, 63 insertions(+), 51 deletions(-) diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 22b6f03231..07e6cc8cea 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -59,7 +59,7 @@ ERROR: undefined-values uses defs ; ! Check that every used register has a definition instructions>> [ [ uses-vregs ] map concat ] - [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi + [ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi 2dup subset? [ 2drop ] [ undefined-values ] if ; : check-cfg ( cfg -- ) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index d4d6ce8289..1c9ac90f78 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -4,14 +4,14 @@ USING: accessors arrays kernel assocs sequences namespaces fry sets compiler.cfg.rpo compiler.cfg.instructions ; IN: compiler.cfg.def-use -GENERIC: defs-vregs ( insn -- seq ) +GENERIC: defs-vreg ( insn -- vreg/f ) GENERIC: temp-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) -M: ##flushable defs-vregs dst>> 1array ; -M: ##fixnum-overflow defs-vregs dst>> 1array ; -M: _fixnum-overflow defs-vregs dst>> 1array ; -M: insn defs-vregs drop f ; +M: ##flushable defs-vreg dst>> ; +M: ##fixnum-overflow defs-vreg dst>> ; +M: _fixnum-overflow defs-vreg dst>> ; +M: insn defs-vreg drop f ; M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ; M: ##unary/temp temp-vregs temp>> 1array ; @@ -50,55 +50,48 @@ M: _compare-imm-branch uses-vregs src1>> 1array ; M: _dispatch uses-vregs src>> 1array ; M: insn uses-vregs drop f ; -! Computing def-use chains. We don't assume a program is in SSA form, -! since SSA construction itself needs def-use information. defs-1 -! is only useful if the program is SSA. -SYMBOLS: defs defs-1 insns uses ; +! Computing def-use chains. -: def-of ( vreg -- node ) defs-1 get at ; -: defs-of ( vreg -- nodes ) defs get at ; +SYMBOLS: defs insns uses ; + +: def-of ( vreg -- node ) defs get at ; : uses-of ( vreg -- nodes ) uses get at ; : insn-of ( vreg -- insn ) insns get at ; -> [ - @ [ - _ conjoin-at - ] with each + _ set-def-of ] with each ] each-basic-block ] keep - [ keys ] assoc-map ; inline - -PRIVATE> - -: compute-defs ( cfg -- ) - [ defs-vregs ] (compute-def-use) - [ defs set ] [ [ first ] assoc-map defs-1 set ] bi ; - -: compute-uses ( cfg -- ) - [ uses-vregs ] (compute-def-use) uses set ; + defs set ; : compute-insns ( cfg -- ) H{ } clone [ '[ instructions>> [ - dup defs-vregs [ - _ set-at - ] with each + dup _ set-def-of ] each ] each-basic-block ] keep insns set ; +: compute-uses ( cfg -- ) + H{ } clone [ + '[ + dup instructions>> [ + uses-vregs [ + _ conjoin-at + ] with each + ] with each + ] each-basic-block + ] keep + [ keys ] assoc-map + uses set ; + : compute-def-use ( cfg -- ) [ compute-defs ] [ compute-uses ] [ compute-insns ] tri ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 370f562fc4..3664f58b1e 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -86,7 +86,9 @@ GENERIC: assign-registers-in-insn ( insn -- ) [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ; : all-vregs ( insn -- vregs ) - [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ; + [ [ temp-vregs ] [ uses-vregs ] bi append ] + [ defs-vreg ] bi + [ suffix ] when* ; SYMBOL: check-assignment? diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 8813a4e94e..77aae14503 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -98,7 +98,7 @@ M: insn compute-live-intervals* drop ; M: vreg-insn compute-live-intervals* dup insn#>> live-intervals get - [ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ] + [ [ defs-vreg ] 2dip '[ [ _ ] dip _ handle-output ] when* ] [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ] [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ] 3tri ; diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index eef9296b4b..6c67769a45 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -13,7 +13,7 @@ BACKWARD-ANALYSIS: live GENERIC: insn-liveness ( live-set insn -- ) : kill-defs ( live-set insn -- live-set ) - defs-vregs [ over delete-at ] each ; + defs-vreg [ over delete-at ] when* ; : gen-uses ( live-set insn -- live-set ) dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ; diff --git a/basis/compiler/cfg/ssa/construction/construction.factor b/basis/compiler/cfg/ssa/construction/construction.factor index b6aea8bb17..3bbbb887f0 100644 --- a/basis/compiler/cfg/ssa/construction/construction.factor +++ b/basis/compiler/cfg/ssa/construction/construction.factor @@ -26,6 +26,27 @@ IN: compiler.cfg.ssa.construction ] 2tri + [ defs-multi get conjoin ] [ drop ] if + ] [ 2drop ] if ; + +: compute-defs ( cfg -- ) + H{ } clone defs set + H{ } clone defs-multi set + [ + dup instructions>> [ + compute-insn-defs + ] with each + ] each-basic-block ; + ! Maps basic blocks to sequences of vregs SYMBOL: inserting-phi-nodes @@ -36,15 +57,11 @@ SYMBOL: inserting-phi-nodes ] [ 2drop ] if ; : compute-phi-nodes-for ( vreg bbs -- ) - dup length 2 >= [ - [ - insert-phi-node-later - ] with merge-set-each - ] [ 2drop ] if ; + keys [ insert-phi-node-later ] with merge-set-each ; : compute-phi-nodes ( -- ) H{ } clone inserting-phi-nodes set - defs get [ compute-phi-nodes-for ] assoc-each ; + defs-multi get defs get '[ _ at compute-phi-nodes-for ] assoc-each ; : insert-phi-nodes-in ( phis bb -- ) [ append ] change-instructions drop ; diff --git a/basis/compiler/cfg/ssa/destruction/forest/forest.factor b/basis/compiler/cfg/ssa/destruction/forest/forest.factor index 8226e2787b..a196be13cb 100644 --- a/basis/compiler/cfg/ssa/destruction/forest/forest.factor +++ b/basis/compiler/cfg/ssa/destruction/forest/forest.factor @@ -10,7 +10,7 @@ TUPLE: dom-forest-node vreg bb children ; assoc [ [ second pre-of ] compare ] sort ; diff --git a/basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor b/basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor index 5a976f29ab..536f5e1e68 100644 --- a/basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor +++ b/basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs fry kernel namespaces sequences math -compiler.cfg.def-use compiler.cfg.instructions +arrays compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.liveness compiler.cfg.rpo ; IN: compiler.cfg.ssa.destruction.live-ranges @@ -11,8 +11,8 @@ IN: compiler.cfg.ssa.destruction.live-ranges SYMBOLS: local-def-indices local-kill-indices ; -: record-defs ( n vregs -- ) - local-def-indices get '[ _ set-at ] with each ; +: record-def ( n vregs -- ) + dup [ local-def-indices get set-at ] [ 2drop ] if ; : record-uses ( n vregs -- ) local-kill-indices get '[ _ set-at ] with each ; @@ -24,9 +24,9 @@ SYMBOLS: local-def-indices local-kill-indices ; ! this instruction and before the next one, ensuring that outputs ! interfere with inputs. 2 * - [ swap defs-vregs record-defs ] + [ swap defs-vreg record-def ] [ swap uses-vregs record-uses ] - [ over def-is-use-insn? [ 1 + swap defs-vregs record-uses ] [ 2drop ] if ] + [ over def-is-use-insn? [ 1 + swap defs-vreg 1array record-uses ] [ 2drop ] if ] 2tri ; SYMBOLS: def-indices kill-indices ; From 9afa39aa3a642ddb0213514d5b20e1d359d35db4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 28 Jul 2009 12:56:33 -0500 Subject: [PATCH 80/81] compiler.cfg.ssa.destruction: rename coalesce word to destruct-ssa --- basis/compiler/cfg/optimizer/optimizer.factor | 2 +- basis/compiler/cfg/ssa/destruction/destruction.factor | 2 +- basis/compiler/cfg/value-numbering/value-numbering-tests.factor | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 52c4c40c09..8e2df04cca 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -42,7 +42,7 @@ SYMBOL: check-optimizer? copy-propagation eliminate-dead-code eliminate-write-barriers - coalesce + destruct-ssa delete-empty-blocks ?check ] with-scope ; diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor index 00f461d6f2..c650782582 100644 --- a/basis/compiler/cfg/ssa/destruction/destruction.factor +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -47,7 +47,7 @@ SYMBOL: seen : remove-phis ( cfg -- ) [ [ remove-phis-from-block ] if-has-phis ] each-basic-block ; -: coalesce ( cfg -- cfg' ) +: destruct-ssa ( cfg -- cfg' ) dup cfg-has-phis? [ init-coalescing compute-ssa-live-sets diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index c5b064b2d3..087b73e2c0 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -1191,7 +1191,7 @@ test-diamond cfg new 0 get >>entry value-numbering compute-predecessors - coalesce drop + destruct-ssa drop ] unit-test [ 1 ] [ 1 get successors>> length ] unit-test From 7f1abec19e6dc9cbda0ff94ca1ae124d256ce604 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 28 Jul 2009 14:38:10 -0500 Subject: [PATCH 81/81] i just cut and pasted --- basis/byte-arrays/hex/authors.txt | 3 ++- basis/byte-arrays/hex/hex-docs.factor | 2 ++ basis/byte-arrays/hex/hex.factor | 2 +- 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/basis/byte-arrays/hex/authors.txt b/basis/byte-arrays/hex/authors.txt index f13c9c1e77..8f20b8c31e 100644 --- a/basis/byte-arrays/hex/authors.txt +++ b/basis/byte-arrays/hex/authors.txt @@ -1 +1,2 @@ -Joe Groff +Maxim Savchenko +Slava Pestov diff --git a/basis/byte-arrays/hex/hex-docs.factor b/basis/byte-arrays/hex/hex-docs.factor index 8c60dc2646..8a2b842fc9 100644 --- a/basis/byte-arrays/hex/hex-docs.factor +++ b/basis/byte-arrays/hex/hex-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2009 Maxim Savchenko, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. IN: byte-arrays.hex USING: byte-arrays help.markup help.syntax ; diff --git a/basis/byte-arrays/hex/hex.factor b/basis/byte-arrays/hex/hex.factor index 054c35dcfa..f1b9a52303 100644 --- a/basis/byte-arrays/hex/hex.factor +++ b/basis/byte-arrays/hex/hex.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2009 Joe Groff. +! Copyright (C) 2009 Maxim Savchenko, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: grouping lexer ascii parser sequences kernel math.parser ; IN: byte-arrays.hex