From a08bbde2e7e70141489a8cb686c534ddc2dd38b1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 25 May 2009 19:18:13 -0500 Subject: [PATCH] compiler.cfg.stack-analysis: progress --- .../stack-analysis-tests.factor | 66 +++++++ .../cfg/stack-analysis/stack-analysis.factor | 176 +++++++++--------- 2 files changed, 156 insertions(+), 86 deletions(-) create mode 100644 basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor new file mode 100644 index 0000000000..e9dc7035b2 --- /dev/null +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -0,0 +1,66 @@ +USING: 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 ; +IN: compiler.cfg.stack-analysis.tests + +[ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test +[ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test +[ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test + +: linearize ( cfg -- seq ) + build-mr instructions>> ; + +: test-stack-analysis ( quot -- mr ) + dup cfg? [ test-cfg first ] unless + compute-predecessors optimize-stack + dup check-cfg ; + +[ ] [ [ ] 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! +[ 2 ] [ [ 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 \ 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 index d43d97a8e0..f1b424e622 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -10,12 +10,12 @@ IN: compiler.cfg.stack-analysis ! If 'poisoned' is set, disregard height information. This is set if we don't have ! height change information for an instruction. -TUPLE: state locs>vregs vregs>locs changed-locs d-height r-height poisoned? ; +TUPLE: state locs>vregs actual-locs>vregs changed-locs d-height r-height poisoned? ; : ( -- state ) state new H{ } clone >>locs>vregs - H{ } clone >>vregs>locs + H{ } clone >>actual-locs>vregs H{ } clone >>changed-locs 0 >>d-height 0 >>r-height ; @@ -23,34 +23,25 @@ TUPLE: state locs>vregs vregs>locs changed-locs d-height r-height poisoned? ; M: state clone call-next-method [ clone ] change-locs>vregs - [ clone ] change-vregs>locs + [ 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 ] - [ swapd vregs>locs>> set-at ] - 3bi ; - -: delete-old-vreg ( loc -- ) - state get locs>vregs>> at [ state get vregs>locs>> delete-at ] when* ; + state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ; : changed-loc ( loc -- ) state get changed-locs>> conjoin ; -: redundant-replace? ( src loc -- ? ) - loc>vreg = ; +: changed-loc? ( loc -- ? ) + state get changed-locs>> key? ; : record-replace ( src loc -- ) - ! Locs are not single assignment, which means we have to forget - ! that the previous vreg, if any, points at this loc. Also, record - ! that the loc changed so that all the right ##replace instructions - ! are emitted at a sync point. - 2dup redundant-replace? [ 2drop ] [ - dup delete-old-vreg dup changed-loc record-peek - ] if ; + dup changed-loc state get locs>vregs>> set-at ; + +: redundant-replace? ( vreg loc -- ? ) + state get actual-locs>vregs>> at = ; : save-changed-locs ( state -- ) [ changed-locs>> ] [ locs>vregs>> ] bi '[ @@ -59,13 +50,10 @@ M: state clone ] assoc-each ; : clear-state ( state -- ) - { - [ 0 >>d-height drop ] - [ 0 >>r-height drop ] - [ changed-locs>> clear-assoc ] - [ locs>vregs>> clear-assoc ] - [ vregs>locs>> clear-assoc ] - } cleave ; + [ locs>vregs>> clear-assoc ] + [ actual-locs>vregs>> clear-assoc ] + [ changed-locs>> clear-assoc ] + tri ; ERROR: poisoned-state state ; @@ -73,8 +61,6 @@ ERROR: poisoned-state state ; state get { [ dup poisoned?>> [ poisoned-state ] [ drop ] if ] [ save-changed-locs ] - [ d-height>> dup 0 = [ drop ] [ ##inc-d ] if ] - [ r-height>> dup 0 = [ drop ] [ ##inc-r ] if ] [ clear-state ] } cleave ; @@ -95,7 +81,8 @@ UNION: neutral-insn ##effect ##branch ##loop-entry - ##conditional-branch ; + ##conditional-branch + ##compare-imm-branch ; M: neutral-insn visit , ; @@ -140,8 +127,6 @@ UNION: poison-insn ##jump ##return ##dispatch - ##dispatch-label - ##alien-callback ##callback-return ##fixnum-mul-tail ##fixnum-add-tail @@ -173,6 +158,10 @@ M: ##alien-invoke visit M: ##alien-indirect visit [ call-next-method ] [ visit-alien-node ] bi ; +M: ##alien-callback visit , ; + +M: ##dispatch-label visit , ; + ! Basic blocks we still need to look at SYMBOL: work-list @@ -182,14 +171,18 @@ SYMBOL: work-list ! Maps basic-blocks to states SYMBOLS: state-in state-out ; -: sync-unpoisoned-states ( predecessors states -- ) - [ - dup poisoned?>> [ 2drop ] [ - state [ - instructions>> building set - sync-state - ] with-variable - ] if +: modify-instructions ( predecessor quot -- ) + [ instructions>> building ] dip + '[ building get pop _ dip building get push ] with-variable ; inline + +: with-state ( state quot -- ) + [ state ] dip with-variable ; inline + +: handle-back-edge ( bb states -- ) + [ predecessors>> ] dip [ + dup [ + [ [ sync-state ] modify-instructions ] with-state + ] [ 2drop ] if ] 2each ; ERROR: must-equal-failed seq ; @@ -202,64 +195,82 @@ ERROR: must-equal-failed seq ; [ [ d-height>> ] map must-equal >>d-height ] [ [ r-height>> ] map must-equal >>r-height ] bi ; -ERROR: inconsistent-vreg>loc states ; - -: check-vreg>loc ( states -- ) - ! The same vreg should not store different locs in - ! different branches - dup - [ vregs>locs>> ] map - [ [ keys ] map concat prune ] keep - '[ _ [ at ] with map sift all-equal? ] all? - [ drop ] [ inconsistent-vreg>loc ] if ; - : insert-peek ( predecessor loc -- vreg ) ! XXX critical edges - [ instructions>> building ] dip '[ _ ^^peek ] with-variable ; + '[ _ ^^peek ] modify-instructions ; + +SYMBOL: phi-nodes + +: find-phis ( insns -- assoc ) + [ ##phi? ] filter [ [ inputs>> ] [ dst>> ] bi ] H{ } map>assoc ; + +: insert-phi ( inputs -- vreg ) + phi-nodes get [ ^^phi ] cache ; : merge-loc ( predecessors locs>vregs loc -- vreg ) ! Insert a ##phi in the current block where the input ! is the vreg storing loc from each predecessor block [ '[ [ _ ] dip at ] map ] keep - '[ [ ] [ _ insert-peek ] if ] 2map - ^^phi ; + '[ [ ] [ _ insert-peek ] ?if ] 2map + dup all-equal? [ first ] [ insert-phi ] if ; + +: (merge-locs) ( predecessors assocs -- assoc ) + dup [ keys ] map concat prune + [ [ 2nip ] [ merge-loc ] 3bi ] with with + H{ } map>assoc ; : merge-locs ( state predecessors states -- state ) - [ locs>vregs>> ] map dup [ keys ] map prune - [ - [ 2nip ] [ merge-loc ] 3bi - ] with with H{ } map>assoc - >>locs>vregs ; + [ locs>vregs>> ] map (merge-locs) >>locs>vregs ; -: merge-states ( predecessors states -- state ) +: merge-actual-locs ( state predecessors states -- state ) + [ actual-locs>vregs>> ] map (merge-locs) >>actual-locs>vregs ; + +: merge-changed-locs ( state predecessors states -- state ) + nip [ changed-locs>> ] map assoc-combine >>changed-locs ; + +ERROR: cannot-merge-poisoned states ; + +: merge-states ( bb states -- state ) ! If any states are poisoned, save all registers ! to the stack in each branch - [ drop ] [ - dup [ poisoned?>> ] any? [ - sync-unpoisoned-states - ] [ - dup check-vreg>loc - [ state new ] 2dip - [ merge-heights ] - [ merge-locs ] 2bi - ! what about vregs>locs - ] if - ] if-empty ; + dup length { + { 0 [ 2drop ] } + { 1 [ nip first clone ] } + [ + drop + dup [ not ] any? [ + handle-back-edge + ] [ + dup [ poisoned?>> ] any? [ + cannot-merge-poisoned + ] [ + [ state new ] 2dip + [ [ instructions>> find-phis phi-nodes set ] [ predecessors>> ] bi ] dip + { + [ merge-locs ] + [ merge-actual-locs ] + [ merge-heights ] + [ merge-changed-locs ] + } 2cleave + ] if + ] if + ] + } case ; : block-in-state ( bb -- states ) - predecessors>> dup state-out get '[ _ at ] map merge-states ; + dup predecessors>> state-out get '[ _ at ] map merge-states ; : maybe-set-at ( value key assoc -- changed? ) 3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ; -: set-block-in-state ( state b -- ) - state-in get set-at ; +: set-block-in-state ( state bb -- ) + [ clone ] dip state-in get set-at ; -: set-block-out-state ( bb state -- changed? ) - swap state-out get maybe-set-at ; +: set-block-out-state ( state bb -- changed? ) + [ clone ] dip state-out get maybe-set-at ; : finish-block ( bb state -- ) - [ drop ] [ set-block-out-state ] 2bi + [ drop ] [ swap set-block-out-state ] 2bi [ successors>> [ add-to-work-list ] each ] [ drop ] if ; : visit-block ( bb -- ) @@ -268,18 +279,17 @@ ERROR: inconsistent-vreg>loc states ; [ dup block-in-state [ swap set-block-in-state ] [ - state [ + [ [ instructions>> [ visit ] each ] [ state get finish-block ] [ ] tri - ] with-variable + ] with-state ] 2bi ] V{ } make >>instructions drop ; : visit-blocks ( bb -- ) - reverse-post-order work-list get - [ '[ _ push-front ] each ] [ [ visit-block ] slurp-deque ] bi ; + reverse-post-order [ visit-block ] each ; : optimize-stack ( cfg -- cfg ) [ @@ -289,9 +299,3 @@ ERROR: inconsistent-vreg>loc states ; work-list set dup entry>> visit-blocks ] with-scope ; - -! XXX: what if our height doesn't match -! a future block we're merging with? -! - we should only poison tail calls -! - non-tail poisoning nodes: ##alien-callback, ##call of a non-tail dispatch -! do we need a distinction between height changes in code and height changes done by the callee \ No newline at end of file