From 22fa524db1d14af155693f90f0e58104c9d5e216 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 24 Jun 2009 13:54:43 -0500 Subject: [PATCH] compiler.cfg.stack-analysis: split up into three vocabs --- .../cfg/stack-analysis/merge/merge.factor | 85 ++++++++++ .../cfg/stack-analysis/stack-analysis.factor | 150 +++--------------- .../cfg/stack-analysis/state/state.factor | 43 +++++ 3 files changed, 148 insertions(+), 130 deletions(-) create mode 100644 basis/compiler/cfg/stack-analysis/merge/merge.factor create mode 100644 basis/compiler/cfg/stack-analysis/state/state.factor diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor new file mode 100644 index 0000000000..9db6d595bf --- /dev/null +++ b/basis/compiler/cfg/stack-analysis/merge/merge.factor @@ -0,0 +1,85 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs sequences accessors fry combinators grouping +sets compiler.cfg compiler.cfg.hats +compiler.cfg.stack-analysis.state ; +IN: compiler.cfg.stack-analysis.merge + +: initial-state ( bb states -- state ) 2drop ; + +: single-predecessor ( bb states -- state ) nip first clone ; + +ERROR: must-equal-failed seq ; + +: must-equal ( seq -- elt ) + dup all-equal? [ first ] [ must-equal-failed ] if ; + +: merge-heights ( state predecessors states -- state ) + nip + [ [ ds-height>> ] map must-equal >>ds-height ] + [ [ rs-height>> ] map must-equal >>rs-height ] bi ; + +: insert-peek ( predecessor loc -- vreg ) + ! XXX critical edges + '[ _ ^^peek ] add-instructions ; + +: 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 + dup all-equal? [ first ] [ ^^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 (merge-locs) >>locs>vregs ; + +: merge-actual-loc ( locs>vregs loc -- vreg ) + '[ [ _ ] dip at ] map + dup all-equal? [ first ] [ drop f ] if ; + +: merge-actual-locs ( state predecessors states -- state ) + nip + [ actual-locs>vregs>> ] map + dup [ keys ] map concat prune + [ [ nip ] [ merge-actual-loc ] 2bi ] with + H{ } map>assoc + [ nip ] assoc-filter + >>actual-locs>vregs ; + +: merge-changed-locs ( state predecessors states -- state ) + nip [ changed-locs>> ] map assoc-combine >>changed-locs ; + +ERROR: cannot-merge-poisoned states ; + +: multiple-predecessors ( bb states -- state ) + dup [ not ] any? [ + [ ] 2dip + sift merge-heights + ] [ + dup [ poisoned?>> ] any? [ + cannot-merge-poisoned + ] [ + [ state new ] 2dip + [ predecessors>> ] dip + { + [ merge-locs ] + [ merge-actual-locs ] + [ merge-heights ] + [ merge-changed-locs ] + } 2cleave + ] if + ] if ; + +: merge-states ( bb states -- state ) + ! If any states are poisoned, save all registers + ! to the stack in each branch + dup length { + { 0 [ initial-state ] } + { 1 [ single-predecessor ] } + [ drop multiple-predecessors ] + } case ; \ 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 4ebdf7012f..3946e0b897 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -1,42 +1,19 @@ ! 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 compiler.cfg.copy-prop compiler.cfg.def-use -compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo -compiler.cfg.hats compiler.cfg ; +sets make combinators +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 ; IN: compiler.cfg.stack-analysis ! Convert stack operations to register operations - -! 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 actual-locs>vregs changed-locs ds-height rs-height 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 ; - GENERIC: height-for ( loc -- n ) M: ds-loc height-for drop state get ds-height>> ; @@ -64,12 +41,6 @@ M: rs-loc untranslate-loc (translate-loc) + ; [ 2drop ] [ untranslate-loc ##replace ] if ] assoc-each ; -: clear-state ( state -- ) - [ locs>vregs>> clear-assoc ] - [ actual-locs>vregs>> clear-assoc ] - [ changed-locs>> clear-assoc ] - tri ; - ERROR: poisoned-state state ; : sync-state ( -- ) @@ -84,6 +55,14 @@ ERROR: poisoned-state state ; ! Abstract interpretation GENERIC: visit ( insn -- ) +: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ; + +M: ##inc-d visit [ , ] [ n>> adjust-ds ] bi ; + +: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ; + +M: ##inc-r visit [ , ] [ n>> adjust-rs ] bi ; + ! Instructions which don't have any effect on the stack UNION: neutral-insn ##flushable @@ -113,14 +92,6 @@ t local-only? set-global M: sync-if-back-edge visit sync-state? [ sync-state ] when , ; -: adjust-d ( n -- ) state get [ + ] change-ds-height drop ; - -M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ; - -: adjust-r ( n -- ) state get [ + ] change-rs-height drop ; - -M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ; - : eliminate-peek ( dst src -- ) ! the requested stack location is already in 'src' [ ##copy ] [ swap copies get set-at ] 2bi ; @@ -138,7 +109,7 @@ M: ##copy visit [ call-next-method ] [ record-copy ] bi ; M: ##call visit - [ call-next-method ] [ height>> adjust-d ] bi ; + [ call-next-method ] [ height>> adjust-ds ] bi ; ! Instructions that poison the stack state UNION: poison-insn @@ -167,7 +138,7 @@ UNION: kill-vreg-insn M: kill-vreg-insn visit sync-state , ; : visit-alien-node ( node -- ) - params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; + params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-ds ; M: ##alien-invoke visit [ call-next-method ] [ visit-alien-node ] bi ; @@ -180,87 +151,6 @@ M: ##alien-callback visit , ; ! Maps basic-blocks to states SYMBOLS: state-in state-out ; -: initial-state ( bb states -- state ) 2drop ; - -: single-predecessor ( bb states -- state ) nip first clone ; - -ERROR: must-equal-failed seq ; - -: must-equal ( seq -- elt ) - dup all-equal? [ first ] [ must-equal-failed ] if ; - -: merge-heights ( state predecessors states -- state ) - nip - [ [ ds-height>> ] map must-equal >>ds-height ] - [ [ rs-height>> ] map must-equal >>rs-height ] bi ; - -: insert-peek ( predecessor loc -- vreg ) - ! XXX critical edges - '[ _ ^^peek ] add-instructions ; - -: 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 - dup all-equal? [ first ] [ ^^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 (merge-locs) >>locs>vregs ; - -: merge-loc' ( 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 - dup all-equal? [ first ] [ drop f ] if ; - -: merge-actual-locs ( state predecessors states -- state ) - nip - [ actual-locs>vregs>> ] map - dup [ keys ] map concat prune - [ [ nip ] [ merge-loc' ] 2bi ] with - H{ } map>assoc - [ nip ] assoc-filter - >>actual-locs>vregs ; - -: merge-changed-locs ( state predecessors states -- state ) - nip [ changed-locs>> ] map assoc-combine >>changed-locs ; - -ERROR: cannot-merge-poisoned states ; - -: multiple-predecessors ( bb states -- state ) - dup [ not ] any? [ - [ ] 2dip - sift merge-heights - ] [ - dup [ poisoned?>> ] any? [ - cannot-merge-poisoned - ] [ - [ state new ] 2dip - [ predecessors>> ] dip - { - [ merge-locs ] - [ merge-actual-locs ] - [ merge-heights ] - [ merge-changed-locs ] - } 2cleave - ] if - ] if ; - -: merge-states ( bb states -- state ) - ! If any states are poisoned, save all registers - ! to the stack in each branch - dup length { - { 0 [ initial-state ] } - { 1 [ single-predecessor ] } - [ drop multiple-predecessors ] - } case ; - : block-in-state ( bb -- states ) dup predecessors>> state-out get '[ _ at ] map merge-states ; diff --git a/basis/compiler/cfg/stack-analysis/state/state.factor b/basis/compiler/cfg/stack-analysis/state/state.factor new file mode 100644 index 0000000000..d8cec0183f --- /dev/null +++ b/basis/compiler/cfg/stack-analysis/state/state.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors namespaces assocs sets math ; +IN: compiler.cfg.stack-analysis.state + +TUPLE: state +locs>vregs actual-locs>vregs changed-locs +ds-height rs-height 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 -- ) + [ locs>vregs>> clear-assoc ] + [ actual-locs>vregs>> clear-assoc ] + [ changed-locs>> clear-assoc ] + tri ; + +: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ; + +: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;