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@ >= ;