compiler.cfg.dcn: Fixing various bugs, hook up with optimizer

basis/compiler/cfg/dcn/dcn-tests.factor

@@ -1,12 +1,14 @@
 IN: compiler.cfg.dcn.tests
-USING: tools.test kernel accessors namespaces assocs
+USING: tools.test kernel accessors namespaces assocs math
-cpu.architecture vectors sequences
+cpu.architecture vectors sequences classes
 compiler.cfg
 compiler.cfg.utilities
 compiler.cfg.debugger
 compiler.cfg.registers
 compiler.cfg.predecessors
 compiler.cfg.instructions
+compiler.cfg.checker
+compiler.cfg.dcn
 compiler.cfg.dcn.height
 compiler.cfg.dcn.local
 compiler.cfg.dcn.local.private
@@ -19,12 +21,19 @@ compiler.cfg.dcn.rewrite ;
     [ local-analysis ] keep
     instructions>> ;
 
+: inserting-peeks' ( from to -- assoc )
+    [ inserting-peeks ] keep untranslate-locs keys ;
+
+: inserting-replaces' ( from to -- assoc )
+    [ inserting-replaces ] keep untranslate-locs remove-dead-stores keys ;
+
 [
     V{
         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 }
+        T{ ##branch }
     }
 ] [
     V{
@@ -38,6 +47,7 @@ compiler.cfg.dcn.rewrite ;
         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 }
+        T{ ##branch }
     } test-local-dcn
 ] unit-test
 
@@ -68,11 +78,10 @@ compiler.cfg.dcn.rewrite ;
 : test-global-dcn ( -- )
     cfg new 0 get >>entry
     compute-predecessors
-    [ compute-heights ]
+    deconcatenatize
-    [ compute-local-sets ]
+    check-cfg ;
-    [ compute-global-sets ] tri ;
 
-V{ T{ ##return } } 0 test-bb
+V{ T{ ##epilogue } T{ ##return } } 0 test-bb
 
 [ ] [ test-global-dcn ] unit-test
 
@@ -84,7 +93,9 @@ V{
 V{
     T{ ##inc-d f 1 }
     T{ ##peek f V int-regs 0 D 1 }
+    T{ ##load-immediate f V int-regs 1 100 }
     T{ ##replace f V int-regs 1 D 2 }
+    T{ ##branch }
 } 1 test-bb
 
 V{
@@ -108,13 +119,13 @@ V{
 
 [ f ] [ D 0 0 get avail-out key? ] unit-test
 
-[ { D 0 } ] [ 0 get 1 get inserting-peeks keys ] unit-test
+[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
 
-[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
 
-[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test
+[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
 
-[ { D 2 } ] [ 1 get 2 get inserting-replaces keys ] unit-test
+[ { D 2 } ] [ 1 get 2 get inserting-replaces' ] unit-test
 
 V{
     T{ ##prologue }
@@ -123,21 +134,29 @@ V{
 
 V{
     T{ ##peek f V int-regs 0 D 1 }
+    T{ ##branch }
 } 1 test-bb
 
 V{
     T{ ##inc-d f -1 }
     T{ ##peek f V int-regs 0 D 0 }
+    T{ ##branch }
 } 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
 
 [ t ] [ D 1 2 get peek-in key? ] unit-test
-[ { D 1 } ] [ 0 get 1 get inserting-peeks keys ] unit-test
+[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
 
 V{
     T{ ##prologue }
@@ -184,16 +203,16 @@ V{
 [ 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
+[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test
+[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test
+[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test
+[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
-[ { D 1 } ] [ 1 get 4 get inserting-peeks keys ] unit-test
+[ { D 1 } ] [ 1 get 4 get inserting-peeks' ] unit-test
-[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test
+[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test
+[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
-[ { D 1 } ] [ 4 get 5 get inserting-replaces keys ] unit-test
+[ { D 1 } ] [ 4 get 5 get inserting-replaces' ] unit-test
 
 [ t ] [ D 0 1 get peek-out key? ] unit-test
 [ f ] [ D 1 1 get peek-out key? ] unit-test
@@ -219,6 +238,7 @@ V{
 } 2 test-bb
 
 V{
+    T{ ##load-immediate f V int-regs 2 100 }
     T{ ##replace f V int-regs 2 D 1 }
     T{ ##inc-d f -1 }
     T{ ##peek f V int-regs 4 D 1 }
@@ -226,6 +246,7 @@ V{
 } 3 test-bb
 
 V{
+    T{ ##load-immediate f V int-regs 3 100 }
     T{ ##replace f V int-regs 3 D 0 }
     T{ ##branch }
 } 4 test-bb
@@ -248,16 +269,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 keys ] unit-test
+[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test
+[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
-[ { D 1 } ] [ 1 get 2 get inserting-peeks keys ] unit-test
+[ { D 1 } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { D 2 } ] [ 1 get 3 get inserting-peeks keys ] unit-test
+[ { D 2 } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test
+[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test
+[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
-[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test
+[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test
+[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
-[ { D 0 } ] [ 4 get 5 get inserting-replaces keys ] unit-test
+[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test
 
 V{
     T{ ##prologue }
@@ -281,9 +302,14 @@ V{
 
 V{
     T{ ##peek f V int-regs 1 D 0 }
-    T{ ##return }
+    T{ ##branch }
 } 4 test-bb
 
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 5 test-bb
+
 [ t ] [ 0 get kill-block? ] unit-test
 [ t ] [ 3 get kill-block? ] unit-test
 
@@ -291,6 +317,7 @@ V{
 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
 
@@ -299,11 +326,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 keys ] unit-test
+[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test
+[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 2 get 4 get inserting-peeks keys ] unit-test
+[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 3 get 4 get inserting-peeks keys ] unit-test
+[ { D 0 } ] [ 3 get 4 get inserting-peeks' ] unit-test
 
 V{
     T{ ##prologue }
@@ -315,7 +342,7 @@ V{
     T{ ##branch }
 } 1 test-bb
 
-V{ T{ ##return } } 2 test-bb
+V{ T{ ##epilogue } T{ ##return } } 2 test-bb
 
 V{ T{ ##branch } } 3 test-bb
 
@@ -327,10 +354,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 keys ] unit-test
+[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks keys ] unit-test
+[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 3 get 1 get inserting-peeks keys ] unit-test
+[ { } ] [ 3 get 1 get inserting-peeks' ] unit-test
 
 V{
     T{ ##prologue }
@@ -374,13 +401,13 @@ V{
 
 [ ] [ test-global-dcn ] unit-test
 
-[ { } ] [ 0 get 1 get inserting-peeks keys ] unit-test
+[ { } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test
+[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 2 get 4 get inserting-peeks keys ] unit-test
+[ { D 0 } ] [ 2 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 1 get 3 get inserting-peeks keys ] unit-test
+[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test
+[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
-[ { } ] [ 5 get 6 get inserting-peeks keys ] unit-test
+[ { } ] [ 5 get 6 get inserting-peeks' ] unit-test
 
 V{
     T{ ##prologue }
@@ -392,6 +419,7 @@ V{
 } 1 test-bb
 
 V{
+    T{ ##load-immediate f V int-regs 1 100 }
     T{ ##replace f V int-regs 1 D 0 }
     T{ ##branch }
 } 2 test-bb
@@ -419,16 +447,16 @@ V{
 
 [ ] [ test-global-dcn ] unit-test
 
-[ { } ] [ 1 get 2 get inserting-peeks keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { D 0 } ] [ 1 get 3 get inserting-peeks keys ] unit-test
+[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-replaces keys ] unit-test
+[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
-[ { } ] [ 2 get 4 get inserting-peeks keys ] unit-test
+[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 2 get 4 get inserting-replaces keys ] unit-test
+[ { D 0 } ] [ 2 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks keys ] unit-test
+[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
-[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test
+[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks keys ] unit-test
+[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
-[ { } ] [ 4 get 5 get inserting-replaces keys ] unit-test
+[ { } ] [ 4 get 5 get inserting-replaces' ] unit-test
 
 V{
     T{ ##prologue }
@@ -440,11 +468,13 @@ V{
 } 1 test-bb
 
 V{
+    T{ ##load-immediate f V int-regs 1 100 }
     T{ ##replace f V int-regs 1 D 0 }
     T{ ##branch }
 } 2 test-bb
 
 V{
+    T{ ##load-immediate f V int-regs 2 100 }
     T{ ##replace f V int-regs 2 D 0 }
     T{ ##branch }
 } 3 test-bb
@@ -466,11 +496,11 @@ V{
 
 [ ] [ test-global-dcn ] unit-test
 
-[ { } ] [ 2 get 4 get inserting-replaces keys ] unit-test
+[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
 
-[ { } ] [ 3 get 4 get inserting-replaces keys ] unit-test
+[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
 
-[ { D 0 } ] [ 4 get 5 get inserting-replaces keys ] unit-test
+[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test
 
 ! Dead replace elimination
 V{
@@ -483,10 +513,12 @@ V{
     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 }
+    T{ ##branch }
 } 1 test-bb
 
 V{
     T{ ##inc-d f -2 }
+    T{ ##branch }
 } 2 test-bb
 
 V{
@@ -500,6 +532,90 @@ V{
 
 [ ] [ test-global-dcn ] unit-test
 
-[ { } ] [ 0 get 1 get inserting-replaces keys ] unit-test
+[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces keys ] unit-test
+[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { } ] [ 2 get 3 get inserting-replaces keys ] unit-test
+[ { } ] [ 2 get 3 get inserting-replaces' ] unit-test
+
+! More dead replace elimination tests
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{    
+    T{ ##peek { dst V int-regs 10 } { loc D 0 } }
+    T{ ##inc-d { n -1 } }
+    T{ ##inc-r { n 1 } }
+    T{ ##replace { src V int-regs 10 } { loc R 0 } }
+    T{ ##peek { dst V int-regs 12 } { loc R 0 } }
+    T{ ##inc-r { n -1 } }
+    T{ ##inc-d { n 1 } }
+    T{ ##replace { src V int-regs 12 } { loc D 0 } }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 1vector >>successors drop
+
+[ ] [ test-global-dcn ] unit-test
+
+[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
+
+! Check that retain stack usage works
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##inc-d f -1 }
+    T{ ##inc-r f 1 }
+    T{ ##replace f V int-regs 0 R 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##call f + -1 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 R 0 }
+    T{ ##inc-r f -1 }
+    T{ ##inc-d f 1 }
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 1vector >>successors drop
+2 get 3 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+
+[ ] [ test-global-dcn ] unit-test
+
+[ ##replace D 0 ] [
+    3 get successors>> first instructions>> first
+    [ class ] [ loc>> ] bi
+] unit-test
+
+[ ##replace R 0 ] [
+    1 get successors>> first instructions>> first
+    [ class ] [ loc>> ] bi
+] unit-test
+
+[ ##peek R 0 ] [
+    2 get successors>> first instructions>> first
+    [ class ] [ loc>> ] bi
+] unit-test

basis/compiler/cfg/dcn/height/height.factor

@@ -53,16 +53,6 @@ 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* - <ds-loc> ;
-M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - <ds-loc> ;
-
-GENERIC# untranslate-loc 1 ( loc bb -- loc' )
-
-M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + <ds-loc> ;
-M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + <ds-loc> ;
-
 PRIVATE>
 
 : compute-heights ( cfg -- )
@@ -75,8 +65,18 @@ PRIVATE>
         [ compute-ds-height ] bi
     ] each-basic-block ;
 
+GENERIC# translate-loc 1 ( loc bb -- loc' )
+
+M: ds-loc translate-loc [ n>> ] [ in-ds-heights get at ] bi* - <ds-loc> ;
+M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - <rs-loc> ;
+
 : translate-locs ( assoc bb -- assoc' )
     '[ [ _ translate-loc ] dip ] assoc-map ;
 
+GENERIC# untranslate-loc 1 ( loc bb -- loc' )
+
+M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + <ds-loc> ;
+M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + <rs-loc> ;
+
 : untranslate-locs ( assoc bb -- assoc' )
     '[ [ _ untranslate-loc ] dip ] assoc-map ;

basis/compiler/cfg/dcn/local/local.factor

@@ -61,20 +61,24 @@ M: ##copy visit
     ds-height get dup 0 = [ drop ] [ ##inc-d ] if
     rs-height get dup 0 = [ drop ] [ ##inc-r ] if ;
 
+: init-local-analysis ( -- )
+    0 ds-height set
+    0 rs-height set
+    H{ } clone copies set
+    H{ } clone reads-locations set
+    H{ } clone writes-locations set ;
+
 : 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
+    init-local-analysis
-    0 rs-height set
-    H{ } clone copies set
-    H{ } clone reads-locations set
-    H{ } clone writes-locations set
     [
         [
-            [ visit ] each
+            unclip-last-slice [ [ visit ] each ] dip
             insert-height-changes
+            ,
         ] V{ } make
     ] change-instructions drop ;
 

basis/compiler/cfg/dcn/rewrite/rewrite.factor

@@ -11,32 +11,35 @@ IN: compiler.cfg.dcn.rewrite
 ! vreg. SSA is reconstructed afterwards.
 
 : inserting-peeks ( from to -- assoc )
-    [
+    peek-in swap [ peek-out ] [ avail-out ] bi
-        peek-in swap [ peek-out ] [ avail-out ] bi
+    assoc-union assoc-diff ;
-        assoc-union assoc-diff
-    ] keep untranslate-locs ;
 
 : remove-dead-stores ( assoc -- assoc' )
     [ drop n>> 0 >= ] assoc-filter ;
 
 : inserting-replaces ( from to -- assoc )
-    [
+    [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
-        [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
+    assoc-union assoc-diff ;
-        assoc-union assoc-diff
-    ] keep untranslate-locs remove-dead-stores ;
 
 SYMBOL: locs>vregs
 
 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
 
-: each-insertion ( assoc quot: ( vreg loc -- ) -- )
+: each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
-    '[ drop [ loc>vreg ] keep @ ] assoc-each ; inline
+    '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
+
+ERROR: bad-peek dst loc ;
+
+: insert-peeks ( from to -- )
+    [ inserting-peeks ] keep
+    [ dup n>> 0 < [ bad-peek ] [ ##peek ] if ] each-insertion ;
+
+: insert-replaces ( from to -- )
+    [ inserting-replaces ] keep
+    [ dup n>> 0 < [ 2drop ] [ ##replace ] if ] each-insertion ;
 
 : visit-edge ( from to -- )
-    2dup [
+    2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
-        [ inserting-peeks [ ##peek ] each-insertion ]
-        [ inserting-replaces [ ##replace ] each-insertion ] 2bi
-    ] V{ } make
     [ 2drop ] [ <simple-block> insert-basic-block ] if-empty ;
 
 : visit-edges ( bb -- )

basis/compiler/cfg/optimizer/optimizer.factor

@@ -5,6 +5,9 @@ compiler.cfg.tco
 compiler.cfg.predecessors
 compiler.cfg.useless-conditionals
 compiler.cfg.stack-analysis
+compiler.cfg.dcn
+compiler.cfg.dominance
+compiler.cfg.ssa
 compiler.cfg.branch-splitting
 compiler.cfg.block-joining
 compiler.cfg.alias-analysis
@@ -24,17 +27,24 @@ SYMBOL: check-optimizer?
         dup check-cfg
     ] when ;
 
+SYMBOL: new-optimizer?
+
 : optimize-cfg ( cfg -- cfg' )
     ! Note that compute-predecessors has to be called several times.
     ! The passes that need this document it.
     [
         optimize-tail-calls
-        delete-useless-conditionals
+        new-optimizer? get [ delete-useless-conditionals ] unless
         compute-predecessors
-        split-branches
+        new-optimizer? get [ split-branches ] unless
+        new-optimizer? get [
+            deconcatenatize
+            compute-dominance
+            construct-ssa
+        ] when
         join-blocks
         compute-predecessors
-        stack-analysis
+        new-optimizer? get [ stack-analysis ] unless
         compute-liveness
         alias-analysis
         value-numbering