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