compiler.cfg: Some code cleanups, update stack-analysis and phi-insertion to work...

diff --git a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor b/basis/compiler/cfg/branch-folding/branch-folding-tests.factor
index 964620d2d3890b274614ad12aaceb151bdcd787d..8ae1f6b75b5dff6e6d21b31865e5a0adee15fafb 100644 (file)
--- a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor
+++ b/basis/compiler/cfg/branch-folding/branch-folding-tests.factor
@@ -40,7 +40,10 @@ test-diamond
 [ 1 ] [ 1 get successors>> length ] unit-test
 [ t ] [ 1 get successors>> first 3 get eq? ] unit-test
 
-[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
+[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
+[ 3 get successors>> first instructions>> first ]
+unit-test
+
 [ 2 ] [ 4 get instructions>> length ] unit-test
 
 V{

diff --git a/basis/compiler/cfg/branch-folding/branch-folding.factor b/basis/compiler/cfg/branch-folding/branch-folding.factor
index 627db63c9f8951d91f9f2960b8f7b7c7efbd5cc3..2432849a9aabd30d949c95f6511c87c4a459720d 100644 (file)
--- a/basis/compiler/cfg/branch-folding/branch-folding.factor
+++ b/basis/compiler/cfg/branch-folding/branch-folding.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators.short-circuit kernel sequences vectors
-compiler.cfg.instructions compiler.cfg.rpo ;
+compiler.cfg.instructions compiler.cfg.rpo compiler.cfg ;
 IN: compiler.cfg.branch-folding
 
 ! Fold comparisons where both inputs are the same. Predecessors must be
@@ -27,4 +27,4 @@ IN: compiler.cfg.branch-folding
         dup fold-branch?
         [ fold-branch ] [ drop ] if
     ] each-basic-block
-    f >>post-order ;
\ No newline at end of file
+    cfg-changed ;
\ No newline at end of file

diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 12a1180d4093c42edf6955a31290ca328934693a..f856efac78fd6df6c16e04feb1f1a53250a8cf80 100644 (file)
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -1,9 +1,6 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays vectors accessors assocs sets
-namespaces math make fry sequences
-combinators.short-circuit
-compiler.cfg.instructions ;
+USING: kernel math vectors arrays accessors namespaces ;
 IN: compiler.cfg
 
 TUPLE: basic-block < identity-tuple
@@ -22,39 +19,12 @@ M: basic-block hashcode* nip id>> ;
         V{ } clone >>predecessors
         \ basic-block counter >>id ;
 
-: empty-block? ( bb -- ? )
-    instructions>> {
-        [ length 1 = ]
-        [ first ##branch? ]
-    } 1&& ;
-
-SYMBOL: visited
-
-: (skip-empty-blocks) ( bb -- bb' )
-    dup visited get key? [
-        dup empty-block? [
-            dup visited get conjoin
-            successors>> first (skip-empty-blocks)
-        ] when
-    ] unless ;
-
-: skip-empty-blocks ( bb -- bb' )
-    H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
-
-: add-instructions ( bb quot -- )
-    [ instructions>> building ] dip '[
-        building get pop
-        _ dip
-        building get push
-    ] with-variable ; inline
-
-: back-edge? ( from to -- ? )
-    [ number>> ] bi@ > ;
-
 TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
 
 : <cfg> ( entry word label -- cfg ) f f cfg boa ;
 
+: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
+
 TUPLE: mr { instructions array } word label ;
 
 : <mr> ( instructions word label -- mr )

diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
index 93adc4c0f96383a5a5cd7c0b85ea39c3763f103a..f585d80d72a4bb11e7d4129eea9c69b24a655766 100755 (executable)
--- a/basis/compiler/cfg/optimizer/optimizer-tests.factor
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -1,7 +1,7 @@
 USING: accessors arrays compiler.cfg.checker
 compiler.cfg.debugger compiler.cfg.def-use
 compiler.cfg.instructions fry kernel kernel.private math
-math.private sbufs sequences sequences.private sets
+math.partial-dispatch math.private sbufs sequences sequences.private sets
 slots.private strings tools.test vectors layouts ;
 IN: compiler.cfg.optimizer.tests
 
@@ -31,6 +31,15 @@ IN: compiler.cfg.optimizer.tests
     [ [ 2 fixnum+ ] when 3 ]
     [ [ 2 fixnum- ] when 3 ]
     [ 10000 [ ] times ]
+    [
+        over integer? [
+            over dup 16 <-integer-fixnum
+            [ 0 >=-integer-fixnum ] [ drop f ] if [
+                nip dup
+                [ ] [ ] if
+            ] [ 2drop f ] if
+        ] [ 2drop f ] if
+    ]
 } [
     [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
 ] each

diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor b/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
index 4577e709973fee0204a0d05c2e93309b3dd10307..2dd75df693d591b22b879934810f966a6e1dcb00 100644 (file)
--- a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
+++ b/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
@@ -35,6 +35,12 @@ test-diamond
 
 [ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
 
-[ T{ ##copy f V int-regs 3 V int-regs 1 } ] [ 2 get instructions>> second ] unit-test
-[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
+[ T{ ##copy f V int-regs 3 V int-regs 1 } ]
+[ 2 get successors>> first instructions>> first ]
+unit-test
+
+[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
+[ 3 get successors>> first instructions>> first ]
+unit-test
+
 [ 2 ] [ 4 get instructions>> length ] unit-test
\ No newline at end of file

diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor
index 9c2f0adafd90b0914b081f2793bf06d52e428898..7e184a9b5317fb5e89d2ba5428849d6652b45f29 100644 (file)
--- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor
+++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel sequences
-compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+USING: accessors assocs fry kernel sequences namespaces
+compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.utilities ;
 IN: compiler.cfg.phi-elimination
 
 : insert-copy ( predecessor input output -- )
@@ -11,7 +12,11 @@ IN: compiler.cfg.phi-elimination
     [ inputs>> ] [ dst>> ] bi '[ _ insert-copy ] assoc-each ;
 
 : eliminate-phi-step ( bb -- )
-    instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ;
+    H{ } clone added-instructions set
+    [ instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ]
+    [ insert-basic-blocks ]
+    bi ;
 
 : eliminate-phis ( cfg -- cfg' )
-    dup [ eliminate-phi-step ] each-basic-block ;
\ No newline at end of file
+    dup [ eliminate-phi-step ] each-basic-block
+    cfg-changed ;
\ No newline at end of file

diff --git a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
index 14a81958a9137b6f3ca631271e9d212853750892..e67f6b5143162bbe6379c30ebe3d99cb99ad2255 100644 (file)
--- a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
@@ -2,7 +2,7 @@ IN: compiler.cfg.stack-analysis.merge.tests
 USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
 compiler.cfg.instructions compiler.cfg.stack-analysis.state
 compiler.cfg compiler.cfg.registers compiler.cfg.debugger
-cpu.architecture make assocs
+cpu.architecture make assocs namespaces
 sequences kernel classes ;
 
 [
@@ -11,13 +11,15 @@ sequences kernel classes ;
 ] [
     <state>
 
-    <basic-block> V{ T{ ##branch } } >>instructions
-    <basic-block> V{ T{ ##branch } } >>instructions 2array
+    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
+    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
 
     <state> H{ { D 0 V int-regs 0 } } >>locs>vregs
     <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
 
-    [ merge-locs locs>vregs>> keys ] { } make first inputs>> values
+    H{ } clone added-instructions set
+    V{ } clone added-phis set
+    merge-locs locs>vregs>> keys added-phis get values first
 ] unit-test
 
 [
@@ -26,15 +28,16 @@ sequences kernel classes ;
 ] [
     <state>
 
-    <basic-block> V{ T{ ##branch } } >>instructions
-    <basic-block> V{ T{ ##branch } } >>instructions 2array
+    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
+    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
 
-    [
-        <state>
-        <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+    <state>
+    <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
 
-        [ merge-locs locs>vregs>> keys ] { } make drop
-    ] keep first instructions>> first class
+    H{ } clone added-instructions set
+    V{ } clone added-phis set
+    [ merge-locs locs>vregs>> keys ] { } make drop
+    1 get added-instructions get at first class
 ] unit-test
 
 [
@@ -42,15 +45,17 @@ sequences kernel classes ;
 ] [
     <state>
 
-    <basic-block> V{ T{ ##branch } } >>instructions
-    <basic-block> V{ T{ ##branch } } >>instructions 2array
+    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
+    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
 
-    [
-        <state> -1 >>ds-height
-        <state> 2array
+    H{ } clone added-instructions set
+    V{ } clone added-phis set
+
+    <state> -1 >>ds-height
+    <state> 2array
 
-        [ merge-ds-heights ds-height>> ] { } make drop
-    ] keep first instructions>> first class
+    [ merge-ds-heights ds-height>> ] { } make drop
+    1 get added-instructions get at first class
 ] unit-test
 
 [
@@ -63,6 +68,9 @@ sequences kernel classes ;
     <basic-block> V{ T{ ##branch } } >>instructions
     <basic-block> V{ T{ ##branch } } >>instructions 2array
 
+    H{ } clone added-instructions set
+    V{ } clone added-phis set
+    
     [
         <state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
         <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
@@ -82,6 +90,9 @@ sequences kernel classes ;
     <basic-block> V{ T{ ##branch } } >>instructions
     <basic-block> V{ T{ ##branch } } >>instructions 2array
 
+    H{ } clone added-instructions set
+    V{ } clone added-phis set
+    
     [
         <state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
         <state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array

diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor
index b6c443a2d325eb1be61267795e2f5d8ff7eda381..cb0ad7d615f9f4f0191fdfbf072753da024b7b0e 100644 (file)
--- a/basis/compiler/cfg/stack-analysis/merge/merge.factor
+++ b/basis/compiler/cfg/stack-analysis/merge/merge.factor
@@ -1,12 +1,11 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs sequences accessors fry combinators grouping
-sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.stack-analysis.state ;
+USING: kernel assocs sequences accessors fry combinators grouping sets
+arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.stack-analysis.state
+compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
 IN: compiler.cfg.stack-analysis.merge
 
-! XXX critical edges
-
 : initial-state ( bb states -- state ) 2drop <state> ;
 
 : single-predecessor ( bb states -- state ) nip first clone ;
@@ -27,14 +26,14 @@ IN: compiler.cfg.stack-analysis.merge
     [ nip first >>rs-height ]
     [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
 
-: assoc-map-values ( assoc quot -- assoc' )
+: assoc-map-keys ( assoc quot -- assoc' )
     '[ _ dip ] assoc-map ; inline
 
 : translate-locs ( assoc state -- assoc' )
-    '[ _ translate-loc ] assoc-map-values ;
+    '[ _ translate-loc ] assoc-map-keys ;
 
 : untranslate-locs ( assoc state -- assoc' )
-    '[ _ untranslate-loc ] assoc-map-values ;
+    '[ _ untranslate-loc ] assoc-map-keys ;
 
 : collect-locs ( loc-maps states -- assoc )
     ! assoc maps locs to sequences
@@ -45,12 +44,16 @@ IN: compiler.cfg.stack-analysis.merge
 : insert-peek ( predecessor loc state -- vreg )
     '[ _ _ translate-loc ^^peek ] add-instructions ;
 
+SYMBOL: added-phis
+
+: add-phi-later ( inputs -- vreg )
+    [ int-regs next-vreg dup ] dip 2array added-phis get push ;
+
 : merge-loc ( predecessors vregs loc state -- vreg )
     ! Insert a ##phi in the current block where the input
     ! is the vreg storing loc from each predecessor block
-    [ dup ] 3dip
     '[ [ ] [ _ _ insert-peek ] ?if ] 2map
-    dup all-equal? [ nip first ] [ zip ^^phi ] if ;
+    dup all-equal? [ first ] [ add-phi-later ] if ;
 
 :: merge-locs ( state predecessors states -- state )
     states [ locs>vregs>> ] map states collect-locs
@@ -77,30 +80,35 @@ IN: compiler.cfg.stack-analysis.merge
     over translate-locs
     >>changed-locs ;
 
-ERROR: cannot-merge-poisoned states ;
-
-: multiple-predecessors ( bb states -- state )
-    dup [ not ] any? [
-        2drop <state>
+:: insert-phis ( bb -- )
+    bb predecessors>> :> predecessors
+    [
+        added-phis get [| dst inputs |
+            dst predecessors inputs zip ##phi
+        ] assoc-each
+    ] V{ } make bb instructions>> over push-all
+    bb (>>instructions) ;
+
+:: multiple-predecessors ( bb states -- state )
+    states [ not ] any? [
+        <state>
     ] [
-        dup [ poisoned?>> ] any? [
-            cannot-merge-poisoned
-        ] [
-            [ state new ] 2dip
-            [ predecessors>> ] dip
-            {
-                [ merge-ds-heights ]
-                [ merge-rs-heights ]
-                [ merge-locs ]
-                [ nip merge-actual-locs ]
-                [ nip merge-changed-locs ]
-            } 2cleave
-        ] if
+        [
+            H{ } clone added-instructions set
+            V{ } clone added-phis set
+            bb predecessors>> :> predecessors
+            state new
+            predecessors states merge-ds-heights
+            predecessors states merge-rs-heights
+            predecessors states merge-locs
+            states merge-actual-locs
+            states merge-changed-locs
+            bb insert-basic-blocks
+            bb insert-phis
+        ] with-scope
     ] 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 ] }

diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index cbc939b1f2c28296b077bab6330f99df3f5aa067..23b1098cd6a1c32a686cb6bc3f7534ad68f4be69 100644 (file)
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -99,7 +99,7 @@ IN: compiler.cfg.stack-analysis.tests
 ! Correct height tracking
 [ t ] [
     [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
-    reverse-post-order 3 swap nth
+    reverse-post-order 4 swap nth
     instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
     2array { D 1 D 0 } set=
 ] unit-test
@@ -126,7 +126,7 @@ IN: compiler.cfg.stack-analysis.tests
     stack-analysis
     drop
 
-    3 get instructions>> second loc>>
+    3 get successors>> first instructions>> first loc>>
 ] unit-test
 
 ! Do inserted ##peeks reference the correct stack location if
@@ -156,7 +156,7 @@ IN: compiler.cfg.stack-analysis.tests
     stack-analysis
     drop
 
-    3 get instructions>> [ ##peek? ] find nip loc>>
+    3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
 ] unit-test
 
 ! Missing ##replace
@@ -170,9 +170,9 @@ IN: compiler.cfg.stack-analysis.tests
 ! Inserted ##peeks reference the wrong stack location
 [ t ] [
     [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
-    eliminate-dead-code reverse-post-order 3 swap nth
+    eliminate-dead-code reverse-post-order 4 swap nth
     instructions>> [ ##peek? ] filter [ loc>> ] map
-    { R 0 D 0 D 1 } set=
+    { D 0 D 1 } set=
 ] unit-test
 
 [ D 0 ] [
@@ -200,5 +200,5 @@ IN: compiler.cfg.stack-analysis.tests
     stack-analysis
     drop
 
-    3 get instructions>> [ ##peek? ] find nip loc>>
+    3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
 ] 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 ab16bbea44704cbb606e900cbbee2af270522d02..48a4b797839d60ef12b959203f04fd35ec85081d 100644 (file)
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -1,7 +1,7 @@
 ! 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
+sets make combinators dlists deques
 compiler.cfg
 compiler.cfg.copy-prop
 compiler.cfg.def-use
@@ -10,9 +10,14 @@ compiler.cfg.registers
 compiler.cfg.rpo
 compiler.cfg.hats
 compiler.cfg.stack-analysis.state
-compiler.cfg.stack-analysis.merge ;
+compiler.cfg.stack-analysis.merge
+compiler.cfg.utilities ;
 IN: compiler.cfg.stack-analysis
 
+SYMBOL: work-list
+
+: add-to-work-list ( bb -- ) work-list get push-front ;
+
 : redundant-replace? ( vreg loc -- ? )
     dup state get untranslate-loc n>> 0 <
     [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
@@ -137,10 +142,21 @@ SYMBOLS: state-in state-out ;
         ] 2bi
     ] V{ } make >>instructions drop ;
 
+: visit-successors ( bb -- )
+    dup successors>> [
+        2dup back-edge? [ 2drop ] [ nip add-to-work-list ] if
+    ] with each ;
+
+: process-work-list ( -- )
+    work-list get [ visit-block ] slurp-deque ;
+
 : stack-analysis ( cfg -- cfg' )
     [
+        <hashed-dlist> work-list set
         H{ } clone copies set
         H{ } clone state-in set
         H{ } clone state-out set
-        dup [ visit-block ] each-basic-block
+        dup [ add-to-work-list ] each-basic-block
+        process-work-list
+        cfg-changed
     ] with-scope ;

diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor
index df5d96299955cae0f3482a9dfbef73fa6678c93d..5fa2e1b042285fb5307ae6a8f0e83f5d147aac41 100644 (file)
--- a/basis/compiler/cfg/tco/tco.factor
+++ b/basis/compiler/cfg/tco/tco.factor
@@ -5,7 +5,8 @@ namespaces sequences fry combinators
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.hats
-compiler.cfg.instructions ;
+compiler.cfg.instructions
+compiler.cfg.utilities ;
 IN: compiler.cfg.tco
 
 ! Tail call optimization. You must run compute-predecessors after this
@@ -82,4 +83,4 @@ M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn
 : optimize-tail-calls ( cfg -- cfg' )
     dup cfg set
     dup [ optimize-tail-call ] each-basic-block
-    f >>post-order ;
\ No newline at end of file
+    cfg-changed ;
\ No newline at end of file

diff --git a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
index 6f4a6eea557065a14a02226511745b4ae908b405..cc98d0804204dbd2d91cfb9b3763cca8a3ab80d2 100644 (file)
--- a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
+++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences math combinators combinators.short-circuit
-classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.utilities ;
 IN: compiler.cfg.useless-conditionals
 
 : delete-conditional? ( bb -- ? )
@@ -18,4 +19,4 @@ IN: compiler.cfg.useless-conditionals
     dup [
         dup delete-conditional? [ delete-conditional ] [ drop ] if
     ] each-basic-block
-    f >>post-order ;
+    cfg-changed ;

diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index 99a138a7636b6a95220a8ec18d886c0ae4690546..0e086073317aee880938496776604dec16b8c6c2 100644 (file)
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math layouts make sequences combinators
-cpu.architecture namespaces compiler.cfg
-compiler.cfg.instructions ;
+USING: accessors assocs combinators combinators.short-circuit
+compiler.cfg compiler.cfg.instructions cpu.architecture kernel
+layouts locals make math namespaces sequences sets vectors ;
 IN: compiler.cfg.utilities
 
 : value-info-small-fixnum? ( value-info -- ? )
@@ -33,7 +33,53 @@ IN: compiler.cfg.utilities
     building off
     basic-block off ;
 
-: stop-iterating ( -- next ) end-basic-block f ;
-
 : emit-primitive ( node -- )
     word>> ##call ##branch begin-basic-block ;
+
+: back-edge? ( from to -- ? )
+    [ number>> ] bi@ >= ;
+
+: empty-block? ( bb -- ? )
+    instructions>> {
+        [ length 1 = ]
+        [ first ##branch? ]
+    } 1&& ;
+
+SYMBOL: visited
+
+: (skip-empty-blocks) ( bb -- bb' )
+    dup visited get key? [
+        dup empty-block? [
+            dup visited get conjoin
+            successors>> first (skip-empty-blocks)
+        ] when
+    ] unless ;
+
+: skip-empty-blocks ( bb -- bb' )
+    H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
+
+! assoc mapping predecessors to sequences
+SYMBOL: added-instructions
+
+: add-instructions ( predecessor quot -- )
+    [
+        added-instructions get
+        [ drop V{ } clone ] cache
+        building
+    ] dip with-variable ; inline
+
+:: insert-basic-block ( from to bb -- )
+    bb from 1vector >>predecessors drop
+    bb to 1vector >>successors drop
+    to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
+    from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
+
+:: insert-basic-blocks ( bb -- )
+    added-instructions get
+    [| predecessor instructions |
+        \ ##branch new-insn instructions push
+        predecessor bb
+        <basic-block> instructions >>instructions
+        insert-basic-block
+    ] assoc-each ;
+