Refactoring low-level optimizer to support stack analysis pass

basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor

@@ -1,56 +1 @@
-USING: compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.alias-analysis compiler.cfg.debugger
-cpu.architecture tools.test kernel ;
 IN: compiler.cfg.alias-analysis.tests
-
-[ ] [
-    {
-        T{ ##peek f V int-regs 2 D 1 f }
-        T{ ##box-alien f V int-regs 1 V int-regs 2 }
-        T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
-    } alias-analysis drop
-] unit-test
-
-[ ] [
-    {
-        T{ ##load-reference f V int-regs 1 "hello" }
-        T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
-    } alias-analysis drop
-] unit-test
-
-[
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 2 f }
-        T{ ##replace f V int-regs 1 D 0 f }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 2 f }
-        T{ ##replace f V int-regs 2 D 0 f }
-        T{ ##replace f V int-regs 1 D 0 f }
-    } alias-analysis
-] unit-test
-
-[
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 0 f }
-        T{ ##copy f V int-regs 3 V int-regs 2 f }
-        T{ ##copy f V int-regs 4 V int-regs 1 f }
-        T{ ##replace f V int-regs 3 D 0 f }
-        T{ ##replace f V int-regs 4 D 1 f }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 0 f }
-        T{ ##replace f V int-regs 1 D 0 f }
-        T{ ##replace f V int-regs 2 D 1 f }
-        T{ ##peek f V int-regs 3 D 1 f }
-        T{ ##peek f V int-regs 4 D 0 f }
-        T{ ##replace f V int-regs 3 D 0 f }
-        T{ ##replace f V int-regs 4 D 1 f }
-    } alias-analysis
-] unit-test

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -1,15 +1,13 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math namespaces assocs hashtables sequences arrays
 accessors vectors combinators sets classes compiler.cfg
 compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.copy-prop ;
+compiler.cfg.copy-prop compiler.cfg.rpo
+compiler.cfg.liveness ;
 IN: compiler.cfg.alias-analysis
 
-! Alias analysis -- assumes compiler.cfg.height has already run.
+! We try to eliminate redundant slot operations using some simple heuristics.
-!
-! We try to eliminate redundant slot and stack
-! traffic using some simple heuristics.
 ! 
 ! All heap-allocated objects which are loaded from the stack, or
 ! other object slots are pessimistically assumed to belong to
@@ -17,9 +15,6 @@ IN: compiler.cfg.alias-analysis
 !
 ! Freshly-allocated objects get their own alias class.
 !
-! The data and retain stack pointer registers are treated
-! uniformly, and each one gets its own alias class.
-! 
 ! Simple pseudo-C example showing load elimination:
 ! 
 ! int *x, *y, z: inputs
@@ -189,23 +184,19 @@ SYMBOL: constants
 GENERIC: insn-slot# ( insn -- slot#/f )
 GENERIC: insn-object ( insn -- vreg )
 
-M: ##peek insn-slot# loc>> n>> ;
-M: ##replace insn-slot# loc>> n>> ;
 M: ##slot insn-slot# slot>> constant ;
 M: ##slot-imm insn-slot# slot>> ;
 M: ##set-slot insn-slot# slot>> constant ;
 M: ##set-slot-imm insn-slot# slot>> ;
 M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
 
-M: ##peek insn-object loc>> class ;
-M: ##replace insn-object loc>> class ;
 M: ##slot insn-object obj>> resolve ;
 M: ##slot-imm insn-object obj>> resolve ;
 M: ##set-slot insn-object obj>> resolve ;
 M: ##set-slot-imm insn-object obj>> resolve ;
 M: ##alien-global insn-object drop \ ##alien-global ;
 
-: init-alias-analysis ( -- )
+: init-alias-analysis ( basic-block -- )
     H{ } clone histories set
     H{ } clone vregs>acs set
     H{ } clone acs>vregs set
@@ -213,11 +204,10 @@ M: ##alien-global insn-object drop \ ##alien-global ;
     H{ } clone constants set
     H{ } clone copies set
 
-    0 ac-counter set
+    live-in keys [ set-heap-ac ] each
-    next-ac heap-ac set
     
-    ds-loc next-ac set-ac
+    0 ac-counter set
-    rs-loc next-ac set-ac ;
+    next-ac heap-ac set ;
 
 GENERIC: analyze-aliases* ( insn -- insn' )
 
@@ -292,15 +282,6 @@ GENERIC: eliminate-dead-stores* ( insn -- insn' )
         ] unless
     ] when ;
 
-M: ##replace eliminate-dead-stores*
-    #! Writes to above the top of the stack can be pruned also.
-    #! This is sound since any such writes are not observable
-    #! after the basic block, and any reads of those locations
-    #! will have been converted to copies by analyze-slot,
-    #! and the final stack height of the basic block is set at
-    #! the beginning by compiler.cfg.stack.
-    dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ;
-
 M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
 
 M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
@@ -310,8 +291,13 @@ M: insn eliminate-dead-stores* ;
 : eliminate-dead-stores ( insns -- insns' )
     [ insn# set eliminate-dead-stores* ] map-index sift ;
 
-: alias-analysis ( insns -- insns' )
+: alias-analysis-step ( basic-block -- )
-    init-alias-analysis
+    dup init-alias-analysis
+    [
         analyze-aliases
         compute-live-stores
-    eliminate-dead-stores ;
+        eliminate-dead-stores
+    ] change-instructions drop ;
+
+: alias-analysis ( rpo -- )
+    [ alias-analysis-step ] each ;

basis/compiler/cfg/checker/checker.factor

@@ -22,4 +22,4 @@ ERROR: last-insn-not-a-jump insn ;
     [ instructions>> check-basic-block ] each ;
 
 : check-cfg ( cfg -- )
-    entry>> reverse-post-order check-rpo ;
+    reverse-post-order check-rpo ;

basis/compiler/cfg/dce/dce.factor

@@ -14,9 +14,9 @@ SYMBOL: live-vregs
     H{ } clone liveness-graph set
     H{ } clone live-vregs set ;
 
-GENERIC: compute-liveness ( insn -- )
+GENERIC: update-liveness-graph ( insn -- )
 
-M: ##flushable compute-liveness
+M: ##flushable update-liveness-graph
     [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
 
 : record-live ( vregs -- )
@@ -28,7 +28,7 @@ M: ##flushable compute-liveness
         ] if
     ] each ;
 
-M: insn compute-liveness uses-vregs record-live ;
+M: insn update-liveness-graph uses-vregs record-live ;
 
 GENERIC: live-insn? ( insn -- ? )
 
@@ -36,9 +36,8 @@ M: ##flushable live-insn? dst>> live-vregs get key? ;
 
 M: insn live-insn? drop t ;
 
-: eliminate-dead-code ( rpo -- rpo )
+: eliminate-dead-code ( rpo -- )
     init-dead-code
-    [ [ instructions>> [ compute-liveness ] each ] each ]
+    [ [ instructions>> [ update-liveness-graph ] each ] each ]
     [ [ [ [ live-insn? ] filter ] change-instructions drop ] each ]
-    [ ]
+    bi ;
-    tri ;

basis/compiler/cfg/dominance/dominance.factor

@@ -37,5 +37,5 @@ PRIVATE>
 
 : compute-dominance ( cfg -- cfg )
     H{ } clone idoms set
-    dup entry>> reverse-post-order
+    dup reverse-post-order
     unclip dup set-idom drop '[ _ iterate ] loop ;

basis/compiler/cfg/height/height.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math namespaces sequences kernel fry
-compiler.cfg compiler.cfg.registers compiler.cfg.instructions ;
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.rpo ;
 IN: compiler.cfg.height
 
 ! Combine multiple stack height changes into one at the
@@ -42,10 +43,15 @@ M: ##replace normalize-height* normalize-peek/replace ;
 
 M: insn normalize-height* ;
 
-: normalize-height ( insns -- insns' )
+: height-step ( insns -- insns' )
     0 ds-height set
     0 rs-height set
+    [
         [ [ compute-heights ] each ]
         [ [ [ normalize-height* ] map sift ] with-scope ] bi
         ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if
-    rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ;
+        rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if
+    ] change-instructions drop ;
+
+: normalize-height ( rpo -- )
+    [ height-step ] each ;

basis/compiler/cfg/instructions/instructions.factor

@@ -44,8 +44,8 @@ M: fixnum ##load-literal tag-fixnum ##load-immediate ;
 M: f ##load-literal drop \ f tag-number ##load-immediate ;
 M: object ##load-literal ##load-reference ;
 
-INSN: ##peek < ##read { loc loc } ;
+INSN: ##peek < ##flushable { loc loc } ;
-INSN: ##replace < ##write { loc loc } ;
+INSN: ##replace < ##effect { loc loc } ;
 INSN: ##inc-d { n integer } ;
 INSN: ##inc-r { n integer } ;
 

basis/compiler/cfg/linearization/linearization.factor

@@ -75,6 +75,6 @@ M: ##compare-float-branch linearize-insn
     [ [ linearize-basic-block ] each ] { } make ;
 
 : build-mr ( cfg -- mr )
-    [ entry>> reverse-post-order linearize-basic-blocks ]
+    [ reverse-post-order linearize-basic-blocks ]
     [ word>> ] [ label>> ]
     tri <mr> ;

basis/compiler/cfg/liveness/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/compiler/cfg/liveness/liveness.factor

@@ -0,0 +1,55 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces deques accessors sets sequences assocs fry dlists
+compiler.cfg.def-use compiler.cfg.rpo ;
+IN: compiler.cfg.liveness
+
+! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
+
+! Assoc mapping basic blocks to sets of vregs
+SYMBOL: live-ins
+
+: live-in ( basic-block -- set ) live-ins get at ;
+
+! Assoc mapping basic blocks to sets of vregs
+SYMBOL: live-outs
+
+: live-out ( basic-block -- set ) live-outs get at ;
+
+SYMBOL: work-list
+
+: add-to-work-list ( basic-blocks -- )
+    work-list get '[ _ push-front ] each ;
+
+: map-unique ( seq quot -- assoc )
+    map concat unique ; inline
+
+: gen-set ( basic-block -- seq )
+    instructions>> [ uses-vregs ] map-unique ;
+
+: kill-set ( basic-block -- seq )
+    instructions>> [ defs-vregs ] map-unique ;
+
+: update-live-in ( basic-block -- changed? )
+    [
+        [ [ gen-set ] [ live-out ] bi assoc-union ]
+        [ kill-set ]
+        bi assoc-diff
+    ] keep live-ins get maybe-set-at ;
+
+: update-live-out ( basic-block -- changed? )
+    [ successors>> [ live-in ] map assoc-combine ] 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-liveness ( rpo -- )
+    <hashed-dlist> work-list set
+    H{ } clone live-ins set
+    H{ } clone live-outs set
+    <reversed> add-to-work-list
+    work-list get [ liveness-step ] slurp-deque ;

basis/compiler/cfg/optimizer/optimizer.factor

@@ -1,29 +1,32 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences compiler.cfg.rpo
+USING: kernel sequences accessors combinators
-compiler.cfg.instructions
 compiler.cfg.predecessors
 compiler.cfg.useless-blocks
 compiler.cfg.height
+compiler.cfg.stack-analysis
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
-compiler.cfg.dead-code
+compiler.cfg.dce
-compiler.cfg.write-barrier ;
+compiler.cfg.write-barrier
+compiler.cfg.liveness
+compiler.cfg.rpo ;
 IN: compiler.cfg.optimizer
 
-: trivial? ( insns -- ? )
+: optimize-cfg ( cfg -- cfg )
-    dup length 2 = [ first ##call? ] [ drop f ] if ;
-
-: optimize-cfg ( cfg -- cfg' )
-    compute-predecessors
-    delete-useless-blocks
-    delete-useless-conditionals
     [
-        dup trivial? [
+        [ compute-predecessors ]
-            normalize-height
+        [ delete-useless-blocks ]
-            alias-analysis
+        [ delete-useless-conditionals ] tri
-            value-numbering
+    ] [
-            eliminate-dead-code
+        reverse-post-order
-            eliminate-write-barriers
+        {
-        ] unless
+            [ compute-liveness ]
-    ] change-basic-blocks ;
+            [ normalize-height ]
+            [ stack-analysis ]
+            [ alias-analysis ]
+            [ value-numbering ]
+            [ eliminate-dead-code ]
+            [ eliminate-write-barriers ]
+        } cleave
+    ] [ ] tri ;

basis/compiler/cfg/predecessors/predecessors.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 accessors sequences compiler.cfg.rpo ;
 IN: compiler.cfg.predecessors
 
-: (compute-predecessors) ( bb -- )
+: predecessors-step ( bb -- )
     dup successors>> [ predecessors>> push ] with each ;
 
-: compute-predecessors ( cfg -- cfg' )
+: compute-predecessors ( cfg -- )
-    dup [ (compute-predecessors) ] each-basic-block ;
+    [ predecessors-step ] each-basic-block ;

basis/compiler/cfg/rpo/rpo.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces make math sequences sets
 assocs fry compiler.cfg compiler.cfg.instructions ;
@@ -7,29 +7,24 @@ IN: compiler.cfg.rpo
 SYMBOL: visited
 
 : post-order-traversal ( bb -- )
-    dup id>> visited get key? [ drop ] [
+    dup visited get key? [ drop ] [
-        dup id>> visited get conjoin
+        dup visited get conjoin
         [
             successors>> <reversed>
             [ post-order-traversal ] each
         ] [ , ] bi
     ] if ;
 
-: post-order ( bb -- blocks )
+: post-order ( cfg -- blocks )
-    [ post-order-traversal ] { } make ;
+    [ entry>> post-order-traversal ] { } make ;
 
 : number-blocks ( blocks -- )
     [ >>number drop ] each-index ;
 
-: reverse-post-order ( bb -- blocks )
+: reverse-post-order ( cfg -- blocks )
     H{ } clone visited [
         post-order <reversed> dup number-blocks
     ] with-variable ; inline
 
 : each-basic-block ( cfg quot -- )
-    [ entry>> reverse-post-order ] dip each ; inline
+    [ reverse-post-order ] dip each ; inline
-
-: change-basic-blocks ( cfg quot -- cfg' )
-    [ '[ _ change-instructions drop ] each-basic-block ]
-    [ drop ]
-    2bi ; inline

basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor

@@ -6,10 +6,6 @@ compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
 compiler.cfg.dce compiler.cfg.registers sets ;
 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
-
 ! Fundamental invariant: a basic block should not load or store a value more than once
 : check-for-redundant-ops ( rpo -- )
     [
@@ -25,11 +21,12 @@ IN: compiler.cfg.stack-analysis.tests
 
 : test-stack-analysis ( quot -- mr )
     dup cfg? [ test-cfg first ] unless
-    compute-predecessors
+    dup compute-predecessors
-    entry>> reverse-post-order
+    reverse-post-order
-    optimize-stack
+    dup stack-analysis
-    dup [ [ normalize-height ] change-instructions drop ] each
+    dup normalize-height
-    dup check-rpo dup check-for-redundant-ops ;
+    dup check-rpo
+    dup check-for-redundant-ops ;
 
 [ ] [ [ ] test-stack-analysis drop ] unit-test
 
@@ -81,13 +78,13 @@ IN: compiler.cfg.stack-analysis.tests
 
 ! Make sure the replace stores a value with the right height
 [ ] [
-    [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize-basic-blocks
+    [ [ . ] [ 2drop 1 ] if ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
     [ ##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-basic-blocks
+    [ 1 2 rot ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
     [ [ ##load-immediate? ] count 2 assert= ]
     [ [ ##peek? ] count 1 assert= ]
     [ [ ##replace? ] count 3 assert= ]
@@ -95,7 +92,7 @@ IN: compiler.cfg.stack-analysis.tests
 ] unit-test
 
 [ ] [
-    [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize-basic-blocks
+    [ 1 2 ? ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
     [ [ ##load-immediate? ] count 2 assert= ]
     [ [ ##peek? ] count 1 assert= ]
     [ [ ##replace? ] count 1 assert= ]
@@ -104,6 +101,6 @@ IN: compiler.cfg.stack-analysis.tests
 
 ! Sync before a back-edge, not after
 [ 1 ] [
-    [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize-basic-blocks
+    [ 1000 [ ] times ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
     [ ##add-imm? ] count
 ] unit-test

basis/compiler/cfg/stack-analysis/stack-analysis.factor

@@ -10,15 +10,15 @@ 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 actual-locs>vregs changed-locs d-height r-height poisoned? ;
+TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height poisoned? ;
 
 : <state> ( -- state )
     state new
         H{ } clone >>locs>vregs
         H{ } clone >>actual-locs>vregs
         H{ } clone >>changed-locs
-        0 >>d-height
+        0 >>ds-height
-        0 >>r-height ;
+        0 >>rs-height ;
 
 M: state clone
     call-next-method
@@ -39,8 +39,8 @@ M: state clone
 
 GENERIC: height-for ( loc -- n )
 
-M: ds-loc height-for drop state get d-height>> ;
+M: ds-loc height-for drop state get ds-height>> ;
-M: rs-loc height-for drop state get r-height>> ;
+M: rs-loc height-for drop state get rs-height>> ;
 
 : (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
 
@@ -105,11 +105,11 @@ M: sync-if-back-edge visit
     [ sync-state ] when
     , ;
 
-: adjust-d ( n -- ) state get [ + ] change-d-height drop ;
+: adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
 
 M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
 
-: adjust-r ( n -- ) state get [ + ] change-r-height drop ;
+: adjust-r ( n -- ) state get [ + ] change-rs-height drop ;
 
 M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
 
@@ -198,8 +198,8 @@ ERROR: must-equal-failed seq ;
 
 : merge-heights ( state predecessors states -- state )
     nip
-    [ [ d-height>> ] map must-equal >>d-height ]
+    [ [ ds-height>> ] map must-equal >>ds-height ]
-    [ [ r-height>> ] map must-equal >>r-height ] bi ;
+    [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
 
 : insert-peek ( predecessor loc -- vreg )
     ! XXX critical edges
@@ -300,10 +300,10 @@ ERROR: cannot-merge-poisoned states ;
         ] 2bi
     ] V{ } make >>instructions drop ;
 
-: optimize-stack ( rpo -- rpo )
+: stack-analysis ( rpo -- )
     [
         H{ } clone copies set
         H{ } clone state-in set
         H{ } clone state-out set
-        dup [ visit-block ] each
+        [ visit-block ] each
     ] with-scope ;

basis/compiler/cfg/useless-blocks/useless-blocks.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences combinators classes vectors
-compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
+compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
 IN: compiler.cfg.useless-blocks
 
 : update-predecessor-for-delete ( bb -- )
@@ -30,8 +30,8 @@ IN: compiler.cfg.useless-blocks
         [ t ]
     } cond nip ;
 
-: delete-useless-blocks ( cfg -- cfg' )
+: delete-useless-blocks ( cfg -- )
-    dup [
+    [
         dup delete-basic-block? [ delete-basic-block ] [ drop ] if
     ] each-basic-block ;
 
@@ -49,7 +49,7 @@ IN: compiler.cfg.useless-blocks
     [ but-last f \ ##branch boa suffix ] change-instructions
     drop ;
 
-: delete-useless-conditionals ( cfg -- cfg' )
+: delete-useless-conditionals ( cfg -- )
-    dup [
+    [
         dup delete-conditional? [ delete-conditional ] [ drop ] if
     ] each-basic-block ;

basis/compiler/cfg/value-numbering/expressions/expressions.factor

@@ -22,17 +22,17 @@ M: constant-expr equal?
         and
     ] [ 2drop f ] if ;
 
-SYMBOL: input-expr-counter
-
-: next-input-expr ( -- n )
-    input-expr-counter [ dup 1 + ] change ;
-
 ! Expressions whose values are inputs to the basic block. We
 ! can eliminate a second computation having the same 'n' as
 ! the first one; we can also eliminate input-exprs whose
 ! result is not used.
 TUPLE: input-expr < expr n ;
 
+SYMBOL: input-expr-counter
+
+: next-input-expr ( class -- expr )
+    input-expr-counter [ dup 1 + ] change input-expr boa ;
+
 : constant>vn ( constant -- vn ) <constant> expr>vn ; inline
 
 GENERIC: >expr ( insn -- expr )
@@ -80,7 +80,7 @@ M: ##compare-imm >expr compare-imm>expr ;
 
 M: ##compare-float >expr compare>expr ;
 
-M: ##flushable >expr class next-input-expr input-expr boa ;
+M: ##flushable >expr class next-input-expr ;
 
 : init-expressions ( -- )
     0 input-expr-counter set ;

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -2,7 +2,7 @@ IN: compiler.cfg.value-numbering.tests
 USING: compiler.cfg.value-numbering compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger cpu.architecture
 tools.test kernel math combinators.short-circuit accessors
-sequences ;
+sequences compiler.cfg vectors arrays ;
 
 : trim-temps ( insns -- insns )
     [
@@ -13,6 +13,10 @@ sequences ;
         } 1|| [ f >>temp ] when
     ] map ;
 
+: test-value-numbering ( insns -- insns )
+    basic-block new swap >vector >>instructions
+    dup value-numbering-step instructions>> >array ;
+
 [
     {
         T{ ##peek f V int-regs 45 D 1 }
@@ -24,7 +28,7 @@ sequences ;
         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
+    } test-value-numbering
 ] unit-test
 
 [
@@ -40,14 +44,14 @@ sequences ;
         T{ ##peek f V int-regs 3 D 0 }
         T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
         T{ ##replace f V int-regs 4 D 0 }
-    } value-numbering
+    } test-value-numbering
 ] unit-test
 
 [ t ] [
     {
         T{ ##peek f V int-regs 1 D 0 }
         T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
-    } dup value-numbering =
+    } dup test-value-numbering =
 ] unit-test
 
 [ t ] [
@@ -60,7 +64,7 @@ sequences ;
         T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
         T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
         T{ ##replace f V int-regs 23 D 0 }
-    } dup value-numbering =
+    } dup test-value-numbering =
 ] unit-test
 
 [
@@ -76,7 +80,7 @@ sequences ;
         T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
         T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
         T{ ##replace f V int-regs 3 D 0 }
-    } value-numbering
+    } test-value-numbering
 ] unit-test
 
 [
@@ -94,7 +98,7 @@ sequences ;
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
         T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
         T{ ##replace f V int-regs 6 D 0 }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
 ] unit-test
 
 [
@@ -112,7 +116,7 @@ sequences ;
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
         T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
         T{ ##replace f V int-regs 6 D 0 }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
 ] unit-test
 
 [
@@ -134,7 +138,7 @@ sequences ;
         T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
         T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
         T{ ##replace f V int-regs 14 D 0 }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
 ] unit-test
 
 [
@@ -150,5 +154,5 @@ sequences ;
         T{ ##peek f V int-regs 30 D -2 }
         T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
         T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
 ] unit-test

basis/compiler/cfg/value-numbering/value-numbering.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs biassocs classes kernel math accessors
 sorting sets sequences
+compiler.cfg.liveness
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.propagate
@@ -9,7 +10,14 @@ compiler.cfg.value-numbering.simplify
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering
 
-: value-numbering ( insns -- insns' )
+: number-input-values ( basic-block -- )
+    live-in keys [ [ next-input-expr ] dip set-vn ] each ;
+
+: value-numbering-step ( basic-block -- )
     init-value-graph
     init-expressions
-    [ [ number-values ] [ rewrite propagate ] bi ] map ;
+    dup number-input-values
+    [ [ [ number-values ] [ rewrite propagate ] bi ] map ] change-instructions drop ;
+
+: value-numbering ( rpo -- )
+    [ value-numbering-step ] each ;

basis/compiler/cfg/write-barrier/write-barrier-tests.factor

@@ -1,8 +1,12 @@
 USING: compiler.cfg.write-barrier compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-arrays tools.test ;
+arrays tools.test vectors compiler.cfg kernel accessors ;
 IN: compiler.cfg.write-barrier.tests
 
+: test-write-barrier ( insns -- insns )
+    basic-block new swap >vector >>instructions
+    dup write-barriers-step instructions>> >array ;
+
 [
     {
         T{ ##peek f V int-regs 4 D 0 f }
@@ -24,7 +28,7 @@ IN: compiler.cfg.write-barrier.tests
         T{ ##set-slot-imm f V int-regs 6 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 }
-    } eliminate-write-barriers
+    } test-write-barrier
 ] unit-test
 
 [
@@ -42,7 +46,7 @@ IN: compiler.cfg.write-barrier.tests
         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 }
-    } eliminate-write-barriers
+    } test-write-barrier
 ] unit-test
 
 [
@@ -69,5 +73,5 @@ IN: compiler.cfg.write-barrier.tests
         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 }
-    } eliminate-write-barriers
+    } test-write-barrier
 ] unit-test

basis/compiler/cfg/write-barrier/write-barrier.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! 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 ;
@@ -35,8 +35,11 @@ M: ##set-slot-imm eliminate-write-barrier
 
 M: insn eliminate-write-barrier ;
 
-: eliminate-write-barriers ( insns -- insns' )
+: write-barriers-step ( basic-block -- )
     H{ } clone safe set
     H{ } clone mutated set
     H{ } clone copies set
-    [ eliminate-write-barrier ] map sift ;
+    [ [ eliminate-write-barrier ] map sift ] change-instructions drop ;
+
+: eliminate-write-barriers ( rpo -- )
+    [ write-barriers-step ] each ;