From e58fcd485c6f89297b7457543fe1a97043f8630b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 19 May 2009 17:28:13 -0500
Subject: [PATCH 01/46] Working on global optimizations

---
 basis/compiler/cfg/builder/builder.factor     |  43 ++--
 basis/compiler/cfg/cfg.factor                 |   2 +
 basis/compiler/cfg/copy-prop/copy-prop.factor |   2 +-
 basis/compiler/cfg/def-use/def-use.factor     |   1 +
 basis/compiler/cfg/dominance/authors.txt      |   1 +
 basis/compiler/cfg/dominance/dominance.factor |  41 +++
 .../cfg/instructions/instructions.factor      |   2 +-
 basis/compiler/cfg/stack-analysis/authors.txt |   1 +
 .../cfg/stack-analysis/stack-analysis.factor  | 238 ++++++++++++++++++
 basis/compiler/cfg/utilities/utilities.factor |   5 +-
 10 files changed, 316 insertions(+), 20 deletions(-)
 create mode 100644 basis/compiler/cfg/dominance/authors.txt
 create mode 100644 basis/compiler/cfg/dominance/dominance.factor
 create mode 100644 basis/compiler/cfg/stack-analysis/authors.txt
 create mode 100644 basis/compiler/cfg/stack-analysis/stack-analysis.factor

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 4b521725fe..b3a0287f3c 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -81,30 +81,33 @@ GENERIC: emit-node ( node -- next )
     basic-block get successors>> push
     stop-iterating ;
 
-: emit-call ( word -- next )
+: emit-call ( word height -- next )
     {
-        { [ dup loops get key? ] [ loops get at local-recursive-call ] }
+        { [ over loops get key? ] [ drop loops get at local-recursive-call ] }
         { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
-        { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
-        [ ##epilogue ##jump stop-iterating ]
+        { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
+        [ drop ##epilogue ##jump stop-iterating ]
     } cond ;
 
 ! #recursive
-: compile-recursive ( node -- next )
-    [ label>> id>> emit-call ]
+: recursive-height ( #recursive -- n )
+    [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
+
+: emit-recursive ( #recursive -- next )
+    [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
 
 : remember-loop ( label -- )
     basic-block get swap loops get set-at ;
 
-: compile-loop ( node -- next )
+: emit-loop ( node -- next )
     ##loop-entry
     begin-basic-block
     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
     iterate-next ;
 
 M: #recursive emit-node
-    dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
+    dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
 
 ! #if
 : emit-branch ( obj -- final-bb )
@@ -191,28 +194,34 @@ M: #if emit-node
     ds-pop ^^offset>slot i 0 ##dispatch
     dispatch-branches ;
 
-: <dispatch-block> ( -- word )
+! If a dispatch is not in tail position, we compile a new word where the dispatch is in
+! tail position, then call this word.
+
+: (non-tail-dispatch) ( -- word )
     gensym dup t "inlined-block" set-word-prop ;
 
+: <non-tail-dispatch> ( node -- word )
+    current-word get (non-tail-dispatch) [
+        [
+            begin-word
+            emit-dispatch
+        ] with-cfg-builder
+    ] keep ;
+
 M: #dispatch emit-node
     tail-call? [
         emit-dispatch stop-iterating
     ] [
-        current-word get <dispatch-block> [
-            [
-                begin-word
-                emit-dispatch
-            ] with-cfg-builder
-        ] keep emit-call
+       <non-tail-dispatch> f emit-call
     ] if ;
 
 ! #call
 M: #call emit-node
     dup word>> dup "intrinsic" word-prop
-    [ emit-intrinsic ] [ nip emit-call ] if ;
+    [ emit-intrinsic ] [ swap call-height emit-call ] if ;
 
 ! #call-recursive
-M: #call-recursive emit-node label>> id>> emit-call ;
+M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
 
 ! #push
 M: #push emit-node
diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 054b4f7ed0..be047f0658 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -10,6 +10,8 @@ number
 { successors vector }
 { predecessors vector } ;
 
+M: basic-block hashcode* nip id>> ;
+
 : <basic-block> ( -- basic-block )
     basic-block new
         V{ } clone >>instructions
diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor
index 52cc75f047..d526ea9c1d 100644
--- a/basis/compiler/cfg/copy-prop/copy-prop.factor
+++ b/basis/compiler/cfg/copy-prop/copy-prop.factor
@@ -6,7 +6,7 @@ IN: compiler.cfg.copy-prop
 SYMBOL: copies
 
 : resolve ( vreg -- vreg )
-    dup copies get at swap or ;
+    [ copies get at ] keep or ;
 
 : record-copy ( insn -- )
     [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 068a6a6377..6275ae2003 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -43,6 +43,7 @@ M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: insn uses-vregs drop f ;
 
+! Instructions that use vregs
 UNION: vreg-insn
 ##flushable
 ##write-barrier
diff --git a/basis/compiler/cfg/dominance/authors.txt b/basis/compiler/cfg/dominance/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/dominance/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor
new file mode 100644
index 0000000000..9d11fdf5b7
--- /dev/null
+++ b/basis/compiler/cfg/dominance/dominance.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators compiler.cfg.rpo
+compiler.cfg.stack-analysis fry kernel math.order namespaces
+sequences ;
+IN: compiler.cfg.dominance
+
+! Reference:
+
+! A Simple, Fast Dominance Algorithm
+! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
+! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
+
+SYMBOL: idoms
+
+: idom ( bb -- bb' ) idoms get at ;
+
+<PRIVATE
+
+: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
+
+: intersect ( finger1 finger2 -- bb )
+    2dup [ number>> ] compare {
+        { +lt+ [ [ idom ] dip intersect ] }
+        { +gt+ [ idom intersect ] }
+        [ 2drop ]
+    } case ;
+
+: compute-idom ( bb -- idom )
+    predecessors>> [ idom ] map sift
+    [ ] [ intersect ] map-reduce ;
+
+: iterate ( rpo -- changed? )
+    [ [ compute-idom ] keep set-idom ] map [ ] any? ;
+
+PRIVATE>
+
+: compute-dominance ( cfg -- cfg )
+    H{ } clone idoms set
+    dup entry>> reverse-post-order
+    unclip dup set-idom drop '[ _ iterate ] loop ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index d152a8cc33..359e7188b0 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -57,7 +57,7 @@ TUPLE: stack-frame
 spill-counts ;
 
 INSN: ##stack-frame stack-frame ;
-INSN: ##call word ;
+INSN: ##call word height ;
 INSN: ##jump word ;
 INSN: ##return ;
 
diff --git a/basis/compiler/cfg/stack-analysis/authors.txt b/basis/compiler/cfg/stack-analysis/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/stack-analysis/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ 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
new file mode 100644
index 0000000000..682d2ac092
--- /dev/null
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -0,0 +1,238 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel namespaces math sequences fry deques
+search-deques dlists sets make combinators compiler.cfg.copy-prop
+compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.rpo ;
+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 vregs>locs changed-locs d-height r-height poisoned? ;
+
+: <state> ( -- state )
+    state new
+        H{ } clone >>locs>vregs
+        H{ } clone >>vregs>locs
+        H{ } clone >>changed-locs
+        0 >>d-height
+        0 >>r-height ;
+
+M: state clone
+    call-next-method
+        [ clone ] change-locs>vregs
+        [ clone ] change-vregs>locs
+        [ 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* ;
+
+: changed-loc ( loc -- )
+    state get changed-locs>> conjoin ;
+
+: redundant-replace? ( src loc -- ? )
+    loc>vreg = ;
+
+: 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 ;
+
+: save-changed-locs ( state -- )
+    [ changed-locs>> ] [ locs>vregs>> ] bi '[
+        _ at swap 2dup redundant-replace?
+        [ 2drop ] [ ##replace ] if
+    ] 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 ;
+
+: sync-state ( -- )
+    ! also: update height
+    ! but first, sync outputs
+    state get {
+        [ save-changed-locs ]
+        [ d-height>> dup 0 = [ drop ] [ ##inc-d ] if ]
+        [ r-height>> dup 0 = [ drop ] [ ##inc-r ] if ]
+        [ clear-state ]
+    } cleave ;
+
+: poison-state ( -- ) state get t >>poisoned? drop ;
+
+GENERIC: translate-loc ( loc -- loc' )
+
+M: ds-loc translate-loc n>> state get d-height>> + <ds-loc> ;
+
+M: rs-loc translate-loc n>> state get r-height>> + <rs-loc> ;
+
+! Abstract interpretation
+GENERIC: visit ( insn -- )
+
+! Instructions which don't have any effect on the stack
+UNION: neutral-insn
+    ##flushable
+    ##effect
+    ##branch
+    ##loop-entry
+    ##conditional-branch ;
+
+M: neutral-insn visit , ;
+
+: adjust-d ( n -- ) state get [ + ] change-d-height drop ;
+
+M: ##inc-d visit n>> adjust-d ;
+
+: adjust-r ( n -- ) state get [ + ] change-r-height drop ;
+
+M: ##inc-r visit n>> adjust-r ;
+
+: eliminate-peek ( dst src -- )
+    ! the requested stack location is already in 'src'
+    [ ##copy ] [ swap copies get set-at ] 2bi ;
+
+M: ##peek visit
+    dup
+    [ dst>> ] [ loc>> translate-loc ] bi
+    dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
+
+M: ##replace visit
+    [ src>> resolve ] [ loc>> translate-loc ] bi
+    record-replace ;
+
+M: ##copy visit
+    [ call-next-method ] [ record-copy ] bi ;
+
+M: ##call visit
+    [ call-next-method ] [ height>> [ adjust-d ] [ poison-state ] if* ] bi ;
+
+M: ##fixnum-mul visit
+    call-next-method -1 adjust-d ;
+
+M: ##fixnum-add visit
+    call-next-method -1 adjust-d ;
+
+M: ##fixnum-sub visit
+    call-next-method -1 adjust-d ;
+
+! Instructions that poison the stack state
+UNION: poison-insn
+    ##jump
+    ##return
+    ##dispatch
+    ##dispatch-label
+    ##alien-callback
+    ##callback-return
+    ##fixnum-mul-tail
+    ##fixnum-add-tail
+    ##fixnum-sub-tail ;
+
+M: poison-insn visit call-next-method poison-state ;
+
+! Instructions that kill all live vregs
+UNION: kill-vreg-insn
+    poison-insn
+    ##stack-frame
+    ##call
+    ##prologue
+    ##epilogue
+    ##fixnum-mul
+    ##fixnum-add
+    ##fixnum-sub
+    ##alien-invoke
+    ##alien-indirect ;
+
+M: kill-vreg-insn visit sync-state , ;
+
+: visit-alien-node ( node -- )
+    params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
+
+M: ##alien-invoke visit
+    [ call-next-method ] [ visit-alien-node ] bi ;
+
+M: ##alien-indirect visit
+    [ call-next-method ] [ visit-alien-node ] bi ;
+
+! Basic blocks we still need to look at
+SYMBOL: work-list
+
+: add-to-work-list ( basic-block -- )
+    work-list get push-front ;
+
+! Maps basic-blocks to states
+SYMBOLS: state-in state-out ;
+
+: merge-states ( seq -- state )
+    [ <state> ] [ first ] if-empty ;
+
+: block-in-state ( bb -- states )
+    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-out-state ( bb state -- changed? )
+    swap state-out get maybe-set-at ;
+
+: finish-block ( bb state -- )
+    [ drop ] [ set-block-out-state ] 2bi
+    [ successors>> [ add-to-work-list ] each ] [ drop ] if ;
+
+: visit-block ( bb -- )
+    dup block-in-state
+    [ swap set-block-in-state ] [
+        state [
+            [ [ [ [ visit ] each ] V{ } make ] change-instructions drop ]
+            [ state get finish-block ]
+            bi
+        ] with-variable
+    ] 2bi ;
+
+: visit-blocks ( bb -- )
+    reverse-post-order work-list get
+    [ '[ _ push-front ] each ] [ [ visit-block ] slurp-deque ] bi ;
+
+: optimize-stack ( cfg -- cfg )
+    [
+        H{ } clone copies set
+        H{ } clone state-in set
+        H{ } clone state-out set
+        <hashed-dlist> work-list set
+        dup entry>> visit-blocks
+    ] with-scope ;
+
+! To do:
+! - implement merge-states
+! - insert loads to convert partially available values into available values
+
+! if any state is poisoned, then we need to sync in every predecessor that didn't sync
+! and begin with a new state.
+
+! if heights differ, throw an error.
+
+! changed-locs is the union of the changed-locs of all predecessors
+! locs>vregs: take the union, then for each predecessor, diff its locs>vregs against the union.
+! those are the ones that need to be loaded in.
+! think about phi insertion.
\ No newline at end of file
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index 99a138a763..e415008808 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -35,5 +35,8 @@ IN: compiler.cfg.utilities
 
 : stop-iterating ( -- next ) end-basic-block f ;
 
+: call-height ( ##call -- n )
+    [ out-d>> length ] [ in-d>> length ] bi - ;
+
 : emit-primitive ( node -- )
-    word>> ##call ##branch begin-basic-block ;
+    [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;

From 6af61656f3b6d3d35a090fed720f7aedbbc93c6a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 21 May 2009 16:49:28 -0500
Subject: [PATCH 02/46] CFG optimizer work in progress - adding phi nodes

---
 basis/compiler/cfg/def-use/def-use.factor     |   1 +
 basis/compiler/cfg/hats/hats.factor           |   2 +
 .../cfg/instructions/instructions.factor      |   2 +
 .../cfg/stack-analysis/stack-analysis.factor  | 115 +++++++++++++-----
 4 files changed, 92 insertions(+), 28 deletions(-)

diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 6275ae2003..97047a7c3e 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -39,6 +39,7 @@ M: ##dispatch uses-vregs src>> 1array ;
 M: ##alien-getter uses-vregs src>> 1array ;
 M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
 M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: ##phi uses-vregs inputs>> ;
 M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: insn uses-vregs drop f ;
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index 817c0f4680..b61f091fad 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -73,3 +73,5 @@ IN: compiler.cfg.hats
 : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
 : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
 : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
+
+: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
\ No newline at end of file
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 359e7188b0..6ebf064a94 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -178,6 +178,8 @@ INSN: ##branch ;
 
 INSN: ##loop-entry ;
 
+INSN: ##phi < ##pure inputs ;
+
 ! Condition codes
 SYMBOL: cc<
 SYMBOL: cc<=
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index 682d2ac092..cbe46d7dd4 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel namespaces math sequences fry deques
+USING: accessors assocs kernel namespaces math sequences fry deques grouping
 search-deques dlists sets make combinators compiler.cfg.copy-prop
 compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.rpo ;
+compiler.cfg.rpo compiler.cfg.hats ;
 IN: compiler.cfg.stack-analysis
 
 ! Convert stack operations to register operations
@@ -67,10 +67,11 @@ M: state clone
         [ vregs>locs>> clear-assoc ]
     } cleave ;
 
+ERROR: poisoned-state state ;
+
 : sync-state ( -- )
-    ! also: update height
-    ! but first, sync outputs
     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 ]
@@ -181,11 +182,72 @@ SYMBOL: work-list
 ! Maps basic-blocks to states
 SYMBOLS: state-in state-out ;
 
-: merge-states ( seq -- state )
-    [ <state> ] [ first ] if-empty ;
+: sync-unpoisoned-states ( predecessors states -- )
+    [
+        dup poisoned?>> [ 2drop ] [
+            state [
+                instructions>> building set
+                sync-state
+            ] with-variable
+        ] if
+    ] 2each ;
+
+ERROR: must-equal-failed seq ;
+
+: must-equal ( seq -- elt )
+    dup all-equal? [ first ] [ must-equal-failed ] if ;
+
+: merge-heights ( state predecessors states -- state )
+    nip
+    [ [ 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 ;
+
+: 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 ;
+
+: merge-locs ( state predecessors states -- state )
+    [ locs>vregs>> ] map dup [ keys ] map prune
+    [
+        [ 2nip ] [ merge-loc ] 3bi
+    ] with with H{ } map>assoc
+    >>locs>vregs ;
+
+: merge-states ( predecessors states -- state )
+    ! If any states are poisoned, save all registers
+    ! to the stack in each branch
+    [ drop <state> ] [
+        dup [ poisoned?>> ] any? [
+            sync-unpoisoned-states <state>
+        ] [
+            dup check-vreg>loc
+            [ state new ] 2dip
+            [ merge-heights ]
+            [ merge-locs ] 2bi
+            ! what about vregs>locs
+        ] if
+    ] if-empty ;
 
 : block-in-state ( bb -- states )
-    predecessors>> state-out get '[ _ at ] map merge-states ;
+    predecessors>> dup 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 ;
@@ -201,14 +263,19 @@ SYMBOLS: state-in state-out ;
     [ successors>> [ add-to-work-list ] each ] [ drop ] if ;
 
 : visit-block ( bb -- )
-    dup block-in-state
-    [ swap set-block-in-state ] [
-        state [
-            [ [ [ [ visit ] each ] V{ } make ] change-instructions drop ]
-            [ state get finish-block ]
-            bi
-        ] with-variable
-    ] 2bi ;
+    ! block-in-state may add phi nodes at the start of the basic block
+    ! so we wrap the whole thing with a 'make'
+    [
+        dup block-in-state
+        [ swap set-block-in-state ] [
+            state [
+                [ instructions>> [ visit ] each ]
+                [ state get finish-block ]
+                [ ]
+                tri
+            ] with-variable
+        ] 2bi
+    ] V{ } make >>instructions drop ;
 
 : visit-blocks ( bb -- )
     reverse-post-order work-list get
@@ -223,16 +290,8 @@ SYMBOLS: state-in state-out ;
         dup entry>> visit-blocks
     ] with-scope ;
 
-! To do:
-! - implement merge-states
-! - insert loads to convert partially available values into available values
-
-! if any state is poisoned, then we need to sync in every predecessor that didn't sync
-! and begin with a new state.
-
-! if heights differ, throw an error.
-
-! changed-locs is the union of the changed-locs of all predecessors
-! locs>vregs: take the union, then for each predecessor, diff its locs>vregs against the union.
-! those are the ones that need to be loaded in.
-! think about phi insertion.
\ No newline at end of file
+! 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

From 145f1dbeef428d1a452fcf094f2b4a9b521600b1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 23 May 2009 15:47:08 -0500
Subject: [PATCH 03/46] compiler.cfg.stack-analysis: change how inc-d/inc-r
 work

---
 basis/compiler/cfg/stack-analysis/stack-analysis.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index cbe46d7dd4..d43d97a8e0 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -101,11 +101,11 @@ M: neutral-insn visit , ;
 
 : adjust-d ( n -- ) state get [ + ] change-d-height drop ;
 
-M: ##inc-d visit n>> adjust-d ;
+M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
 
 : adjust-r ( n -- ) state get [ + ] change-r-height drop ;
 
-M: ##inc-r visit n>> adjust-r ;
+M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
 
 : eliminate-peek ( dst src -- )
     ! the requested stack location is already in 'src'

From a2b982e2478db354d46a8d6a943de3194dc4b1f6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 25 May 2009 19:16:36 -0500
Subject: [PATCH 04/46] compiler.cfg.builder: don't make basic blocks after
 terminating calls

---
 basis/compiler/cfg/builder/builder.factor   |  2 ++
 basis/compiler/cfg/iterator/iterator.factor | 10 +++++-----
 2 files changed, 7 insertions(+), 5 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index b3a0287f3c..1bf5bab067 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -84,6 +84,7 @@ GENERIC: emit-node ( node -- next )
 : emit-call ( word height -- next )
     {
         { [ over loops get key? ] [ drop loops get at local-recursive-call ] }
+        { [ terminate-call? ] [ ##call stop-iterating ] }
         { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
         { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
         [ drop ##epilogue ##jump stop-iterating ]
@@ -102,6 +103,7 @@ GENERIC: emit-node ( node -- next )
 
 : emit-loop ( node -- next )
     ##loop-entry
+    ##branch
     begin-basic-block
     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
     iterate-next ;
diff --git a/basis/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor
index 3444b517ac..c12e5bdd86 100644
--- a/basis/compiler/cfg/iterator/iterator.factor
+++ b/basis/compiler/cfg/iterator/iterator.factor
@@ -37,9 +37,9 @@ DEFER: (tail-call?)
 : tail-call? ( -- ? )
     node-stack get [
         rest-slice
-        [ t ] [
-            [ (tail-call?) ]
-            [ first #terminate? not ]
-            bi and
-        ] if-empty
+        [ t ] [ (tail-call?) ] if-empty
     ] all? ;
+
+: terminate-call? ( -- ? )
+    node-stack get peek
+    rest-slice [ f ] [ first #terminate? ] if-empty ;

From dead771b3f6167d3a78b474548ea52fe16966430 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 25 May 2009 19:16:58 -0500
Subject: [PATCH 05/46] compiler.cfg.checker: new vocabulary for checking CFG
 invariants

---
 basis/compiler/cfg/checker/authors.txt    |  1 +
 basis/compiler/cfg/checker/checker.factor | 24 +++++++++++++++++++++++
 2 files changed, 25 insertions(+)
 create mode 100644 basis/compiler/cfg/checker/authors.txt
 create mode 100644 basis/compiler/cfg/checker/checker.factor

diff --git a/basis/compiler/cfg/checker/authors.txt b/basis/compiler/cfg/checker/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/checker/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
new file mode 100644
index 0000000000..c14b7d0ae0
--- /dev/null
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -0,0 +1,24 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel compiler.cfg.instructions compiler.cfg.rpo sequences
+combinators.short-circuit accessors ;
+IN: compiler.cfg.checker
+
+ERROR: last-insn-not-a-jump insn ;
+
+: check-basic-block ( bb -- )
+    peek dup {
+        [ ##branch? ]
+        [ ##conditional-branch? ]
+        [ ##compare-imm-branch? ]
+        [ ##return? ]
+        [ ##callback-return? ]
+        [ ##jump? ]
+        [ ##call? ]
+        [ ##dispatch-label? ]
+    } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
+
+: check-cfg ( cfg -- )
+    entry>> reverse-post-order [
+        instructions>> check-basic-block
+    ] each ;
\ No newline at end of file

From a08bbde2e7e70141489a8cb686c534ddc2dd38b1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 25 May 2009 19:18:13 -0500
Subject: [PATCH 06/46] 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 )
     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 <state> ] [
-        dup [ poisoned?>> ] any? [
-            sync-unpoisoned-states <state>
-        ] [
-            dup check-vreg>loc
-            [ state new ] 2dip
-            [ merge-heights ]
-            [ merge-locs ] 2bi
-            ! what about vregs>locs
-        ] if
-    ] if-empty ;
+    dup length {
+        { 0 [ 2drop <state> ] }
+        { 1 [ nip first clone ] }
+        [
+            drop
+            dup [ not ] any? [
+                handle-back-edge <state>
+            ] [
+                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 ;
         <hashed-dlist> 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

From e0841fa695655d9dc0e4cb4c8d08f4097c2fd5ea Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 26 May 2009 02:58:40 -0500
Subject: [PATCH 07/46] compiler.cfg.checker: new check-rpo word

---
 basis/compiler/cfg/checker/checker.factor | 7 ++++---
 1 file changed, 4 insertions(+), 3 deletions(-)

diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index c14b7d0ae0..ac3d133fe6 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -18,7 +18,8 @@ ERROR: last-insn-not-a-jump insn ;
         [ ##dispatch-label? ]
     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
 
+: check-rpo ( rpo -- )
+    [ instructions>> check-basic-block ] each ;
+
 : check-cfg ( cfg -- )
-    entry>> reverse-post-order [
-        instructions>> check-basic-block
-    ] each ;
\ No newline at end of file
+    entry>> reverse-post-order check-rpo ;
\ No newline at end of file

From 8b022f926c005a33077f9087848052caf7d56b32 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 26 May 2009 02:58:57 -0500
Subject: [PATCH 08/46] compiler.cfg.dce: new global dead code elimination pass

---
 basis/compiler/cfg/dce/authors.txt |  1 +
 basis/compiler/cfg/dce/dce.factor  | 44 ++++++++++++++++++++++++++++++
 2 files changed, 45 insertions(+)
 create mode 100644 basis/compiler/cfg/dce/authors.txt
 create mode 100644 basis/compiler/cfg/dce/dce.factor

diff --git a/basis/compiler/cfg/dce/authors.txt b/basis/compiler/cfg/dce/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/dce/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor
new file mode 100644
index 0000000000..ed9b48f7c6
--- /dev/null
+++ b/basis/compiler/cfg/dce/dce.factor
@@ -0,0 +1,44 @@
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sets kernel namespaces sequences
+compiler.cfg.instructions compiler.cfg.def-use ;
+IN: compiler.cfg.dce
+
+! Maps vregs to sequences of vregs
+SYMBOL: liveness-graph
+
+! vregs which participate in side effects and thus are always live
+SYMBOL: live-vregs
+
+: init-dead-code ( -- )
+    H{ } clone liveness-graph set
+    H{ } clone live-vregs set ;
+
+GENERIC: compute-liveness ( insn -- )
+
+M: ##flushable compute-liveness
+    [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
+
+: record-live ( vregs -- )
+    [
+        dup live-vregs get key? [ drop ] [
+            [ live-vregs get conjoin ]
+            [ liveness-graph get at record-live ]
+            bi
+        ] if
+    ] each ;
+
+M: insn compute-liveness uses-vregs record-live ;
+
+GENERIC: live-insn? ( insn -- ? )
+
+M: ##flushable live-insn? dst>> live-vregs get key? ;
+
+M: insn live-insn? drop t ;
+
+: eliminate-dead-code ( rpo -- rpo )
+    init-dead-code
+    [ [ instructions>> [ compute-liveness ] each ] each ]
+    [ [ [ [ live-insn? ] filter ] change-instructions drop ] each ]
+    [ ]
+    tri ;
\ No newline at end of file

From 7ea4e255fb75293937e51cfc9280ec557c6de925 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 26 May 2009 02:59:14 -0500
Subject: [PATCH 09/46] compiler.cfg.stack-analysis: make it pass more tests

---
 .../stack-analysis-tests.factor               | 67 ++++++++++++----
 .../cfg/stack-analysis/stack-analysis.factor  | 77 ++++++++++---------
 2 files changed, 94 insertions(+), 50 deletions(-)

diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index e9dc7035b2..517516e34a 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -1,37 +1,51 @@
-USING: compiler.cfg.debugger compiler.cfg.linearization
+USING: prettyprint 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 ;
+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
 
-: linearize ( cfg -- seq )
-    build-mr instructions>> ;
+! Fundamental invariant: a basic block should not load or store a value more than once
+: check-for-redundant-ops ( rpo -- )
+    [
+        instructions>>
+        [
+            [ ##peek? ] filter [ loc>> ] map duplicates empty?
+            [ "Redundant peeks" throw ] unless
+        ] [
+            [ ##replace? ] filter [ loc>> ] map duplicates empty?
+            [ "Redundant replaces" throw ] unless
+        ] bi
+    ] each ;
 
 : test-stack-analysis ( quot -- mr )
     dup cfg? [ test-cfg first ] unless
-    compute-predecessors optimize-stack
-    dup check-cfg ;
+    compute-predecessors
+    entry>> reverse-post-order
+    optimize-stack
+    dup [ [ normalize-height ] change-instructions drop ] each
+    dup check-rpo dup check-for-redundant-ops ;
 
 [ ] [ [ ] test-stack-analysis drop ] unit-test
 
 ! Only peek once
-[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
+[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize-basic-blocks [ ##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
+[ f ] [ [ dup drop ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
+[ f ] [ [ swap swap ] test-stack-analysis linearize-basic-blocks [ ##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
+[ t ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
+[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
 
 ! Only one replace, at the end
-[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
+[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize-basic-blocks [ ##replace? ] count ] unit-test
 
 ! Do we support the full language?
 [ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
@@ -49,10 +63,10 @@ IN: compiler.cfg.stack-analysis.tests
 [ ] [ [ [ 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
+[ f ] [ [ [ ] dip ] test-stack-analysis linearize-basic-blocks [ ##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
+[ 1 ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##inc-d? ] count ] unit-test
 
 ! Bug in height tracking
 [ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
@@ -63,4 +77,27 @@ IN: compiler.cfg.stack-analysis.tests
 [ ] [ [ [ "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
+[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test
+
+! Make sure the replace stores a value with the right height
+[ ] [
+    [ [ . ] [ 2drop 1 ] if ] test-stack-analysis 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
+    [ [ ##load-immediate? ] count 2 assert= ]
+    [ [ ##peek? ] count 1 assert= ]
+    [ [ ##replace? ] count 3 assert= ]
+    tri
+] unit-test
+
+[ ] [
+    [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize-basic-blocks
+    [ [ ##load-immediate? ] count 2 assert= ]
+    [ [ ##peek? ] count 1 assert= ]
+    [ [ ##replace? ] count 1 assert= ]
+    tri
+] 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 f1b424e622..0650623ecc 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel namespaces math sequences fry deques grouping
-search-deques dlists sets make combinators compiler.cfg.copy-prop
-compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.rpo compiler.cfg.hats ;
+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 ;
 IN: compiler.cfg.stack-analysis
 
 ! Convert stack operations to register operations
@@ -34,19 +34,34 @@ M: state clone
 : changed-loc ( loc -- )
     state get changed-locs>> conjoin ;
 
-: changed-loc? ( loc -- ? )
-    state get changed-locs>> key? ;
-
 : 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 d-height>> ;
+M: rs-loc height-for drop state get r-height>> ;
+
+: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
+
+GENERIC: translate-loc ( loc -- loc' )
+
+M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
+M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
+
+GENERIC: untranslate-loc ( loc -- loc' )
+
+M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
+M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
+
 : redundant-replace? ( vreg loc -- ? )
-    state get actual-locs>vregs>> at = ;
+    dup untranslate-loc n>> 0 <
+    [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
 
 : save-changed-locs ( state -- )
     [ changed-locs>> ] [ locs>vregs>> ] bi '[
         _ at swap 2dup redundant-replace?
-        [ 2drop ] [ ##replace ] if
+        [ 2drop ] [ untranslate-loc ##replace ] if
     ] assoc-each ;
 
 : clear-state ( state -- )
@@ -66,12 +81,6 @@ ERROR: poisoned-state state ;
 
 : poison-state ( -- ) state get t >>poisoned? drop ;
 
-GENERIC: translate-loc ( loc -- loc' )
-
-M: ds-loc translate-loc n>> state get d-height>> + <ds-loc> ;
-
-M: rs-loc translate-loc n>> state get r-height>> + <rs-loc> ;
-
 ! Abstract interpretation
 GENERIC: visit ( insn -- )
 
@@ -162,12 +171,6 @@ M: ##alien-callback visit , ;
 
 M: ##dispatch-label visit , ;
 
-! Basic blocks we still need to look at
-SYMBOL: work-list
-
-: add-to-work-list ( basic-block -- )
-    work-list get push-front ;
-
 ! Maps basic-blocks to states
 SYMBOLS: state-in state-out ;
 
@@ -222,8 +225,20 @@ SYMBOL: phi-nodes
 : 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 )
-    [ actual-locs>vregs>> ] map (merge-locs) >>actual-locs>vregs ;
+    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 ;
@@ -266,12 +281,8 @@ ERROR: cannot-merge-poisoned states ;
 : set-block-in-state ( state bb -- )
     [ clone ] dip state-in get set-at ;
 
-: set-block-out-state ( state bb -- changed? )
-    [ clone ] dip state-out get maybe-set-at ;
-
-: finish-block ( bb state -- )
-    [ drop ] [ swap set-block-out-state ] 2bi
-    [ successors>> [ add-to-work-list ] each ] [ drop ] if ;
+: set-block-out-state ( state bb -- )
+    [ clone ] dip state-out get set-at ;
 
 : visit-block ( bb -- )
     ! block-in-state may add phi nodes at the start of the basic block
@@ -281,21 +292,17 @@ ERROR: cannot-merge-poisoned states ;
         [ swap set-block-in-state ] [
             [
                 [ instructions>> [ visit ] each ]
-                [ state get finish-block ]
+                [ [ state get ] dip set-block-out-state ]
                 [ ]
                 tri
             ] with-state
         ] 2bi
     ] V{ } make >>instructions drop ;
 
-: visit-blocks ( bb -- )
-    reverse-post-order [ visit-block ] each ;
-
-: optimize-stack ( cfg -- cfg )
+: optimize-stack ( rpo -- rpo )
     [
         H{ } clone copies set
         H{ } clone state-in set
         H{ } clone state-out set
-        <hashed-dlist> work-list set
-        dup entry>> visit-blocks
+        dup [ visit-block ] each
     ] with-scope ;

From ccb662c60e7f6d3c07be22aac2d900870988b79c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 26 May 2009 03:42:39 -0500
Subject: [PATCH 10/46] Fix another bug in stack-analysis

---
 .../stack-analysis-tests.factor               |  6 +++++
 .../cfg/stack-analysis/stack-analysis.factor  | 22 +++++++++++--------
 2 files changed, 19 insertions(+), 9 deletions(-)

diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index 517516e34a..c89a8b1cfd 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -100,4 +100,10 @@ IN: compiler.cfg.stack-analysis.tests
     [ [ ##peek? ] count 1 assert= ]
     [ [ ##replace? ] count 1 assert= ]
     tri
+] unit-test
+
+! Sync before a back-edge, not after
+[ 1 ] [
+    [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize-basic-blocks
+    [ ##add-imm? ] count
 ] 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 0650623ecc..419c43c47e 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -3,7 +3,7 @@
 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.hats compiler.cfg ;
 IN: compiler.cfg.stack-analysis
 
 ! Convert stack operations to register operations
@@ -95,6 +95,16 @@ UNION: neutral-insn
 
 M: neutral-insn visit , ;
 
+UNION: sync-if-back-edge
+    ##branch
+    ##conditional-branch
+    ##compare-imm-branch ;
+
+M: sync-if-back-edge visit
+    basic-block get [ successors>> ] [ number>> ] bi '[ number>> _ < ] any?
+    [ sync-state ] when
+    , ;
+
 : adjust-d ( n -- ) state get [ + ] change-d-height drop ;
 
 M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
@@ -181,13 +191,6 @@ SYMBOLS: state-in state-out ;
 : 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 ;
 
 : must-equal ( seq -- elt )
@@ -254,7 +257,7 @@ ERROR: cannot-merge-poisoned states ;
         [
             drop
             dup [ not ] any? [
-                handle-back-edge <state>
+                2drop <state>
             ] [
                 dup [ poisoned?>> ] any? [
                     cannot-merge-poisoned
@@ -288,6 +291,7 @@ ERROR: cannot-merge-poisoned states ;
     ! block-in-state may add phi nodes at the start of the basic block
     ! so we wrap the whole thing with a 'make'
     [
+        dup basic-block set
         dup block-in-state
         [ swap set-block-in-state ] [
             [

From eda44f28a67f5fc2646cf74b78b94af224defcd9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 26 May 2009 18:45:37 -0500
Subject: [PATCH 11/46] Move maybe-set-at to assocs

---
 basis/compiler/cfg/stack-analysis/stack-analysis.factor | 3 ---
 core/assocs/assocs-tests.factor                         | 4 ++++
 core/assocs/assocs.factor                               | 3 +++
 3 files changed, 7 insertions(+), 3 deletions(-)

diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index 419c43c47e..bce3064a9e 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -278,9 +278,6 @@ ERROR: cannot-merge-poisoned states ;
 : block-in-state ( bb -- 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 bb -- )
     [ clone ] dip state-in get set-at ;
 
diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index fc74df6d45..c21cac2632 100644
--- a/core/assocs/assocs-tests.factor
+++ b/core/assocs/assocs-tests.factor
@@ -142,3 +142,7 @@ unit-test
 
 [ 1 f ] [ 1 H{ } ?at ] unit-test
 [ 2 t ] [ 1 H{ { 1 2 } } ?at ] unit-test
+
+[ 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
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index e783ef81c4..7fc3eae00c 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -22,6 +22,9 @@ M: assoc assoc-like drop ;
 : ?at ( key assoc -- value/key ? )
     2dup at* [ 2nip t ] [ 2drop f ] if ; inline
 
+: maybe-set-at ( value key assoc -- changed? )
+    3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
+
 <PRIVATE
 
 : (assoc-each) ( assoc quot -- seq quot' )

From 1db81da2644a36b80b96f294388becc1273fb43c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 26 May 2009 19:31:19 -0500
Subject: [PATCH 12/46] Refactoring low-level optimizer to support stack
 analysis pass

---
 .../alias-analysis-tests.factor               | 55 -------------------
 .../cfg/alias-analysis/alias-analysis.factor  | 50 ++++++-----------
 basis/compiler/cfg/checker/checker.factor     |  2 +-
 basis/compiler/cfg/dce/dce.factor             | 13 ++---
 basis/compiler/cfg/dominance/dominance.factor |  2 +-
 basis/compiler/cfg/height/height.factor       | 20 ++++---
 .../cfg/instructions/instructions.factor      |  4 +-
 .../cfg/linearization/linearization.factor    |  2 +-
 basis/compiler/cfg/liveness/authors.txt       |  1 +
 basis/compiler/cfg/liveness/liveness.factor   | 55 +++++++++++++++++++
 basis/compiler/cfg/optimizer/optimizer.factor | 43 ++++++++-------
 .../cfg/predecessors/predecessors.factor      |  8 +--
 basis/compiler/cfg/rpo/rpo.factor             | 19 +++----
 .../stack-analysis-tests.factor               | 23 ++++----
 .../cfg/stack-analysis/stack-analysis.factor  | 22 ++++----
 .../cfg/useless-blocks/useless-blocks.factor  | 12 ++--
 .../expressions/expressions.factor            | 12 ++--
 .../value-numbering-tests.factor              | 24 ++++----
 .../value-numbering/value-numbering.factor    | 12 +++-
 .../write-barrier/write-barrier-tests.factor  | 12 ++--
 .../cfg/write-barrier/write-barrier.factor    |  9 ++-
 21 files changed, 203 insertions(+), 197 deletions(-)
 create mode 100644 basis/compiler/cfg/liveness/authors.txt
 create mode 100644 basis/compiler/cfg/liveness/liveness.factor

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
index 81359690db..79165f2c96 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
+++ b/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
diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index ec8fe62dfb..3a153740d5 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/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 and stack
-! traffic using some simple heuristics.
+! We try to eliminate redundant slot operations 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
 
+    live-in keys [ set-heap-ac ] each
+    
     0 ac-counter set
-    next-ac heap-ac set
-
-    ds-loc next-ac set-ac
-    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' )
-    init-alias-analysis
-    analyze-aliases
-    compute-live-stores
-    eliminate-dead-stores ;
+: alias-analysis-step ( basic-block -- )
+    dup init-alias-analysis
+    [
+        analyze-aliases
+        compute-live-stores
+        eliminate-dead-stores
+    ] change-instructions drop ;
+
+: alias-analysis ( rpo -- )
+    [ alias-analysis-step ] each ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index ac3d133fe6..3a9d4a2b90 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/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 ;
\ No newline at end of file
+    reverse-post-order check-rpo ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor
index ed9b48f7c6..5db760e861 100644
--- a/basis/compiler/cfg/dce/dce.factor
+++ b/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 ]
-    [ ]
-    tri ;
\ No newline at end of file
+    bi ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor
index 9d11fdf5b7..750a46ee6c 100644
--- a/basis/compiler/cfg/dominance/dominance.factor
+++ b/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 ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
index 9312f6f133..9c305442e5 100644
--- a/basis/compiler/cfg/height/height.factor
+++ b/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 ;
+    [
+        [ [ 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
+    ] change-instructions drop ;
+
+: normalize-height ( rpo -- )
+    [ height-step ] each ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 6ebf064a94..650bcb5795 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/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: ##replace < ##write { loc loc } ;
+INSN: ##peek < ##flushable { loc loc } ;
+INSN: ##replace < ##effect { loc loc } ;
 INSN: ##inc-d { n integer } ;
 INSN: ##inc-r { n integer } ;
 
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 8ef3abda39..9d80a2b28e 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/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> ;
diff --git a/basis/compiler/cfg/liveness/authors.txt b/basis/compiler/cfg/liveness/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/liveness/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor
new file mode 100644
index 0000000000..66a584c613
--- /dev/null
+++ b/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 ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 7887faeb61..41cd3c4b90 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/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
-compiler.cfg.instructions
+USING: kernel sequences accessors combinators
 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.write-barrier ;
+compiler.cfg.dce
+compiler.cfg.write-barrier
+compiler.cfg.liveness
+compiler.cfg.rpo ;
 IN: compiler.cfg.optimizer
 
-: trivial? ( insns -- ? )
-    dup length 2 = [ first ##call? ] [ drop f ] if ;
-
-: optimize-cfg ( cfg -- cfg' )
-    compute-predecessors
-    delete-useless-blocks
-    delete-useless-conditionals
+: optimize-cfg ( cfg -- cfg )
     [
-        dup trivial? [
-            normalize-height
-            alias-analysis
-            value-numbering
-            eliminate-dead-code
-            eliminate-write-barriers
-        ] unless
-    ] change-basic-blocks ;
+        [ compute-predecessors ]
+        [ delete-useless-blocks ]
+        [ delete-useless-conditionals ] tri
+    ] [
+        reverse-post-order
+        {
+            [ compute-liveness ]
+            [ normalize-height ]
+            [ stack-analysis ]
+            [ alias-analysis ]
+            [ value-numbering ]
+            [ eliminate-dead-code ]
+            [ eliminate-write-barriers ]
+        } cleave
+    ] [ ] tri ;
diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor
index 01a2a771bc..9bc3a08f63 100644
--- a/basis/compiler/cfg/predecessors/predecessors.factor
+++ b/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' )
-    dup [ (compute-predecessors) ] each-basic-block ;
+: compute-predecessors ( cfg -- )
+    [ predecessors-step ] each-basic-block ;
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index bb4153da78..766373175c 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/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 id>> visited get conjoin
+    dup visited get key? [ drop ] [
+        dup visited get conjoin
         [
             successors>> <reversed>
             [ post-order-traversal ] each
         ] [ , ] bi
     ] if ;
 
-: post-order ( bb -- blocks )
-    [ post-order-traversal ] { } make ;
+: post-order ( cfg -- blocks )
+    [ 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
-
-: change-basic-blocks ( cfg quot -- cfg' )
-    [ '[ _ change-instructions drop ] each-basic-block ]
-    [ drop ]
-    2bi ; inline
+    [ reverse-post-order ] dip each ; inline
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index c89a8b1cfd..8c941f4539 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/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
-    entry>> reverse-post-order
-    optimize-stack
-    dup [ [ normalize-height ] change-instructions drop ] each
-    dup check-rpo dup check-for-redundant-ops ;
+    dup compute-predecessors
+    reverse-post-order
+    dup stack-analysis
+    dup normalize-height
+    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
\ 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 bce3064a9e..6d602ede76 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/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 >>r-height ;
+        0 >>ds-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: rs-loc height-for drop state get r-height>> ;
+M: ds-loc height-for drop state get ds-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 ]
-    [ [ r-height>> ] map must-equal >>r-height ] bi ;
+    [ [ ds-height>> ] map must-equal >>ds-height ]
+    [ [ 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 ;
diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor
index f543aa4036..b4999a8074 100644
--- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor
+++ b/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' )
-    dup [
+: delete-useless-blocks ( cfg -- )
+    [
         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' )
-    dup [
+: delete-useless-conditionals ( cfg -- )
+    [
         dup delete-conditional? [ delete-conditional ] [ drop ] if
     ] each-basic-block ;
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index cc790c6c0a..bf750231c7 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/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 ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index abd2720817..11c0819027 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/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
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index d17b2a7e1f..ac0c512bf8 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/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 ;
diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
index 73748dbc37..fb755399dc 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
+++ b/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
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index 4a55cb3266..5a08296617 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/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 ;

From ce25e0ad8db18bb68580e7b8d5ae6c175f4e93e6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 26 May 2009 19:56:56 -0500
Subject: [PATCH 13/46] New local-optimization combinator removes some
 boilerplate

---
 .../cfg/alias-analysis/alias-analysis.factor    | 17 +++++++----------
 basis/compiler/cfg/height/height.factor         | 12 +++++-------
 basis/compiler/cfg/liveness/liveness.factor     |  4 ++--
 basis/compiler/cfg/rpo/rpo.factor               |  9 ++++++++-
 .../cfg/value-numbering/value-numbering.factor  | 16 +++++++++-------
 .../cfg/write-barrier/write-barrier.factor      |  9 +++++----
 6 files changed, 36 insertions(+), 31 deletions(-)

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 3a153740d5..8e1034fb0d 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -196,7 +196,7 @@ 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 ( basic-block -- )
+: init-alias-analysis ( live-in -- )
     H{ } clone histories set
     H{ } clone vregs>acs set
     H{ } clone acs>vregs set
@@ -204,7 +204,7 @@ M: ##alien-global insn-object drop \ ##alien-global ;
     H{ } clone constants set
     H{ } clone copies set
 
-    live-in keys [ set-heap-ac ] each
+    [ set-heap-ac ] each
     
     0 ac-counter set
     next-ac heap-ac set ;
@@ -291,13 +291,10 @@ M: insn eliminate-dead-stores* ;
 : eliminate-dead-stores ( insns -- insns' )
     [ insn# set eliminate-dead-stores* ] map-index sift ;
 
-: alias-analysis-step ( basic-block -- )
-    dup init-alias-analysis
-    [
-        analyze-aliases
-        compute-live-stores
-        eliminate-dead-stores
-    ] change-instructions drop ;
+: alias-analysis-step ( insns -- insns' )
+    analyze-aliases
+    compute-live-stores
+    eliminate-dead-stores ;
 
 : alias-analysis ( rpo -- )
-    [ alias-analysis-step ] each ;
\ No newline at end of file
+    [ init-alias-analysis ] [ alias-analysis-step ] local-optimization ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
index 9c305442e5..336a8a33c2 100644
--- a/basis/compiler/cfg/height/height.factor
+++ b/basis/compiler/cfg/height/height.factor
@@ -46,12 +46,10 @@ M: insn normalize-height* ;
 : 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
-    ] change-instructions drop ;
+    [ [ 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 ;
 
 : normalize-height ( rpo -- )
-    [ height-step ] each ;
+    [ ] [ height-step ] local-optimization ;
diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor
index 66a584c613..7cc6158e68 100644
--- a/basis/compiler/cfg/liveness/liveness.factor
+++ b/basis/compiler/cfg/liveness/liveness.factor
@@ -1,7 +1,7 @@
 ! 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 ;
+USING: kernel namespaces deques accessors sets sequences assocs fry
+dlists compiler.cfg.def-use ;
 IN: compiler.cfg.liveness
 
 ! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index 766373175c..32ca87de97 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/basis/compiler/cfg/rpo/rpo.factor
@@ -1,7 +1,8 @@
 ! 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 ;
+assocs fry compiler.cfg compiler.cfg.instructions
+compiler.cfg.liveness ;
 IN: compiler.cfg.rpo
 
 SYMBOL: visited
@@ -28,3 +29,9 @@ SYMBOL: visited
 
 : each-basic-block ( cfg quot -- )
     [ reverse-post-order ] dip each ; inline
+
+: optimize-basic-block ( bb init-quot insn-quot -- )
+    [ '[ live-in keys _ each ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
+
+: local-optimization ( rpo init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- )
+    '[ _ _ optimize-basic-block ] each ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index ac0c512bf8..b22c8b4388 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -2,7 +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.rpo
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.propagate
@@ -10,14 +10,16 @@ compiler.cfg.value-numbering.simplify
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering
 
-: number-input-values ( basic-block -- )
-    live-in keys [ [ next-input-expr ] dip set-vn ] each ;
+: number-input-values ( live-in -- )
+    [ [ f next-input-expr ] dip set-vn ] each ;
 
-: value-numbering-step ( basic-block -- )
+: init-value-numbering ( live-in -- )
     init-value-graph
     init-expressions
-    dup number-input-values
-    [ [ [ number-values ] [ rewrite propagate ] bi ] map ] change-instructions drop ;
+    number-input-values ;
+
+: value-numbering-step ( insns -- insns' )
+    [ [ number-values ] [ rewrite propagate ] bi ] map ;
 
 : value-numbering ( rpo -- )
-    [ value-numbering-step ] each ;
+    [ init-value-numbering ] [ value-numbering-step ] local-optimization ;
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index 5a08296617..b952c062e7 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -1,7 +1,8 @@
 ! 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 ;
+compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
+compiler.cfg.rpo ;
 IN: compiler.cfg.write-barrier
 
 ! Eliminate redundant write barrier hits.
@@ -35,11 +36,11 @@ M: ##set-slot-imm eliminate-write-barrier
 
 M: insn eliminate-write-barrier ;
 
-: write-barriers-step ( basic-block -- )
+: write-barriers-step ( insns -- insns' )
     H{ } clone safe set
     H{ } clone mutated set
     H{ } clone copies set
-    [ [ eliminate-write-barrier ] map sift ] change-instructions drop ;
+    [ eliminate-write-barrier ] map sift ;
 
 : eliminate-write-barriers ( rpo -- )
-    [ write-barriers-step ] each ;
+    [ ] [ write-barriers-step ] local-optimization ;

From 2025823ba6262058faef7993ab57b4bfc607844f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 27 May 2009 17:55:15 -0500
Subject: [PATCH 14/46] Remove old local DCE pass

---
 .../cfg/dead-code/dead-code-tests.factor      |  9 ---
 basis/compiler/cfg/dead-code/dead-code.factor | 61 -------------------
 basis/compiler/cfg/dead-code/summary.txt      |  1 -
 3 files changed, 71 deletions(-)
 delete mode 100644 basis/compiler/cfg/dead-code/dead-code-tests.factor
 delete mode 100644 basis/compiler/cfg/dead-code/dead-code.factor
 delete mode 100644 basis/compiler/cfg/dead-code/summary.txt

diff --git a/basis/compiler/cfg/dead-code/dead-code-tests.factor b/basis/compiler/cfg/dead-code/dead-code-tests.factor
deleted file mode 100644
index ee7d8d2a43..0000000000
--- a/basis/compiler/cfg/dead-code/dead-code-tests.factor
+++ /dev/null
@@ -1,9 +0,0 @@
-USING: compiler.cfg.dead-code compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.debugger
-cpu.architecture tools.test ;
-IN: compiler.cfg.dead-code.tests
-
-[ { } ] [
-    { T{ ##load-immediate f V int-regs 134 16 } }
-    eliminate-dead-code
-] unit-test
diff --git a/basis/compiler/cfg/dead-code/dead-code.factor b/basis/compiler/cfg/dead-code/dead-code.factor
deleted file mode 100644
index 73aa7b4a5a..0000000000
--- a/basis/compiler/cfg/dead-code/dead-code.factor
+++ /dev/null
@@ -1,61 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sets kernel namespaces sequences
-compiler.cfg.instructions compiler.cfg.def-use ;
-IN: compiler.cfg.dead-code
-
-! Dead code elimination -- assumes compiler.cfg.alias-analysis
-! has already run.
-
-! Maps vregs to sequences of vregs
-SYMBOL: liveness-graph
-
-! vregs which participate in side effects and thus are always live
-SYMBOL: live-vregs
-
-! mapping vregs to stack locations
-SYMBOL: vregs>locs
-
-: init-dead-code ( -- )
-    H{ } clone liveness-graph set
-    H{ } clone live-vregs set
-    H{ } clone vregs>locs set ;
-
-GENERIC: compute-liveness ( insn -- )
-
-M: ##flushable compute-liveness
-    [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
-
-M: ##peek compute-liveness
-    [ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ]
-    [ call-next-method ]
-    bi ;
-
-: live-replace? ( ##replace -- ? )
-    [ src>> vregs>locs get at ] [ loc>> ] bi = not ;
-
-M: ##replace compute-liveness
-    dup live-replace? [ call-next-method ] [ drop ] if ;
-
-: record-live ( vregs -- )
-    [
-        dup live-vregs get key? [ drop ] [
-            [ live-vregs get conjoin ]
-            [ liveness-graph get at record-live ]
-            bi
-        ] if
-    ] each ;
-
-M: insn compute-liveness uses-vregs record-live ;
-
-GENERIC: live-insn? ( insn -- ? )
-
-M: ##flushable live-insn? dst>> live-vregs get key? ;
-
-M: ##replace live-insn? live-replace? ;
-
-M: insn live-insn? drop t ;
-
-: eliminate-dead-code ( insns -- insns' )
-    init-dead-code
-    [ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ;
diff --git a/basis/compiler/cfg/dead-code/summary.txt b/basis/compiler/cfg/dead-code/summary.txt
deleted file mode 100644
index c66cd99606..0000000000
--- a/basis/compiler/cfg/dead-code/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Dead-code elimination

From 3b79d614964e59d4c03019172aa031e5224b7d16 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 27 May 2009 18:55:49 -0500
Subject: [PATCH 15/46] Add a new ##allocation union to remove some code
 duplication

---
 .../cfg/alias-analysis/alias-analysis.factor  | 12 +---------
 .../cfg/instructions/instructions.factor      |  5 ++++-
 .../cfg/linearization/linearization.factor    | 22 +++++++++----------
 3 files changed, 15 insertions(+), 24 deletions(-)

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 8e1034fb0d..6b1e0c47b6 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -220,17 +220,7 @@ M: ##load-reference analyze-aliases*
 M: ##alien-global analyze-aliases*
     dup dst>> set-heap-ac ;
 
-M: ##allot analyze-aliases*
-    #! A freshly allocated object is distinct from any other
-    #! object.
-    dup dst>> set-new-ac ;
-
-M: ##box-float analyze-aliases*
-    #! A freshly allocated object is distinct from any other
-    #! object.
-    dup dst>> set-new-ac ;
-
-M: ##box-alien analyze-aliases*
+M: ##allocation analyze-aliases*
     #! A freshly allocated object is distinct from any other
     #! object.
     dup dst>> set-new-ac ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 650bcb5795..747233dbba 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -160,6 +160,9 @@ INSN: ##set-alien-double < ##alien-setter ;
 
 ! Memory allocation
 INSN: ##allot < ##flushable size class { temp vreg } ;
+
+UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
+
 INSN: ##write-barrier < ##effect card# table ;
 
 INSN: ##alien-global < ##read symbol library ;
@@ -225,7 +228,7 @@ INSN: _epilogue stack-frame ;
 
 INSN: _label id ;
 
-INSN: _gc ;
+INSN: _gc live-in ;
 
 INSN: _branch label ;
 
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 9d80a2b28e..64507779a4 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -1,9 +1,11 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math accessors sequences namespaces make
-combinators classes
+combinators assocs
+cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
+compiler.cfg.liveness
 compiler.cfg.instructions ;
 IN: compiler.cfg.linearization
 
@@ -18,7 +20,7 @@ M: insn linearize-insn , drop ;
 : useless-branch? ( basic-block successor -- ? )
     #! If our successor immediately follows us in RPO, then we
     #! don't need to branch.
-    [ number>> ] bi@ 1- = ; inline
+    [ number>> ] bi@ 1 - = ; inline
 
 : branch-to-branch? ( successor -- ? )
     #! A branch to a block containing just a jump return is cloned.
@@ -56,18 +58,14 @@ M: ##compare-float-branch linearize-insn
     binary-conditional _compare-float-branch emit-branch ;
 
 : gc? ( bb -- ? )
-    instructions>> [
-        class {
-            ##allot
-            ##integer>bignum
-            ##box-float
-            ##box-alien
-        } memq?
-    ] any? ;
+    instructions>> [ ##allocation? ] any? ;
+
+: object-pointer-regs ( basic-block -- vregs )
+    live-in keys [ reg-class>> int-regs eq? ] filter ;
 
 : linearize-basic-block ( bb -- )
     [ number>> _label ]
-    [ gc? [ _gc ] when ]
+    [ dup gc? [ object-pointer-regs _gc ] [ drop ] if ]
     [ linearize-insns ]
     tri ;
 

From dadb9a2c5031da6abf792f50d0c416ad1b078b93 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 27 May 2009 18:58:01 -0500
Subject: [PATCH 16/46] Add phi elimination pass

---
 basis/compiler/cfg/cfg.factor                 | 14 +++++--
 .../cfg/optimizer/optimizer-tests.factor      |  8 ++++
 basis/compiler/cfg/optimizer/optimizer.factor | 38 ++++++++++---------
 .../compiler/cfg/phi-elimination/authors.txt  |  1 +
 .../phi-elimination/phi-elimination.factor    | 21 ++++++++++
 .../stack-analysis-tests.factor               |  3 +-
 .../cfg/stack-analysis/stack-analysis.factor  | 18 ++-------
 7 files changed, 67 insertions(+), 36 deletions(-)
 create mode 100644 basis/compiler/cfg/optimizer/optimizer-tests.factor
 create mode 100644 basis/compiler/cfg/phi-elimination/authors.txt
 create mode 100644 basis/compiler/cfg/phi-elimination/phi-elimination.factor

diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index be047f0658..265cbb8f00 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -1,6 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays vectors accessors namespaces ;
+USING: kernel arrays vectors accessors
+namespaces make fry sequences ;
 IN: compiler.cfg
 
 TUPLE: basic-block < identity-tuple
@@ -12,13 +13,20 @@ number
 
 M: basic-block hashcode* nip id>> ;
 
-: <basic-block> ( -- basic-block )
+: <basic-block> ( -- bb )
     basic-block new
         V{ } clone >>instructions
         V{ } clone >>successors
         V{ } clone >>predecessors
         \ basic-block counter >>id ;
 
+: add-instructions ( bb quot -- )
+    [ instructions>> building ] dip '[
+        building get pop
+        _ dip
+        building get push
+    ] with-variable ; inline
+
 TUPLE: cfg { entry basic-block } word label ;
 
 C: <cfg> cfg
diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
new file mode 100644
index 0000000000..5cc01173ad
--- /dev/null
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -0,0 +1,8 @@
+USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
+compiler.cfg.def-use sets kernel ;
+IN: compiler.cfg.optimizer.tests
+
+! Miscellaneous tests
+
+[ ] [ [ 1array ] test-mr first check-mr ] unit-test
+[ ] [ [ 1 2 ? ] test-mr first check-mr ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 41cd3c4b90..f59e9e0b83 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors combinators
+USING: kernel sequences accessors combinators namespaces
 compiler.cfg.predecessors
 compiler.cfg.useless-blocks
 compiler.cfg.height
@@ -10,23 +10,27 @@ compiler.cfg.value-numbering
 compiler.cfg.dce
 compiler.cfg.write-barrier
 compiler.cfg.liveness
-compiler.cfg.rpo ;
+compiler.cfg.rpo
+compiler.cfg.phi-elimination ;
 IN: compiler.cfg.optimizer
 
 : optimize-cfg ( cfg -- cfg )
     [
-        [ compute-predecessors ]
-        [ delete-useless-blocks ]
-        [ delete-useless-conditionals ] tri
-    ] [
-        reverse-post-order
-        {
-            [ compute-liveness ]
-            [ normalize-height ]
-            [ stack-analysis ]
-            [ alias-analysis ]
-            [ value-numbering ]
-            [ eliminate-dead-code ]
-            [ eliminate-write-barriers ]
-        } cleave
-    ] [ ] tri ;
+        [
+            [ compute-predecessors ]
+            [ delete-useless-blocks ]
+            [ delete-useless-conditionals ] tri
+        ] [
+            reverse-post-order
+            {
+                [ normalize-height ]
+                [ stack-analysis ]
+                [ compute-liveness ]
+                [ alias-analysis ]
+                [ value-numbering ]
+                [ eliminate-dead-code ]
+                [ eliminate-write-barriers ]
+                [ eliminate-phis ]
+            } cleave
+        ] [ ] tri
+    ] with-scope ;
diff --git a/basis/compiler/cfg/phi-elimination/authors.txt b/basis/compiler/cfg/phi-elimination/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/phi-elimination/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ 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
new file mode 100644
index 0000000000..d94e57f378
--- /dev/null
+++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor
@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors compiler.cfg compiler.cfg.instructions fry
+kernel sequences ;
+IN: compiler.cfg.phi-elimination
+
+: insert-copy ( predecessor input output -- )
+    '[ _ _ swap ##copy ] add-instructions ;
+
+: eliminate-phi ( bb ##phi -- )
+    [ predecessors>> ] [ [ inputs>> ] [ dst>> ] bi ] bi*
+    '[ _ insert-copy ] 2each ;
+
+: eliminate-phi-step ( bb -- )
+    dup [
+        [ ##phi? ] partition
+        [ [ eliminate-phi ] with each ] dip
+    ] change-instructions drop ;
+
+: eliminate-phis ( rpo -- )
+    [ eliminate-phi-step ] each ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index 8c941f4539..d43900018e 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -100,7 +100,8 @@ IN: compiler.cfg.stack-analysis.tests
 ] unit-test
 
 ! Sync before a back-edge, not after
+! ##peeks should be inserted before a ##loop-entry
 [ 1 ] [
     [ 1000 [ ] times ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
     [ ##add-imm? ] count
-] unit-test
\ No newline at end of file
+] unit-test
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index 6d602ede76..0aa402ed66 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -184,10 +184,6 @@ M: ##dispatch-label visit , ;
 ! Maps basic-blocks to states
 SYMBOLS: state-in state-out ;
 
-: 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
 
@@ -203,22 +199,14 @@ ERROR: must-equal-failed seq ;
 
 : insert-peek ( predecessor loc -- vreg )
     ! XXX critical edges
-    '[ _ ^^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 ;
+    '[ _ ^^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 ] [ insert-phi ] if ;
+    dup all-equal? [ first ] [ ^^phi ] if ;
 
 : (merge-locs) ( predecessors assocs -- assoc )
     dup [ keys ] map concat prune
@@ -263,7 +251,7 @@ ERROR: cannot-merge-poisoned states ;
                     cannot-merge-poisoned
                 ] [
                     [ state new ] 2dip
-                    [ [ instructions>> find-phis phi-nodes set ] [ predecessors>> ] bi ] dip
+                    [ predecessors>> ] dip
                     {
                         [ merge-locs ]
                         [ merge-actual-locs ]

From f3688c93738d5e7c8d430a9f184ab9276cdf4af5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 27 May 2009 18:58:14 -0500
Subject: [PATCH 17/46] Better CFG checker

---
 basis/compiler/cfg/checker/checker.factor | 29 +++++++++++++++++++----
 1 file changed, 25 insertions(+), 4 deletions(-)

diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index 3a9d4a2b90..53f0557db5 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -1,12 +1,13 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.instructions compiler.cfg.rpo sequences
-combinators.short-circuit accessors ;
+USING: kernel compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use
+compiler.cfg.linearization combinators.short-circuit accessors math
+sequences sets ;
 IN: compiler.cfg.checker
 
 ERROR: last-insn-not-a-jump insn ;
 
-: check-basic-block ( bb -- )
+: check-last-instruction ( bb -- )
     peek dup {
         [ ##branch? ]
         [ ##conditional-branch? ]
@@ -18,8 +19,28 @@ ERROR: last-insn-not-a-jump insn ;
         [ ##dispatch-label? ]
     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
 
+ERROR: bad-loop-entry ;
+
+: check-loop-entry ( bb -- )
+    dup length 2 >= [
+        2 head* [ ##loop-entry? ] any?
+        [ bad-loop-entry ] when
+    ] [ drop ] if ;
+
+: check-basic-block ( bb -- )
+    [ check-last-instruction ] [ check-loop-entry ] bi ;
+
 : check-rpo ( rpo -- )
     [ instructions>> check-basic-block ] each ;
 
+ERROR: undefined-values uses defs ;
+
+: check-mr ( mr -- )
+    ! Check that every used register has a definition
+    instructions>>
+    [ [ uses-vregs ] map concat ]
+    [ [ defs-vregs ] map concat ] bi
+    2dup subset? [ 2drop ] [ undefined-values ] if ;
+
 : check-cfg ( cfg -- )
-    reverse-post-order check-rpo ;
\ No newline at end of file
+    [ reverse-post-order check-rpo ] [ build-mr check-mr ] bi ;

From 117cb78d6bc674a06ed30e0172b4dff15b39568b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 27 May 2009 18:58:41 -0500
Subject: [PATCH 18/46] Fixing local optimizations

---
 basis/compiler/cfg/height/height.factor         |  6 +++---
 basis/compiler/cfg/rpo/rpo.factor               |  2 +-
 .../value-numbering-tests.factor                | 17 +++++++++++++++--
 .../cfg/value-numbering/value-numbering.factor  |  2 +-
 .../write-barrier/write-barrier-tests.factor    |  3 +--
 .../cfg/write-barrier/write-barrier.factor      |  2 +-
 6 files changed, 22 insertions(+), 10 deletions(-)

diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
index 336a8a33c2..eed0aeb0b5 100644
--- a/basis/compiler/cfg/height/height.factor
+++ b/basis/compiler/cfg/height/height.factor
@@ -48,8 +48,8 @@ M: insn normalize-height* ;
     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 ;
+    ds-height get dup 0 = [ drop ] [ f \ ##inc-d boa prefix ] if
+    rs-height get dup 0 = [ drop ] [ f \ ##inc-r boa prefix ] if ;
 
 : normalize-height ( rpo -- )
-    [ ] [ height-step ] local-optimization ;
+    [ drop ] [ height-step ] local-optimization ;
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index 32ca87de97..babea55643 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/basis/compiler/cfg/rpo/rpo.factor
@@ -31,7 +31,7 @@ SYMBOL: visited
     [ reverse-post-order ] dip each ; inline
 
 : optimize-basic-block ( bb init-quot insn-quot -- )
-    [ '[ live-in keys _ each ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
+    [ '[ live-in keys _ call ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
 
 : local-optimization ( rpo init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- )
     '[ _ _ optimize-basic-block ] each ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 11c0819027..c12b5afd2e 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -14,8 +14,8 @@ sequences compiler.cfg vectors arrays ;
     ] map ;
 
 : test-value-numbering ( insns -- insns )
-    basic-block new swap >vector >>instructions
-    dup value-numbering-step instructions>> >array ;
+    { } init-value-numbering
+    value-numbering-step ;
 
 [
     {
@@ -156,3 +156,16 @@ sequences compiler.cfg vectors arrays ;
         T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
     } test-value-numbering trim-temps
 ] unit-test
+
+[
+    {
+        T{ ##copy f V int-regs 48 V int-regs 45 }
+        T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
+    }
+] [
+    { V int-regs 45 } init-value-numbering
+    {
+        T{ ##copy f V int-regs 48 V int-regs 45 }
+        T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
+    } value-numbering-step
+] unit-test
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index b22c8b4388..c771d3b388 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -11,7 +11,7 @@ compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering
 
 : number-input-values ( live-in -- )
-    [ [ f next-input-expr ] dip set-vn ] each ;
+    [ [ f next-input-expr simplify ] dip set-vn ] each ;
 
 : init-value-numbering ( live-in -- )
     init-value-graph
diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
index fb755399dc..c1a667c004 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
@@ -4,8 +4,7 @@ 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 ;
+    write-barriers-step ;
 
 [
     {
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index b952c062e7..e4767599a7 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -43,4 +43,4 @@ M: insn eliminate-write-barrier ;
     [ eliminate-write-barrier ] map sift ;
 
 : eliminate-write-barriers ( rpo -- )
-    [ ] [ write-barriers-step ] local-optimization ;
+    [ drop ] [ write-barriers-step ] local-optimization ;

From 7b88756fd04f8f663661840ee61464063b57dc7f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 27 May 2009 18:58:54 -0500
Subject: [PATCH 19/46] Add a with-scope so that optimize-tree doesn't pollute
 namespace

---
 .../compiler/tree/optimizer/optimizer.factor  | 32 ++++++++++---------
 1 file changed, 17 insertions(+), 15 deletions(-)

diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor
index fe3c7acb92..d1f5b03be0 100644
--- a/basis/compiler/tree/optimizer/optimizer.factor
+++ b/basis/compiler/tree/optimizer/optimizer.factor
@@ -25,18 +25,20 @@ SYMBOL: check-optimizer?
     ] when ;
 
 : optimize-tree ( nodes -- nodes' )
-    analyze-recursive
-    normalize
-    propagate
-    cleanup
-    dup run-escape-analysis? [
-        escape-analysis
-        unbox-tuples
-    ] when
-    apply-identities
-    compute-def-use
-    remove-dead-code
-    ?check
-    compute-def-use
-    optimize-modular-arithmetic
-    finalize ;
+    [
+        analyze-recursive
+        normalize
+        propagate
+        cleanup
+        dup run-escape-analysis? [
+            escape-analysis
+            unbox-tuples
+        ] when
+        apply-identities
+        compute-def-use
+        remove-dead-code
+        ?check
+        compute-def-use
+        optimize-modular-arithmetic
+        finalize
+    ] with-scope ;

From 1fa465d77fc447e311f6af03d3278133c11a4ae4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 28 May 2009 02:48:58 -0500
Subject: [PATCH 20/46] Fix alias analysis

---
 basis/compiler/cfg/alias-analysis/alias-analysis.factor | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 6b1e0c47b6..198ffb5549 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -203,11 +203,11 @@ M: ##alien-global insn-object drop \ ##alien-global ;
     H{ } clone live-slots set
     H{ } clone constants set
     H{ } clone copies set
-
-    [ set-heap-ac ] each
     
     0 ac-counter set
-    next-ac heap-ac set ;
+    next-ac heap-ac set
+
+    [ set-heap-ac ] each ;
 
 GENERIC: analyze-aliases* ( insn -- insn' )
 

From ecece1d08b97e286d4eece489c9aa7b8815df1ad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 28 May 2009 02:49:51 -0500
Subject: [PATCH 21/46] CFG checker now checks consistency of successors and
 predecessors lists; fix long-standing bug in useless-blocks optimization

---
 basis/compiler/cfg/checker/checker.factor     | 24 +++++++++++++----
 .../useless-blocks-tests.factor               | 11 ++++++++
 .../cfg/useless-blocks/useless-blocks.factor  | 27 +++++++++++--------
 3 files changed, 46 insertions(+), 16 deletions(-)
 create mode 100644 basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor

diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index 53f0557db5..bc0eb74554 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use
-compiler.cfg.linearization combinators.short-circuit accessors math
-sequences sets ;
+USING: kernel compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness
+combinators.short-circuit accessors math sequences sets assocs ;
 IN: compiler.cfg.checker
 
 ERROR: last-insn-not-a-jump insn ;
@@ -27,11 +27,25 @@ ERROR: bad-loop-entry ;
         [ bad-loop-entry ] when
     ] [ drop ] if ;
 
+ERROR: bad-successors ;
+
+: check-successors ( bb -- )
+    dup successors>> [ predecessors>> memq? ] with all?
+    [ bad-successors ] unless ;
+
 : check-basic-block ( bb -- )
-    [ check-last-instruction ] [ check-loop-entry ] bi ;
+    [ instructions>> check-last-instruction ]
+    [ instructions>> check-loop-entry ]
+    [ check-successors ]
+    tri ;
+
+ERROR: bad-live-in ;
 
 : check-rpo ( rpo -- )
-    [ instructions>> check-basic-block ] each ;
+    [ compute-liveness ]
+    [ first live-in assoc-empty? [ bad-live-in ] unless ]
+    [ [ check-basic-block ] each ]
+    tri ;
 
 ERROR: undefined-values uses defs ;
 
diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
new file mode 100644
index 0000000000..ebc333b537
--- /dev/null
+++ b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
@@ -0,0 +1,11 @@
+IN: compiler.cfg.useless-blocks.tests
+USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
+compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
+
+{
+    [ [ drop 1 ] when ]
+    [ [ drop 1 ] unless ]
+} [
+    [ [ ] ] dip
+    '[ _ test-cfg first dup compute-predecessors dup delete-useless-blocks check-cfg ] unit-test
+] each
\ No newline at end of file
diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor
index b4999a8074..b6ec1a72ce 100644
--- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor
+++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor
@@ -1,10 +1,12 @@
 ! 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.instructions compiler.cfg.rpo ;
+USING: kernel accessors sequences combinators combinators.short-circuit
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
 IN: compiler.cfg.useless-blocks
 
 : update-predecessor-for-delete ( bb -- )
+    ! We have to replace occurrences of bb with bb's successor
+    ! in bb's predecessor's list of successors.
     dup predecessors>> first [
         [
             2dup eq? [ drop successors>> first ] [ nip ] if
@@ -12,9 +14,13 @@ IN: compiler.cfg.useless-blocks
     ] change-successors drop ;
 
 : update-successor-for-delete ( bb -- )
-    [ predecessors>> first ]
-    [ successors>> first predecessors>> ]
-    bi set-first ;
+    ! We have to replace occurrences of bb with bb's predecessor
+    ! in bb's sucessor's list of predecessors.
+    dup successors>> first [
+        [
+            2dup eq? [ drop predecessors>> first ] [ nip ] if
+        ] with map
+    ] change-predecessors drop ;
 
 : delete-basic-block ( bb -- )
     [ update-predecessor-for-delete ]
@@ -23,12 +29,11 @@ IN: compiler.cfg.useless-blocks
 
 : delete-basic-block? ( bb -- ? )
     {
-        { [ dup instructions>> length 1 = not ] [ f ] }
-        { [ dup predecessors>> length 1 = not ] [ f ] }
-        { [ dup successors>> length 1 = not ] [ f ] }
-        { [ dup instructions>> first ##branch? not ] [ f ] }
-        [ t ]
-    } cond nip ;
+        [ instructions>> length 1 = ]
+        [ predecessors>> length 1 = ]
+        [ successors>> length 1 = ]
+        [ instructions>> first ##branch? ]
+    } 1&& ;
 
 : delete-useless-blocks ( cfg -- )
     [

From fc5587bda32e3c204d2dfd9f347f93ce73e5da7a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 28 May 2009 02:50:07 -0500
Subject: [PATCH 22/46] Test updates

---
 basis/compiler/cfg/optimizer/optimizer-tests.factor  | 12 +++++++++---
 .../cfg/stack-analysis/stack-analysis-tests.factor   |  7 +++++--
 2 files changed, 14 insertions(+), 5 deletions(-)

diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
index 5cc01173ad..b81d9f81f5 100644
--- a/basis/compiler/cfg/optimizer/optimizer-tests.factor
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -1,8 +1,14 @@
 USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
-compiler.cfg.def-use sets kernel ;
+compiler.cfg.def-use sets kernel kernel.private fry slots.private ;
 IN: compiler.cfg.optimizer.tests
 
 ! Miscellaneous tests
 
-[ ] [ [ 1array ] test-mr first check-mr ] unit-test
-[ ] [ [ 1 2 ? ] test-mr first check-mr ] unit-test
\ No newline at end of file
+{
+    [ 1array ]
+    [ 1 2 ? ]
+    [ { array } declare [ ] map ]
+    [ { array } declare dup 1 slot [ 1 slot ] when ]
+} [
+    [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
+] each
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index d43900018e..e846ebc28f 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -3,7 +3,8 @@ 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 compiler.cfg.height compiler.cfg.rpo
-compiler.cfg.dce compiler.cfg.registers sets ;
+compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
+sets ;
 IN: compiler.cfg.stack-analysis.tests
 
 ! Fundamental invariant: a basic block should not load or store a value more than once
@@ -22,9 +23,11 @@ IN: compiler.cfg.stack-analysis.tests
 : test-stack-analysis ( quot -- mr )
     dup cfg? [ test-cfg first ] unless
     dup compute-predecessors
+    dup delete-useless-blocks
+    dup delete-useless-conditionals
     reverse-post-order
-    dup stack-analysis
     dup normalize-height
+    dup stack-analysis
     dup check-rpo
     dup check-for-redundant-ops ;
 

From dbf18927b92789cc2f3c7aa34f594164bb6b8a7e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 28 May 2009 17:54:27 -0500
Subject: [PATCH 23/46] compiler.cfg.liveness: correct handling of phi nodes

---
 basis/compiler/cfg/liveness/liveness.factor | 44 +++++++++++++++------
 1 file changed, 33 insertions(+), 11 deletions(-)

diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor
index 7cc6158e68..e069caa03d 100644
--- a/basis/compiler/cfg/liveness/liveness.factor
+++ b/basis/compiler/cfg/liveness/liveness.factor
@@ -1,7 +1,7 @@
 ! 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 ;
+dlists compiler.cfg.def-use compiler.cfg.instructions ;
 IN: compiler.cfg.liveness
 
 ! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
@@ -11,6 +11,14 @@ SYMBOL: live-ins
 
 : live-in ( basic-block -- set ) live-ins get at ;
 
+! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
+! is in conrrespondence with a predecessor
+SYMBOL: phi-live-ins
+
+: phi-live-in ( predecessor basic-block -- set )
+    [ predecessors>> index ] keep phi-live-ins get at
+    dup [ nth ] [ 2drop f ] if ;
+
 ! Assoc mapping basic blocks to sets of vregs
 SYMBOL: live-outs
 
@@ -24,21 +32,34 @@ SYMBOL: work-list
 : map-unique ( seq quot -- assoc )
     map concat unique ; inline
 
-: gen-set ( basic-block -- seq )
-    instructions>> [ uses-vregs ] map-unique ;
+: gen-set ( instructions -- seq )
+    [ ##phi? not ] filter [ uses-vregs ] map-unique ;
 
-: kill-set ( basic-block -- seq )
-    instructions>> [ defs-vregs ] map-unique ;
+: kill-set ( instructions -- seq )
+    [ defs-vregs ] map-unique ;
+
+: compute-live-in ( basic-block -- live-in )
+    dup instructions>>
+    [ [ live-out ] [ gen-set ] bi* assoc-union ]
+    [ nip kill-set ]
+    2bi assoc-diff ;
+
+: compute-phi-live-in ( basic-block -- phi-live-in )
+    instructions>> [ ##phi? ] filter
+    [ f ] [ [ inputs>> ] map flip [ unique ] map ] if-empty ;
 
 : 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 ;
+    [ [ compute-live-in ] keep live-ins get maybe-set-at ]
+    [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
+    bi and ; 
+
+: compute-live-out ( basic-block -- live-out )
+    [ successors>> [ live-in ] map ]
+    [ dup successors>> [ phi-live-in ] with map ] bi
+    append assoc-combine ;
 
 : update-live-out ( basic-block -- changed? )
-    [ successors>> [ live-in ] map assoc-combine ] keep
+    [ compute-live-out ] keep
     live-outs get maybe-set-at ;
 
 : liveness-step ( basic-block -- )
@@ -50,6 +71,7 @@ SYMBOL: work-list
 : compute-liveness ( rpo -- )
     <hashed-dlist> work-list set
     H{ } clone live-ins set
+    H{ } clone phi-live-ins set
     H{ } clone live-outs set
     <reversed> add-to-work-list
     work-list get [ liveness-step ] slurp-deque ;
\ No newline at end of file

From ceb332f5961b927897b690618527c8c473b1f97d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 28 May 2009 18:19:01 -0500
Subject: [PATCH 24/46] compiler.cfg.alias-analysis: ##peek needs to set alias
 class of output value

---
 .../cfg/alias-analysis/alias-analysis.factor       | 14 +++++++++-----
 1 file changed, 9 insertions(+), 5 deletions(-)

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 198ffb5549..0a3671034d 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -63,15 +63,14 @@ IN: compiler.cfg.alias-analysis
 ! Map vregs -> alias classes
 SYMBOL: vregs>acs
 
-: check ( obj -- obj )
-    [ "BUG: static type error detected" throw ] unless* ; inline
- 
+ERROR: vreg-ac-not-set vreg ;
+
 : vreg>ac ( vreg -- ac )
     #! Only vregs produced by ##allot, ##peek and ##slot can
     #! ever be used as valid inputs to ##slot and ##set-slot,
     #! so we assert this fact by not giving alias classes to
     #! other vregs.
-    vregs>acs get at check ;
+    vregs>acs get ?at [ vreg-ac-not-set ] unless ;
 
 ! Map alias classes -> sequence of vregs
 SYMBOL: acs>vregs
@@ -117,8 +116,10 @@ SYMBOL: histories
     #! value.
     over [ live-slots get at at ] [ 2drop f ] if ;
 
+ERROR: vreg-has-no-slots vreg ;
+
 : load-constant-slot ( value slot# vreg -- )
-    live-slots get at check set-at ;
+    live-slots get ?at [ vreg-has-no-slots ] unless set-at ;
 
 : load-slot ( value slot#/f vreg -- )
     over [ load-constant-slot ] [ 3drop ] if ;
@@ -214,6 +215,9 @@ GENERIC: analyze-aliases* ( insn -- insn' )
 M: ##load-immediate analyze-aliases*
     dup [ val>> ] [ dst>> ] bi constants get set-at ;
 
+M: ##peek analyze-aliases*
+    dup dst>> set-heap-ac ;
+
 M: ##load-reference analyze-aliases*
     dup dst>> set-heap-ac ;
 

From e3a8421f445a0a676c28a228306cd46e0b52b811 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Fri, 29 May 2009 00:01:22 -0300
Subject: [PATCH 25/46] irc.client: Send password on connect if provided

---
 extra/irc/client/internals/internals-tests.factor | 12 ++++++++++++
 extra/irc/client/internals/internals.factor       |  7 ++++++-
 2 files changed, 18 insertions(+), 1 deletion(-)

diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor
index 2c26188e04..a591fe9ce0 100644
--- a/extra/irc/client/internals/internals-tests.factor
+++ b/extra/irc/client/internals/internals-tests.factor
@@ -85,6 +85,18 @@ M: mb-writer dispose drop ;
     ] with-irc
 ] unit-test
 
+! Test connect with password
+{ V{ "PASS password" "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
+    "someserver" irc-port "factorbot" "password" <irc-profile> <irc-client>
+    [ 2drop <test-stream> ] >>connect
+    [
+        (connect-irc)
+        (do-login)
+        irc> stream>> out>> lines>>
+        (terminate-irc)
+    ] with-irc
+] unit-test
+
 ! Test join
 [ { "JOIN #factortest" } [
       "#factortest" %join %pop-output-line
diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor
index 0a4fe11830..1b4a4550dc 100644
--- a/extra/irc/client/internals/internals.factor
+++ b/extra/irc/client/internals/internals.factor
@@ -16,6 +16,7 @@ IN: irc.client.internals
 
 : /NICK ( nick -- ) "NICK " prepend irc-print ;
 : /PONG ( text -- ) "PONG " prepend irc-print ;
+: /PASS ( password -- ) "PASS " prepend irc-print ;
 
 : /LOGIN ( nick -- )
     dup /NICK
@@ -44,7 +45,11 @@ IN: irc.client.internals
         in-messages>> [ irc-connected ] dip mailbox-put
     ] [ (terminate-irc) ] if* ;
 
-: (do-login) ( -- ) irc> nick>> /LOGIN ;
+: (do-login) ( -- )
+     irc>
+     [ profile>> password>> [ /PASS ] when* ]
+     [ nick>> /LOGIN ]
+     bi ;
 
 GENERIC: initialize-chat ( chat -- )
 M: irc-chat         initialize-chat drop ;

From 76d74c16af409217c33ccf1626ee862be471404b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 29 May 2009 01:39:14 -0500
Subject: [PATCH 26/46] Fixing various bugs; alias analysis wasn't handling
 ##phi nodes, stack analysis incorrectly handled height-changing back edges
 and ##fixnum-*, clean up ##dispatch generation

---
 .../cfg/alias-analysis/alias-analysis.factor  | 10 +---
 basis/compiler/cfg/builder/builder.factor     | 57 +------------------
 basis/compiler/cfg/checker/checker.factor     |  2 +-
 .../cfg/instructions/instructions.factor      |  7 +--
 .../cfg/optimizer/optimizer-tests.factor      | 21 ++++++-
 .../cfg/stack-analysis/stack-analysis.factor  | 20 ++-----
 .../value-numbering-tests.factor              |  2 +-
 basis/compiler/codegen/codegen.factor         |  4 +-
 basis/cpu/architecture/architecture.factor    |  3 +-
 basis/cpu/ppc/ppc.factor                      |  7 +--
 basis/cpu/x86/32/32.factor                    |  4 +-
 basis/cpu/x86/64/64.factor                    |  4 +-
 basis/cpu/x86/x86.factor                      |  3 -
 13 files changed, 41 insertions(+), 103 deletions(-)

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 0a3671034d..7ea02c81e5 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -215,13 +215,7 @@ GENERIC: analyze-aliases* ( insn -- insn' )
 M: ##load-immediate analyze-aliases*
     dup [ val>> ] [ dst>> ] bi constants get set-at ;
 
-M: ##peek analyze-aliases*
-    dup dst>> set-heap-ac ;
-
-M: ##load-reference analyze-aliases*
-    dup dst>> set-heap-ac ;
-
-M: ##alien-global analyze-aliases*
+M: ##flushable analyze-aliases*
     dup dst>> set-heap-ac ;
 
 M: ##allocation analyze-aliases*
@@ -230,7 +224,7 @@ M: ##allocation analyze-aliases*
     dup dst>> set-new-ac ;
 
 M: ##read analyze-aliases*
-    dup dst>> set-heap-ac
+    call-next-method
     dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
     2dup live-slot dup [
         2nip f \ ##copy boa analyze-aliases* nip
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 1bf5bab067..38075c24a3 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -159,63 +159,8 @@ M: #if emit-node
     } cond iterate-next ;
 
 ! #dispatch
-: trivial-dispatch-branch? ( nodes -- ? )
-    dup length 1 = [
-        first dup #call? [
-            word>> "intrinsic" word-prop not
-        ] [ drop f ] if
-    ] [ drop f ] if ;
-
-: dispatch-branch ( nodes word -- label )
-    over trivial-dispatch-branch? [
-        drop first word>>
-    ] [
-        gensym [
-            [
-                V{ } clone node-stack set
-                ##prologue
-                begin-basic-block
-                emit-nodes
-                basic-block get [
-                    ##epilogue
-                    ##return
-                    end-basic-block
-                ] when
-            ] with-cfg-builder
-        ] keep
-    ] if ;
-
-: dispatch-branches ( node -- )
-    children>> [
-        current-word get dispatch-branch
-        ##dispatch-label
-    ] each ;
-
-: emit-dispatch ( node -- )
-    ##epilogue
-    ds-pop ^^offset>slot i 0 ##dispatch
-    dispatch-branches ;
-
-! If a dispatch is not in tail position, we compile a new word where the dispatch is in
-! tail position, then call this word.
-
-: (non-tail-dispatch) ( -- word )
-    gensym dup t "inlined-block" set-word-prop ;
-
-: <non-tail-dispatch> ( node -- word )
-    current-word get (non-tail-dispatch) [
-        [
-            begin-word
-            emit-dispatch
-        ] with-cfg-builder
-    ] keep ;
-
 M: #dispatch emit-node
-    tail-call? [
-        emit-dispatch stop-iterating
-    ] [
-       <non-tail-dispatch> f emit-call
-    ] if ;
+    ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
 
 ! #call
 M: #call emit-node
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index bc0eb74554..65191d5ac2 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -10,13 +10,13 @@ ERROR: last-insn-not-a-jump insn ;
 : check-last-instruction ( bb -- )
     peek dup {
         [ ##branch? ]
+        [ ##dispatch? ]
         [ ##conditional-branch? ]
         [ ##compare-imm-branch? ]
         [ ##return? ]
         [ ##callback-return? ]
         [ ##jump? ]
         [ ##call? ]
-        [ ##dispatch-label? ]
     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
 
 ERROR: bad-loop-entry ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 747233dbba..6da9f797bd 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -57,13 +57,12 @@ TUPLE: stack-frame
 spill-counts ;
 
 INSN: ##stack-frame stack-frame ;
-INSN: ##call word height ;
+INSN: ##call word { height integer } ;
 INSN: ##jump word ;
 INSN: ##return ;
 
 ! Jump tables
-INSN: ##dispatch src temp offset ;
-INSN: ##dispatch-label label ;
+INSN: ##dispatch src temp ;
 
 ! Slot access
 INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
@@ -165,7 +164,7 @@ UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
 
 INSN: ##write-barrier < ##effect card# table ;
 
-INSN: ##alien-global < ##read symbol library ;
+INSN: ##alien-global < ##flushable symbol library ;
 
 ! FFI
 INSN: ##alien-invoke params ;
diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
index b81d9f81f5..923fe828b5 100644
--- a/basis/compiler/cfg/optimizer/optimizer-tests.factor
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -1,14 +1,33 @@
 USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
-compiler.cfg.def-use sets kernel kernel.private fry slots.private ;
+compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
+sequences.private math sbufs math.private slots.private strings ;
 IN: compiler.cfg.optimizer.tests
 
 ! Miscellaneous tests
 
+: more? ( x -- ? ) ;
+
+: test-case-1 ( -- ? ) f ;
+
+: test-case-2 ( -- )
+    test-case-1 [ test-case-2 ] [ ] if ; inline recursive
+
 {
     [ 1array ]
     [ 1 2 ? ]
     [ { array } declare [ ] map ]
     [ { array } declare dup 1 slot [ 1 slot ] when ]
+    [ [ dup more? ] [ dup ] produce ]
+    [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
+    [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
+    [
+        { fixnum sbuf } declare 2dup 3 slot fixnum> [
+            over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
+        ] [ ] if
+    ]
+    [ [ 2 fixnum* ] when 3 ]
+    [ [ 2 fixnum+ ] when 3 ]
+    [ [ 2 fixnum- ] when 3 ]
 } [
     [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
 ] each
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index 0aa402ed66..ffff728ece 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -91,7 +91,8 @@ UNION: neutral-insn
     ##branch
     ##loop-entry
     ##conditional-branch
-    ##compare-imm-branch ;
+    ##compare-imm-branch
+    ##dispatch ;
 
 M: neutral-insn visit , ;
 
@@ -130,22 +131,12 @@ M: ##copy visit
     [ call-next-method ] [ record-copy ] bi ;
 
 M: ##call visit
-    [ call-next-method ] [ height>> [ adjust-d ] [ poison-state ] if* ] bi ;
-
-M: ##fixnum-mul visit
-    call-next-method -1 adjust-d ;
-
-M: ##fixnum-add visit
-    call-next-method -1 adjust-d ;
-
-M: ##fixnum-sub visit
-    call-next-method -1 adjust-d ;
+    [ call-next-method ] [ height>> adjust-d ] bi ;
 
 ! Instructions that poison the stack state
 UNION: poison-insn
     ##jump
     ##return
-    ##dispatch
     ##callback-return
     ##fixnum-mul-tail
     ##fixnum-add-tail
@@ -179,8 +170,6 @@ M: ##alien-indirect visit
 
 M: ##alien-callback visit , ;
 
-M: ##dispatch-label visit , ;
-
 ! Maps basic-blocks to states
 SYMBOLS: state-in state-out ;
 
@@ -245,7 +234,8 @@ ERROR: cannot-merge-poisoned states ;
         [
             drop
             dup [ not ] any? [
-                2drop <state>
+                [ <state> ] 2dip
+                sift merge-heights
             ] [
                 dup [ poisoned?>> ] any? [
                     cannot-merge-poisoned
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index c12b5afd2e..5063273bf4 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -50,7 +50,7 @@ sequences compiler.cfg vectors arrays ;
 [ t ] [
     {
         T{ ##peek f V int-regs 1 D 0 }
-        T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
+        T{ ##dispatch f V int-regs 1 V int-regs 2 }
     } dup test-value-numbering =
 ] unit-test
 
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index c7b67b72b4..11b4e153f6 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -92,10 +92,8 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
 
 M: ##return generate-insn drop %return ;
 
-M: ##dispatch-label generate-insn label>> %dispatch-label ;
-
 M: ##dispatch generate-insn
-    [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
+    [ src>> register ] [ temp>> register ] bi %dispatch ;
 
 : >slot< ( insn -- dst obj slot tag )
     {
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index de5d1da4e0..98d0c5326b 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -51,8 +51,7 @@ HOOK: %jump cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 HOOK: %return cpu ( -- )
 
-HOOK: %dispatch cpu ( src temp offset -- )
-HOOK: %dispatch-label cpu ( word -- )
+HOOK: %dispatch cpu ( src temp -- )
 
 HOOK: %slot cpu ( dst obj slot tag temp -- )
 HOOK: %slot-imm cpu ( dst obj slot tag -- )
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 617a7c5141..934b456075 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -124,16 +124,13 @@ M: ppc %jump ( word -- )
 M: ppc %jump-label ( label -- ) B ;
 M: ppc %return ( -- ) BLR ;
 
-M:: ppc %dispatch ( src temp offset -- )
+M:: ppc %dispatch ( src temp -- )
     0 temp LOAD32
-    4 offset + cells rc-absolute-ppc-2/2 rel-here
+    4 cells rc-absolute-ppc-2/2 rel-here
     temp temp src LWZX
     temp MTCTR
     BCTR ;
 
-M: ppc %dispatch-label ( word -- )
-    B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
-
 :: (%slot) ( obj slot tag temp -- reg offset )
     temp slot obj ADD
     temp tag neg ; inline
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 0a0ac4a53e..4492a3d762 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -26,10 +26,10 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 temp-reg-1 ECX ;
 M: x86.32 temp-reg-2 EDX ;
 
-M:: x86.32 %dispatch ( src temp offset -- )
+M:: x86.32 %dispatch ( src temp -- )
     ! Load jump table base.
     src HEX: ffffffff ADD
-    offset cells rc-absolute-cell rel-here
+    0 rc-absolute-cell rel-here
     ! Go
     src HEX: 7f [+] JMP
     ! Fix up the displacement above
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index b77539b7e7..0b9b4e8ddf 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -22,10 +22,10 @@ M: x86.64 ds-reg R14 ;
 M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
 
-M:: x86.64 %dispatch ( src temp offset -- )
+M:: x86.64 %dispatch ( src temp -- )
     ! Load jump table base.
     temp HEX: ffffffff MOV
-    offset cells rc-absolute-cell rel-here
+    0 rc-absolute-cell rel-here
     ! Add jump table base
     src temp ADD
     src HEX: 7f [+] JMP
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index e12cec9738..8ab247f5e5 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -79,9 +79,6 @@ M: x86 %return ( -- ) 0 RET ;
 : align-code ( n -- )
     0 <repetition> % ;
 
-M: x86 %dispatch-label ( word -- )
-    0 cell, rc-absolute-cell rel-word ;
-
 :: (%slot) ( obj slot tag temp -- op )
     temp slot obj [+] LEA
     temp tag neg [+] ; inline

From 743550f19c956ca29c4238f57f6ff3097ce212c2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 29 May 2009 05:36:04 -0500
Subject: [PATCH 27/46] Put GC checks in the right place when linearizing, and
 generate _dispatch-labels

---
 basis/compiler/cfg/def-use/def-use.factor     |  5 +-
 .../cfg/instructions/instructions.factor      |  3 ++
 .../cfg/linearization/linearization.factor    | 52 ++++++++++++++-----
 3 files changed, 45 insertions(+), 15 deletions(-)

diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 97047a7c3e..ba2a4dac3a 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -21,6 +21,7 @@ M: ##compare-imm defs-vregs dst/tmp-vregs ;
 M: ##compare-float defs-vregs dst/tmp-vregs ;
 M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
 M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: _dispatch defs-vregs temp>> 1array ;
 M: insn defs-vregs drop f ;
 
 M: ##unary uses-vregs src>> 1array ;
@@ -42,6 +43,7 @@ M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: ##phi uses-vregs inputs>> ;
 M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
+M: _dispatch uses-vregs src>> 1array ;
 M: insn uses-vregs drop f ;
 
 ! Instructions that use vregs
@@ -54,4 +56,5 @@ UNION: vreg-insn
 ##conditional-branch
 ##compare-imm-branch
 _conditional-branch
-_compare-imm-branch ;
+_compare-imm-branch
+_dispatch ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 6da9f797bd..5682aa668d 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -231,6 +231,9 @@ INSN: _gc live-in ;
 
 INSN: _branch label ;
 
+INSN: _dispatch src temp ;
+INSN: _dispatch-label label ;
+
 TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
 
 INSN: _compare-branch < _conditional-branch ;
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 64507779a4..0d851ea483 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -12,8 +12,38 @@ IN: compiler.cfg.linearization
 ! Convert CFG IR to machine IR.
 GENERIC: linearize-insn ( basic-block insn -- )
 
-: linearize-insns ( basic-block -- )
-    dup instructions>> [ linearize-insn ] with each ; inline
+: linearize-insns ( bb insns -- )
+    [ linearize-insn ] with each ;
+
+: gc? ( bb -- ? )
+    instructions>> [ ##allocation? ] any? ;
+
+: object-pointer-regs ( basic-block -- vregs )
+    live-out keys [ reg-class>> int-regs eq? ] filter ;
+
+: gc-check-position ( insns -- n )
+    #! We want to insert the GC check before the final branch in a basic block.
+    #! If there is a ##epilogue or ##loop-entry we want to insert it before that too.
+    dup length
+    dup 2 >= [
+        2 - swap nth [ ##loop-entry? ] [ ##epilogue? ] bi or
+        2 1 ?
+    ] [ 2drop 1 ] if ;
+
+: linearize-basic-block/gc ( bb -- )
+    dup instructions>> dup gc-check-position
+    [ head* linearize-insns ]
+    [ 2drop object-pointer-regs _gc ]
+    [ tail* linearize-insns ]
+    3tri ;
+
+: linearize-basic-block ( bb -- )
+    [ number>> _label ]
+    [
+        dup gc?
+        [ linearize-basic-block/gc ]
+        [ dup instructions>> linearize-insns ] if
+    ] bi ;
 
 M: insn linearize-insn , drop ;
 
@@ -32,7 +62,7 @@ M: insn linearize-insn , drop ;
 : emit-branch ( basic-block successor -- )
     {
         { [ 2dup useless-branch? ] [ 2drop ] }
-        { [ dup branch-to-branch? ] [ nip linearize-insns ] }
+        { [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
         [ nip number>> _branch ]
     } cond ;
 
@@ -57,17 +87,11 @@ M: ##compare-imm-branch linearize-insn
 M: ##compare-float-branch linearize-insn
     binary-conditional _compare-float-branch emit-branch ;
 
-: gc? ( bb -- ? )
-    instructions>> [ ##allocation? ] any? ;
-
-: object-pointer-regs ( basic-block -- vregs )
-    live-in keys [ reg-class>> int-regs eq? ] filter ;
-
-: linearize-basic-block ( bb -- )
-    [ number>> _label ]
-    [ dup gc? [ object-pointer-regs _gc ] [ drop ] if ]
-    [ linearize-insns ]
-    tri ;
+M: ##dispatch linearize-insn
+    swap
+    [ [ src>> ] [ temp>> ] bi _dispatch ]
+    [ successors>> [ number>> _dispatch-label ] each ]
+    bi* ;
 
 : linearize-basic-blocks ( rpo -- insns )
     [ [ linearize-basic-block ] each ] { } make ;

From 280736ab00d6a9f57095a7ac7e07e3aaf6d91f67 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 29 May 2009 05:45:40 -0500
Subject: [PATCH 28/46] On second thought, linearization will be done after SSA
 destruction so live-in is accurate

---
 .../cfg/linearization/linearization.factor    | 28 ++++---------------
 1 file changed, 5 insertions(+), 23 deletions(-)

diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 0d851ea483..9b328a43c0 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -13,37 +13,19 @@ IN: compiler.cfg.linearization
 GENERIC: linearize-insn ( basic-block insn -- )
 
 : linearize-insns ( bb insns -- )
-    [ linearize-insn ] with each ;
+    dup instructions>> [ linearize-insn ] with each ;
 
 : gc? ( bb -- ? )
     instructions>> [ ##allocation? ] any? ;
 
 : object-pointer-regs ( basic-block -- vregs )
-    live-out keys [ reg-class>> int-regs eq? ] filter ;
-
-: gc-check-position ( insns -- n )
-    #! We want to insert the GC check before the final branch in a basic block.
-    #! If there is a ##epilogue or ##loop-entry we want to insert it before that too.
-    dup length
-    dup 2 >= [
-        2 - swap nth [ ##loop-entry? ] [ ##epilogue? ] bi or
-        2 1 ?
-    ] [ 2drop 1 ] if ;
-
-: linearize-basic-block/gc ( bb -- )
-    dup instructions>> dup gc-check-position
-    [ head* linearize-insns ]
-    [ 2drop object-pointer-regs _gc ]
-    [ tail* linearize-insns ]
-    3tri ;
+    live-in keys [ reg-class>> int-regs eq? ] filter ;
 
 : linearize-basic-block ( bb -- )
     [ number>> _label ]
-    [
-        dup gc?
-        [ linearize-basic-block/gc ]
-        [ dup instructions>> linearize-insns ] if
-    ] bi ;
+    [ dup gc? [ object-pointer-regs _gc ] [ drop ] if ]
+    [ linearize-insns ]
+    tri ;
 
 M: insn linearize-insn , drop ;
 

From e04df76f60c19e94e97d3713041b341d97bbede0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 29 May 2009 13:11:34 -0500
Subject: [PATCH 29/46] Various codegen improvements:

- new-insn word to construct instructions
- cache RPO in the CFG
- re-organize low-level optimizer so that MR is built after register allocation
- register allocation now stores instruction numbers in the instructions themselves
- split defs-vregs into defs-vregs and temp-vregs
---
 .../cfg/alias-analysis/alias-analysis.factor  |  4 +-
 basis/compiler/cfg/cfg.factor                 |  6 +--
 basis/compiler/cfg/checker/checker.factor     | 14 +++---
 basis/compiler/cfg/dce/dce.factor             | 12 +++--
 basis/compiler/cfg/debugger/debugger.factor   |  6 +--
 basis/compiler/cfg/def-use/def-use.factor     | 40 ++++++++++------
 basis/compiler/cfg/height/height.factor       |  8 ++--
 .../cfg/instructions/instructions.factor      |  4 +-
 .../cfg/instructions/syntax/syntax.factor     |  6 +--
 .../linear-scan/assignment/assignment.factor  | 34 ++++++++------
 .../cfg/linear-scan/linear-scan-tests.factor  | 31 +++++++++----
 .../cfg/linear-scan/linear-scan.factor        | 17 ++++---
 .../live-intervals/live-intervals.factor      | 18 ++++----
 .../cfg/linear-scan/numbering/authors.txt     |  1 +
 .../linear-scan/numbering/numbering.factor    | 11 +++++
 .../cfg/linearization/linearization.factor    | 24 ++++++----
 basis/compiler/cfg/liveness/liveness.factor   | 14 ++++--
 basis/compiler/cfg/optimizer/optimizer.factor | 30 +++++-------
 .../phi-elimination/phi-elimination.factor    |  8 ++--
 .../cfg/predecessors/predecessors.factor      |  4 +-
 basis/compiler/cfg/rpo/rpo.factor             | 24 +++++-----
 .../stack-analysis-tests.factor               | 46 ++++++++++---------
 .../cfg/stack-analysis/stack-analysis.factor  |  4 +-
 .../cfg/two-operand/two-operand.factor        | 46 ++++++++++---------
 .../useless-blocks-tests.factor               |  2 +-
 .../cfg/useless-blocks/useless-blocks.factor  | 16 ++++---
 .../value-numbering/rewrite/rewrite.factor    | 18 ++++----
 .../value-numbering/value-numbering.factor    |  4 +-
 .../cfg/write-barrier/write-barrier.factor    |  4 +-
 basis/compiler/compiler.factor                |  6 +--
 30 files changed, 258 insertions(+), 204 deletions(-)
 create mode 100644 basis/compiler/cfg/linear-scan/numbering/authors.txt
 create mode 100644 basis/compiler/cfg/linear-scan/numbering/numbering.factor

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 7ea02c81e5..384fd65c1a 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -227,7 +227,7 @@ M: ##read analyze-aliases*
     call-next-method
     dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
     2dup live-slot dup [
-        2nip f \ ##copy boa analyze-aliases* nip
+        2nip \ ##copy new-insn analyze-aliases* nip
     ] [
         drop remember-slot
     ] if ;
@@ -284,5 +284,5 @@ M: insn eliminate-dead-stores* ;
     compute-live-stores
     eliminate-dead-stores ;
 
-: alias-analysis ( rpo -- )
+: alias-analysis ( cfg -- cfg' )
     [ init-alias-analysis ] [ alias-analysis-step ] local-optimization ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 265cbb8f00..c3ae15f069 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -27,11 +27,11 @@ M: basic-block hashcode* nip id>> ;
         building get push
     ] with-variable ; inline
 
-TUPLE: cfg { entry basic-block } word label ;
+TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
 
-C: <cfg> cfg
+: <cfg> ( entry word label -- cfg ) f f cfg boa ;
 
-TUPLE: mr { instructions array } word label spill-counts ;
+TUPLE: mr { instructions array } word label ;
 
 : <mr> ( instructions word label -- mr )
     mr new
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index 65191d5ac2..bf5adc2d55 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -41,20 +41,18 @@ ERROR: bad-successors ;
 
 ERROR: bad-live-in ;
 
-: check-rpo ( rpo -- )
-    [ compute-liveness ]
-    [ first live-in assoc-empty? [ bad-live-in ] unless ]
-    [ [ check-basic-block ] each ]
-    tri ;
-
 ERROR: undefined-values uses defs ;
 
 : check-mr ( mr -- )
     ! Check that every used register has a definition
     instructions>>
     [ [ uses-vregs ] map concat ]
-    [ [ defs-vregs ] map concat ] bi
+    [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
     2dup subset? [ 2drop ] [ undefined-values ] if ;
 
 : check-cfg ( cfg -- )
-    [ reverse-post-order check-rpo ] [ build-mr check-mr ] bi ;
+    compute-liveness
+    [ entry>> live-in assoc-empty? [ bad-live-in ] unless ]
+    [ [ check-basic-block ] each-basic-block ]
+    [ build-mr check-mr ]
+    tri ;
diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor
index 5db760e861..68c89be455 100644
--- a/basis/compiler/cfg/dce/dce.factor
+++ b/basis/compiler/cfg/dce/dce.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sets kernel namespaces sequences
-compiler.cfg.instructions compiler.cfg.def-use ;
+compiler.cfg.instructions compiler.cfg.def-use
+compiler.cfg.rpo ;
 IN: compiler.cfg.dce
 
 ! Maps vregs to sequences of vregs
@@ -36,8 +37,9 @@ M: ##flushable live-insn? dst>> live-vregs get key? ;
 
 M: insn live-insn? drop t ;
 
-: eliminate-dead-code ( rpo -- )
+: eliminate-dead-code ( cfg -- cfg' )
     init-dead-code
-    [ [ instructions>> [ update-liveness-graph ] each ] each ]
-    [ [ [ [ live-insn? ] filter ] change-instructions drop ] each ]
-    bi ;
\ No newline at end of file
+    [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
+    [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
+    [ ]
+    tri ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 6b0aba6813..5c106bfaee 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -23,10 +23,10 @@ SYMBOL: allocate-registers?
 : test-mr ( quot -- mrs )
     test-cfg [
         optimize-cfg
-        build-mr
         convert-two-operand
-        allocate-registers? get
-        [ linear-scan build-stack-frame ] when
+        allocate-registers? get [ linear-scan ] when
+        build-mr
+        allocate-registers? get [ build-stack-frame ] when
     ] map ;
 
 : insn. ( insn -- )
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index ba2a4dac3a..17e49f59a8 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -1,29 +1,39 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel compiler.cfg.instructions ;
 IN: compiler.cfg.def-use
 
 GENERIC: defs-vregs ( insn -- seq )
+GENERIC: temp-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
-: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
 M: ##flushable defs-vregs dst>> 1array ;
-M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
-M: ##unary/temp defs-vregs dst/tmp-vregs ;
-M: ##allot defs-vregs dst/tmp-vregs ;
-M: ##dispatch defs-vregs temp>> 1array ;
-M: ##slot defs-vregs dst/tmp-vregs ;
+M: ##unary/temp defs-vregs dst>> 1array ;
+M: ##allot defs-vregs dst>> 1array ;
+M: ##slot defs-vregs dst>> 1array ;
 M: ##set-slot defs-vregs temp>> 1array ;
-M: ##string-nth defs-vregs dst/tmp-vregs ;
-M: ##set-string-nth-fast defs-vregs temp>> 1array ;
-M: ##compare defs-vregs dst/tmp-vregs ;
-M: ##compare-imm defs-vregs dst/tmp-vregs ;
-M: ##compare-float defs-vregs dst/tmp-vregs ;
-M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: _dispatch defs-vregs temp>> 1array ;
+M: ##string-nth defs-vregs dst>> 1array ;
+M: ##compare defs-vregs dst>> 1array ;
+M: ##compare-imm defs-vregs dst>> 1array ;
+M: ##compare-float defs-vregs dst>> 1array ;
 M: insn defs-vregs drop f ;
 
+M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
+M: ##unary/temp temp-vregs temp>> 1array ;
+M: ##allot temp-vregs temp>> 1array ;
+M: ##dispatch temp-vregs temp>> 1array ;
+M: ##slot temp-vregs temp>> 1array ;
+M: ##set-slot temp-vregs temp>> 1array ;
+M: ##string-nth temp-vregs temp>> 1array ;
+M: ##set-string-nth-fast temp-vregs temp>> 1array ;
+M: ##compare temp-vregs temp>> 1array ;
+M: ##compare-imm temp-vregs temp>> 1array ;
+M: ##compare-float temp-vregs temp>> 1array ;
+M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: _dispatch temp-vregs temp>> 1array ;
+M: insn temp-vregs drop f ;
+
 M: ##unary uses-vregs src>> 1array ;
 M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: ##binary-imm uses-vregs src1>> 1array ;
diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
index eed0aeb0b5..b91120ccfd 100644
--- a/basis/compiler/cfg/height/height.factor
+++ b/basis/compiler/cfg/height/height.factor
@@ -2,7 +2,7 @@
 ! 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.rpo ;
+compiler.cfg.liveness ;
 IN: compiler.cfg.height
 
 ! Combine multiple stack height changes into one at the
@@ -48,8 +48,8 @@ M: insn normalize-height* ;
     0 rs-height set
     [ [ compute-heights ] each ]
     [ [ [ normalize-height* ] map sift ] with-scope ] bi
-    ds-height get dup 0 = [ drop ] [ f \ ##inc-d boa prefix ] if
-    rs-height get dup 0 = [ drop ] [ f \ ##inc-r boa prefix ] if ;
+    ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
+    rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
 
-: normalize-height ( rpo -- )
+: normalize-height ( cfg -- cfg' )
     [ drop ] [ height-step ] local-optimization ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 5682aa668d..d2d444a4a5 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.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: assocs accessors arrays kernel sequences namespaces words
 math math.order layouts classes.algebra alien byte-arrays
@@ -6,6 +6,8 @@ compiler.constants combinators compiler.cfg.registers
 compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
+: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline
+
 ! Virtual CPU instructions, used by CFG and machine IRs
 TUPLE: insn ;
 
diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor
index 876ac5596c..e8f8641e7d 100644
--- a/basis/compiler/cfg/instructions/syntax/syntax.factor
+++ b/basis/compiler/cfg/instructions/syntax/syntax.factor
@@ -11,12 +11,12 @@ IN: compiler.cfg.instructions.syntax
     "insn" "compiler.cfg.instructions" lookup ;
 
 : insn-effect ( word -- effect )
-    boa-effect in>> but-last f <effect> ;
+    boa-effect in>> 2 head* f <effect> ;
 
 SYNTAX: INSN:
-    parse-tuple-definition "regs" suffix
+    parse-tuple-definition { "regs" "insn#" } append
     [ dup tuple eq? [ drop insn-word ] when ] dip
     [ define-tuple-class ]
     [ 2drop save-location ]
-    [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
+    [ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ]
     3tri ;
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index da45b45aaa..f21b9e5db8 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -59,29 +59,35 @@ SYMBOL: unhandled-intervals
         ] [ 2drop ] if
     ] if ;
 
-GENERIC: (assign-registers) ( insn -- )
+GENERIC: assign-registers-in-insn ( insn -- )
 
-M: vreg-insn (assign-registers)
-    dup
-    [ defs-vregs ] [ uses-vregs ] bi append
-    active-intervals get swap '[ vreg>> _ member? ] filter
+: all-vregs ( insn -- vregs )
+    [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
+
+M: vreg-insn assign-registers-in-insn
+    active-intervals get over all-vregs '[ vreg>> _ member? ] filter
     [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
     >>regs drop ;
 
-M: insn (assign-registers) drop ;
+M: insn assign-registers-in-insn drop ;
 
 : init-assignment ( live-intervals -- )
     V{ } clone active-intervals set
     <min-heap> unhandled-intervals set
     init-unhandled ;
 
-: assign-registers ( insns live-intervals -- insns' )
+: assign-registers-in-block ( bb -- )
     [
-        init-assignment
         [
-            [ activate-new-intervals ]
-            [ drop [ (assign-registers) ] [ , ] bi ]
-            [ expire-old-intervals ]
-            tri
-        ] each-index
-    ] { } make ;
+            [
+                [ insn#>> activate-new-intervals ]
+                [ [ assign-registers-in-insn ] [ , ] bi ]
+                [ insn#>> expire-old-intervals ]
+                tri
+            ] each
+        ] V{ } make
+    ] change-instructions drop ;
+
+: assign-registers ( rpo live-intervals -- )
+    init-assignment
+    [ assign-registers-in-block ] each ;
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 4ddd1fdc0b..bfbc824846 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -3,6 +3,8 @@ USING: tools.test random sorting sequences sets hashtables assocs
 kernel fry arrays splitting namespaces math accessors vectors
 math.order grouping
 cpu.architecture
+compiler.cfg
+compiler.cfg.optimizer
 compiler.cfg.instructions
 compiler.cfg.registers
 compiler.cfg.linear-scan
@@ -264,18 +266,27 @@ SYMBOL: max-uses
 
 USING: math.private compiler.cfg.debugger ;
 
-[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
+[ ] [
+    [ float+ float>fixnum 3 fixnum*fast ]
+    test-cfg first optimize-cfg linear-scan drop
+] unit-test
 
 [ f ] [
-    T{ ##allot
-        f
-        T{ vreg f int-regs 1 }
-        40
-        array
-        T{ vreg f int-regs 2 }
-        f
-    } clone
-    1array (linear-scan) first regs>> values all-equal?
+    T{ basic-block
+       { instructions
+         V{
+             T{ ##allot
+                f
+                T{ vreg f int-regs 1 }
+                40
+                array
+                T{ vreg f int-regs 2 }
+                f
+             }
+         }
+       }
+    } clone [ [ clone ] map ] change-instructions
+    dup 1array (linear-scan) instructions>> first regs>> values all-equal?
 ] unit-test
 
 [ 0 1 ] [
diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index 855f2a6648..1e6b9d02c8 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -1,9 +1,11 @@
-! 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
 cpu.architecture
 compiler.cfg
+compiler.cfg.rpo
 compiler.cfg.instructions
+compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.assignment ;
@@ -23,16 +25,13 @@ IN: compiler.cfg.linear-scan
 ! by Omri Traub, Glenn Holloway, Michael D. Smith
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
 
-: (linear-scan) ( insns -- insns' )
+: (linear-scan) ( rpo -- )
+    dup number-instructions
     dup compute-live-intervals
     machine-registers allocate-registers assign-registers ;
 
-: linear-scan ( mr -- mr' )
+: linear-scan ( cfg -- cfg' )
     [
-        [
-            [
-                (linear-scan) %
-                spill-counts get _spill-counts
-            ] { } make
-        ] change-instructions
+        dup reverse-post-order (linear-scan)
+        spill-counts get >>spill-counts
     ] with-scope ;
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index 1055a3524a..55bcdc7470 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.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: namespaces kernel assocs accessors sequences math fry
 compiler.cfg.instructions compiler.cfg.registers
@@ -38,27 +38,29 @@ SYMBOL: live-intervals
         [ [ <live-interval> ] keep ] dip set-at
     ] if ;
 
-GENERIC# compute-live-intervals* 1 ( insn n -- )
+GENERIC: compute-live-intervals* ( insn -- )
 
-M: insn compute-live-intervals* 2drop ;
+M: insn compute-live-intervals* drop ;
 
 M: vreg-insn compute-live-intervals*
+    dup insn#>>
     live-intervals get
     [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
     [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
-    3bi ;
+    [ [ temp-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+    3tri ;
 
 : record-copy ( insn -- )
     [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
 
 M: ##copy compute-live-intervals*
-    [ call-next-method ] [ drop record-copy ] 2bi ;
+    [ call-next-method ] [ record-copy ] bi ;
 
 M: ##copy-float compute-live-intervals*
-    [ call-next-method ] [ drop record-copy ] 2bi ;
+    [ call-next-method ] [ record-copy ] bi ;
 
-: compute-live-intervals ( instructions -- live-intervals )
+: compute-live-intervals ( rpo -- live-intervals )
     H{ } clone [
         live-intervals set
-        [ compute-live-intervals* ] each-index
+        [ instructions>> [ compute-live-intervals* ] each ] each
     ] keep values ;
diff --git a/basis/compiler/cfg/linear-scan/numbering/authors.txt b/basis/compiler/cfg/linear-scan/numbering/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/numbering/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor
new file mode 100644
index 0000000000..6734f6a359
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor
@@ -0,0 +1,11 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math sequences ;
+IN: compiler.cfg.linear-scan.numbering
+
+: number-instructions ( rpo -- )
+    [ 0 ] dip [
+        instructions>> [
+            [ (>>insn#) ] [ drop 2 + ] 2bi
+        ] each
+    ] each drop ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 9b328a43c0..5ad8be2953 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -60,25 +60,31 @@ M: ##branch linearize-insn
     [ drop dup successors>> second useless-branch? ] 2bi
     [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
 
+: with-regs ( insn quot -- )
+    over regs>> [ call ] dip building get peek (>>regs) ; inline
+
 M: ##compare-branch linearize-insn
-    binary-conditional _compare-branch emit-branch ;
+    [ binary-conditional _compare-branch ] with-regs emit-branch ;
 
 M: ##compare-imm-branch linearize-insn
-    binary-conditional _compare-imm-branch emit-branch ;
+    [ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
 
 M: ##compare-float-branch linearize-insn
-    binary-conditional _compare-float-branch emit-branch ;
+    [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
 
 M: ##dispatch linearize-insn
     swap
-    [ [ src>> ] [ temp>> ] bi _dispatch ]
+    [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
     [ successors>> [ number>> _dispatch-label ] each ]
     bi* ;
 
-: linearize-basic-blocks ( rpo -- insns )
-    [ [ linearize-basic-block ] each ] { } make ;
+: linearize-basic-blocks ( cfg -- insns )
+    [
+        [ [ linearize-basic-block ] each-basic-block ]
+        [ spill-counts>> _spill-counts ]
+        bi
+    ] { } make ;
 
 : build-mr ( cfg -- mr )
-    [ reverse-post-order linearize-basic-blocks ]
-    [ word>> ] [ label>> ]
-    tri <mr> ;
+    [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
+    <mr> ;
diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor
index e069caa03d..72609cf4d9 100644
--- a/basis/compiler/cfg/liveness/liveness.factor
+++ b/basis/compiler/cfg/liveness/liveness.factor
@@ -1,7 +1,8 @@
 ! 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.instructions ;
+dlists compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.rpo ;
 IN: compiler.cfg.liveness
 
 ! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
@@ -36,7 +37,7 @@ SYMBOL: work-list
     [ ##phi? not ] filter [ uses-vregs ] map-unique ;
 
 : kill-set ( instructions -- seq )
-    [ defs-vregs ] map-unique ;
+    [ [ defs-vregs ] [ temp-vregs ] bi append ] map-unique ;
 
 : compute-live-in ( basic-block -- live-in )
     dup instructions>>
@@ -68,10 +69,13 @@ SYMBOL: work-list
         [ predecessors>> add-to-work-list ] [ drop ] if
     ] [ drop ] if ;
 
-: compute-liveness ( rpo -- )
+: compute-liveness ( cfg -- cfg' )
     <hashed-dlist> work-list set
     H{ } clone live-ins set
     H{ } clone phi-live-ins set
     H{ } clone live-outs set
-    <reversed> add-to-work-list
-    work-list get [ liveness-step ] slurp-deque ;
\ No newline at end of file
+    dup post-order add-to-work-list
+    work-list get [ liveness-step ] slurp-deque ;
+
+: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
+    [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index f59e9e0b83..8ceafd1693 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -14,23 +14,17 @@ compiler.cfg.rpo
 compiler.cfg.phi-elimination ;
 IN: compiler.cfg.optimizer
 
-: optimize-cfg ( cfg -- cfg )
+: optimize-cfg ( cfg -- cfg' )
     [
-        [
-            [ compute-predecessors ]
-            [ delete-useless-blocks ]
-            [ delete-useless-conditionals ] tri
-        ] [
-            reverse-post-order
-            {
-                [ normalize-height ]
-                [ stack-analysis ]
-                [ compute-liveness ]
-                [ alias-analysis ]
-                [ value-numbering ]
-                [ eliminate-dead-code ]
-                [ eliminate-write-barriers ]
-                [ eliminate-phis ]
-            } cleave
-        ] [ ] tri
+        compute-predecessors
+        delete-useless-blocks
+        delete-useless-conditionals
+        normalize-height
+        stack-analysis
+        compute-liveness
+        alias-analysis
+        value-numbering
+        eliminate-dead-code
+        eliminate-write-barriers
+        eliminate-phis
     ] with-scope ;
diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor
index d94e57f378..3ebf553a45 100644
--- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor
+++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors compiler.cfg compiler.cfg.instructions fry
-kernel sequences ;
+USING: accessors compiler.cfg compiler.cfg.instructions
+compiler.cfg.rpo fry kernel sequences ;
 IN: compiler.cfg.phi-elimination
 
 : insert-copy ( predecessor input output -- )
@@ -17,5 +17,5 @@ IN: compiler.cfg.phi-elimination
         [ [ eliminate-phi ] with each ] dip
     ] change-instructions drop ;
 
-: eliminate-phis ( rpo -- )
-    [ eliminate-phi-step ] each ;
\ No newline at end of file
+: eliminate-phis ( cfg -- cfg' )
+    dup [ eliminate-phi-step ] each-basic-block ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor
index 9bc3a08f63..5be085ba5a 100644
--- a/basis/compiler/cfg/predecessors/predecessors.factor
+++ b/basis/compiler/cfg/predecessors/predecessors.factor
@@ -6,5 +6,5 @@ IN: compiler.cfg.predecessors
 : predecessors-step ( bb -- )
     dup successors>> [ predecessors>> push ] with each ;
 
-: compute-predecessors ( cfg -- )
-    [ predecessors-step ] each-basic-block ;
+: compute-predecessors ( cfg -- cfg' )
+    dup [ predecessors-step ] each-basic-block ;
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index babea55643..d01f5ee864 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/basis/compiler/cfg/rpo/rpo.factor
@@ -16,22 +16,24 @@ SYMBOL: visited
         ] [ , ] bi
     ] if ;
 
-: post-order ( cfg -- blocks )
-    [ entry>> post-order-traversal ] { } make ;
-
 : number-blocks ( blocks -- )
-    [ >>number drop ] each-index ;
+    dup length iota <reversed>
+    [ >>number drop ] 2each ;
+
+: post-order ( cfg -- blocks )
+    dup post-order>> [ ] [
+        [
+            H{ } clone visited set
+            dup entry>> post-order-traversal
+        ] { } make dup number-blocks
+        >>post-order post-order>>
+    ] ?if ;
 
 : reverse-post-order ( cfg -- blocks )
-    H{ } clone visited [
-        post-order <reversed> dup number-blocks
-    ] with-variable ; inline
+    post-order <reversed> ; inline
 
 : each-basic-block ( cfg quot -- )
     [ reverse-post-order ] dip each ; inline
 
 : optimize-basic-block ( bb init-quot insn-quot -- )
-    [ '[ live-in keys _ call ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
-
-: local-optimization ( rpo init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- )
-    '[ _ _ optimize-basic-block ] each ;
\ No newline at end of file
+    [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index e846ebc28f..bd0e539173 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -8,7 +8,7 @@ sets ;
 IN: compiler.cfg.stack-analysis.tests
 
 ! Fundamental invariant: a basic block should not load or store a value more than once
-: check-for-redundant-ops ( rpo -- )
+: check-for-redundant-ops ( cfg -- )
     [
         instructions>>
         [
@@ -18,34 +18,36 @@ IN: compiler.cfg.stack-analysis.tests
             [ ##replace? ] filter [ loc>> ] map duplicates empty?
             [ "Redundant replaces" throw ] unless
         ] bi
-    ] each ;
+    ] each-basic-block ;
 
-: test-stack-analysis ( quot -- mr )
+: test-stack-analysis ( quot -- cfg )
     dup cfg? [ test-cfg first ] unless
-    dup compute-predecessors
-    dup delete-useless-blocks
-    dup delete-useless-conditionals
-    reverse-post-order
-    dup normalize-height
-    dup stack-analysis
-    dup check-rpo
+    compute-predecessors
+    delete-useless-blocks
+    delete-useless-conditionals
+    normalize-height
+    stack-analysis
+    dup check-cfg
     dup check-for-redundant-ops ;
 
+: linearize ( cfg -- mr )
+    build-mr instructions>> ;
+
 [ ] [ [ ] test-stack-analysis drop ] unit-test
 
 ! Only peek once
-[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize-basic-blocks [ ##peek? ] count ] unit-test
+[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
 
 ! Redundant replace is redundant
-[ f ] [ [ dup drop ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
-[ f ] [ [ swap swap ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
+[ 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-basic-blocks [ ##replace? ] any? ] unit-test
-[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
+[ 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-basic-blocks [ ##replace? ] count ] unit-test
+[ 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
@@ -63,10 +65,10 @@ IN: compiler.cfg.stack-analysis.tests
 [ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
 
 ! This should be a total no-op
-[ f ] [ [ [ ] dip ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
+[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
 
 ! Don't insert inc-d/inc-r; that's wrong!
-[ 1 ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##inc-d? ] count ] unit-test
+[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
 
 ! Bug in height tracking
 [ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
@@ -81,13 +83,13 @@ IN: compiler.cfg.stack-analysis.tests
 
 ! Make sure the replace stores a value with the right height
 [ ] [
-    [ [ . ] [ 2drop 1 ] if ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
+    [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize
     [ ##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 dup eliminate-dead-code linearize-basic-blocks
+    [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize
     [ [ ##load-immediate? ] count 2 assert= ]
     [ [ ##peek? ] count 1 assert= ]
     [ [ ##replace? ] count 3 assert= ]
@@ -95,7 +97,7 @@ IN: compiler.cfg.stack-analysis.tests
 ] unit-test
 
 [ ] [
-    [ 1 2 ? ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
+    [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize
     [ [ ##load-immediate? ] count 2 assert= ]
     [ [ ##peek? ] count 1 assert= ]
     [ [ ##replace? ] count 1 assert= ]
@@ -105,6 +107,6 @@ IN: compiler.cfg.stack-analysis.tests
 ! Sync before a back-edge, not after
 ! ##peeks should be inserted before a ##loop-entry
 [ 1 ] [
-    [ 1000 [ ] times ] test-stack-analysis dup eliminate-dead-code linearize-basic-blocks
+    [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
     [ ##add-imm? ] count
 ] unit-test
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index ffff728ece..955630a76d 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -278,10 +278,10 @@ ERROR: cannot-merge-poisoned states ;
         ] 2bi
     ] V{ } make >>instructions drop ;
 
-: stack-analysis ( rpo -- )
+: stack-analysis ( cfg -- cfg' )
     [
         H{ } clone copies set
         H{ } clone state-in set
         H{ } clone state-out set
-        [ visit-block ] each
+        dup [ visit-block ] each-basic-block
     ] with-scope ;
diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor
index dabecaeec4..d5fb1e56cf 100644
--- a/basis/compiler/cfg/two-operand/two-operand.factor
+++ b/basis/compiler/cfg/two-operand/two-operand.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: accessors arrays kernel sequences compiler.utilities
-compiler.cfg.instructions cpu.architecture ;
+USING: accessors arrays kernel sequences make compiler.cfg.instructions
+compiler.cfg.rpo cpu.architecture ;
 IN: compiler.cfg.two-operand
 
 ! On x86, instructions take the form x = x op y
@@ -11,26 +11,26 @@ IN: compiler.cfg.two-operand
 ! has a LEA instruction which is effectively a three-operand
 ! addition
 
-: make-copy ( dst src -- insn ) f \ ##copy boa ; inline
+: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline
 
-: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline
+: make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline
 
 : convert-two-operand/integer ( insn -- insns )
-    [ [ dst>> ] [ src1>> ] bi make-copy ]
-    [ dup dst>> >>src1 ]
-    bi 2array ; inline
+    [ [ dst>> ] [ src1>> ] bi ##copy ]
+    [ dup dst>> >>src1 , ]
+    bi ; inline
 
 : convert-two-operand/float ( insn -- insns )
-    [ [ dst>> ] [ src1>> ] bi make-copy/float ]
-    [ dup dst>> >>src1 ]
-    bi 2array ; inline
+    [ [ dst>> ] [ src1>> ] bi ##copy-float ]
+    [ dup dst>> >>src1 , ]
+    bi ; inline
 
-GENERIC: convert-two-operand* ( insn -- insns )
+GENERIC: convert-two-operand* ( insn -- )
 
 M: ##not convert-two-operand*
-    [ [ dst>> ] [ src>> ] bi make-copy ]
-    [ dup dst>> >>src ]
-    bi 2array ;
+    [ [ dst>> ] [ src>> ] bi ##copy ]
+    [ dup dst>> >>src , ]
+    bi ;
 
 M: ##sub convert-two-operand* convert-two-operand/integer ;
 M: ##mul convert-two-operand* convert-two-operand/integer ;
@@ -50,11 +50,13 @@ M: ##sub-float convert-two-operand* convert-two-operand/float ;
 M: ##mul-float convert-two-operand* convert-two-operand/float ;
 M: ##div-float convert-two-operand* convert-two-operand/float ;
 
-M: insn convert-two-operand* ;
+M: insn convert-two-operand* , ;
 
-: convert-two-operand ( mr -- mr' )
-    [
-        two-operand? [
-            [ convert-two-operand* ] map-flat
-        ] when
-    ] change-instructions ;
+: convert-two-operand ( cfg -- cfg' )
+    two-operand? [
+        dup [
+            [
+                [ [ convert-two-operand* ] each ] V{ } make
+            ] change-instructions drop
+        ] each-basic-block
+    ] when ;
diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
index ebc333b537..1d14cef193 100644
--- a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
+++ b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
@@ -7,5 +7,5 @@ compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
     [ [ drop 1 ] unless ]
 } [
     [ [ ] ] dip
-    '[ _ test-cfg first dup compute-predecessors dup delete-useless-blocks check-cfg ] unit-test
+    '[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
 ] each
\ No newline at end of file
diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor
index b6ec1a72ce..91c337e43a 100644
--- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor
+++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor
@@ -35,10 +35,11 @@ IN: compiler.cfg.useless-blocks
         [ instructions>> first ##branch? ]
     } 1&& ;
 
-: delete-useless-blocks ( cfg -- )
-    [
+: delete-useless-blocks ( cfg -- cfg' )
+    dup [
         dup delete-basic-block? [ delete-basic-block ] [ drop ] if
-    ] each-basic-block ;
+    ] each-basic-block
+    f >>post-order ;
 
 : delete-conditional? ( bb -- ? )
     dup instructions>> [ drop f ] [
@@ -51,10 +52,11 @@ IN: compiler.cfg.useless-blocks
 
 : delete-conditional ( bb -- )
     dup successors>> first 1vector >>successors
-    [ but-last f \ ##branch boa suffix ] change-instructions
+    [ but-last \ ##branch new-insn suffix ] change-instructions
     drop ;
 
-: delete-useless-conditionals ( cfg -- )
-    [
+: delete-useless-conditionals ( cfg -- cfg' )
+    dup [
         dup delete-conditional? [ delete-conditional ] [ drop ] if
-    ] each-basic-block ;
+    ] each-basic-block
+    f >>post-order ;
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 990543ed7a..c53a001d28 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -13,7 +13,7 @@ GENERIC: rewrite ( insn -- insn' )
 
 M: ##mul-imm rewrite
     dup src2>> dup power-of-2? [
-        [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa
+        [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
         dup number-values
     ] [ drop ] if ;
 
@@ -36,9 +36,9 @@ M: ##mul-imm rewrite
 
 : rewrite-boolean-comparison ( expr -- insn )
     src1>> vreg>expr dup op>> {
-        { \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
-        { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
-        { \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
+        { \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
+        { \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
+        { \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
     } case ;
 
 : tag-fixnum-expr? ( expr -- ? )
@@ -60,11 +60,11 @@ M: ##mul-imm rewrite
 GENERIC: rewrite-tagged-comparison ( insn -- insn' )
 
 M: ##compare-imm-branch rewrite-tagged-comparison
-    (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
+    (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
 
 M: ##compare-imm rewrite-tagged-comparison
     [ dst>> ] [ (rewrite-tagged-comparison) ] bi
-    i f \ ##compare-imm boa ;
+    i \ ##compare-imm new-insn ;
 
 M: ##compare-imm-branch rewrite
     dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
@@ -96,9 +96,9 @@ M: ##compare rewrite
 
 : rewrite-redundant-comparison ( insn -- insn' )
     [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
-        { \ ##compare [ >compare-expr< i f \ ##compare boa ] }
-        { \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
-        { \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
+        { \ ##compare [ >compare-expr< i \ ##compare new-insn ] }
+        { \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] }
+        { \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] }
     } case
     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index c771d3b388..cc62c0f0c1 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs biassocs classes kernel math accessors
 sorting sets sequences
-compiler.cfg.rpo
+compiler.cfg.liveness
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.propagate
@@ -21,5 +21,5 @@ IN: compiler.cfg.value-numbering
 : value-numbering-step ( insns -- insns' )
     [ [ number-values ] [ rewrite propagate ] bi ] map ;
 
-: value-numbering ( rpo -- )
+: value-numbering ( cfg -- cfg' )
     [ init-value-numbering ] [ value-numbering-step ] local-optimization ;
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index e4767599a7..52d5170138 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -2,7 +2,7 @@
 ! 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
-compiler.cfg.rpo ;
+compiler.cfg.liveness ;
 IN: compiler.cfg.write-barrier
 
 ! Eliminate redundant write barrier hits.
@@ -42,5 +42,5 @@ M: insn eliminate-write-barrier ;
     H{ } clone copies set
     [ eliminate-write-barrier ] map sift ;
 
-: eliminate-write-barriers ( rpo -- )
+: eliminate-write-barriers ( cfg -- cfg' )
     [ drop ] [ write-barriers-step ] local-optimization ;
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index c3d70fdc5b..ae58c3bd3e 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -8,8 +8,8 @@ stack-checker.inlining stack-checker.errors combinators.short-circuit
 compiler.errors compiler.units compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
 compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
-compiler.utilities ;
+compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.cfg.rpo
+compiler.codegen compiler.utilities ;
 IN: compiler
 
 SYMBOL: compile-queue
@@ -146,9 +146,9 @@ t compile-dependencies? set-global
 : backend ( nodes word -- )
     build-cfg [
         optimize-cfg
-        build-mr
         convert-two-operand
         linear-scan
+        build-mr
         build-stack-frame
         generate
         save-asm

From 3e00dc8c8d075aa95271eca21c1782f94045ae20 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 30 May 2009 13:22:30 -0500
Subject: [PATCH 30/46] Start cleaning up stack analysis

---
 .../cfg/stack-analysis/stack-analysis.factor  | 65 +++++++++----------
 1 file changed, 32 insertions(+), 33 deletions(-)

diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index 955630a76d..dfc99883c4 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -88,21 +88,19 @@ GENERIC: visit ( insn -- )
 UNION: neutral-insn
     ##flushable
     ##effect
-    ##branch
-    ##loop-entry
-    ##conditional-branch
-    ##compare-imm-branch
-    ##dispatch ;
+    ##loop-entry ;
 
 M: neutral-insn visit , ;
 
 UNION: sync-if-back-edge
     ##branch
     ##conditional-branch
-    ##compare-imm-branch ;
+    ##compare-imm-branch
+    ##dispatch ;
 
 M: sync-if-back-edge visit
-    basic-block get [ successors>> ] [ number>> ] bi '[ number>> _ < ] any?
+    basic-block get [ successors>> ] [ number>> ] bi
+    '[ number>> _ < ] any?
     [ sync-state ] when
     , ;
 
@@ -173,8 +171,9 @@ M: ##alien-callback visit , ;
 ! Maps basic-blocks to states
 SYMBOLS: state-in state-out ;
 
-: with-state ( state quot -- )
-    [ state ] dip with-variable ; inline
+: initial-state ( bb states -- state ) 2drop <state> ;
+
+: single-predecessor ( bb states -- state ) nip first clone ;
 
 ERROR: must-equal-failed seq ;
 
@@ -225,32 +224,32 @@ ERROR: must-equal-failed seq ;
 
 ERROR: cannot-merge-poisoned states ;
 
+: multiple-predecessors ( bb states -- state )
+    dup [ not ] any? [
+        [ <state> ] 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 [ 2drop <state> ] }
-        { 1 [ nip first clone ] }
-        [
-            drop
-            dup [ not ] any? [
-                [ <state> ] 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
-        ]
+        { 0 [ initial-state ] }
+        { 1 [ single-predecessor ] }
+        [ drop multiple-predecessors ]
     } case ;
 
 : block-in-state ( bb -- states )
@@ -269,12 +268,12 @@ ERROR: cannot-merge-poisoned states ;
         dup basic-block set
         dup block-in-state
         [ swap set-block-in-state ] [
-            [
+            state [
                 [ instructions>> [ visit ] each ]
                 [ [ state get ] dip set-block-out-state ]
                 [ ]
                 tri
-            ] with-state
+            ] with-variable
         ] 2bi
     ] V{ } make >>instructions drop ;
 

From ae75b41a43db09d4504170f205d1801e081f92b9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 31 May 2009 08:53:42 -0500
Subject: [PATCH 31/46] clean up some stack shuffling

---
 extra/cursors/cursors.factor | 56 +++++++++++++++++++-----------------
 1 file changed, 29 insertions(+), 27 deletions(-)

diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor
index 059129f22e..11b9bf4bf4 100644
--- a/extra/cursors/cursors.factor
+++ b/extra/cursors/cursors.factor
@@ -12,31 +12,32 @@ GENERIC: cursor-write ( obj cursor -- )
 ERROR: cursor-ended cursor ;
 
 : cursor-get ( cursor -- obj )
-   dup cursor-done?
-   [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
+    dup cursor-done?
+    [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
 
-: find-done? ( quot cursor -- ? )
-   dup cursor-done? [ 2drop t ] [ cursor-get-unsafe swap call ] if ; inline
-
-: cursor-until ( quot cursor -- )
-   [ find-done? not ]
-   [ cursor-advance drop ] bi-curry bi-curry while ; inline
+: find-done? ( cursor quot -- ? )
+    over cursor-done?
+    [ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline
 
+: cursor-until ( cursor quot -- )
+    [ find-done? not ]
+    [ drop cursor-advance ] bi-curry bi-curry while ; inline
+ 
 : cursor-each ( cursor quot -- )
-   [ f ] compose swap cursor-until ; inline
+    [ f ] compose cursor-until ; inline
 
 : cursor-find ( cursor quot -- obj ? )
-   swap [ cursor-until ] keep
-   dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
+    [ cursor-until ] [ drop ] 2bi
+    dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
 
 : cursor-any? ( cursor quot -- ? )
-   cursor-find nip ; inline
+    cursor-find nip ; inline
 
 : cursor-all? ( cursor quot -- ? )
-   [ not ] compose cursor-any? not ; inline
+    [ not ] compose cursor-any? not ; inline
 
 : cursor-map-quot ( quot to -- quot' )
-   [ [ call ] dip cursor-write ] 2curry ; inline
+    [ [ call ] dip cursor-write ] 2curry ; inline
 
 : cursor-map ( from to quot -- )
    swap cursor-map-quot cursor-each ; inline
@@ -46,10 +47,10 @@ ERROR: cursor-ended cursor ;
     [ cursor-write ] 2curry when ; inline
 
 : cursor-filter-quot ( quot to -- quot' )
-   [ cursor-write-if ] 2curry ; inline
+    [ cursor-write-if ] 2curry ; inline
 
 : cursor-filter ( from to quot -- )
-   swap cursor-filter-quot cursor-each ; inline
+    swap cursor-filter-quot cursor-each ; inline
 
 TUPLE: from-sequence { seq sequence } { n integer } ;
 
@@ -60,19 +61,19 @@ M: from-sequence cursor-done? ( cursor -- ? )
     >from-sequence< length >= ;
 
 M: from-sequence cursor-valid?
-   >from-sequence< bounds-check? not ;
+    >from-sequence< bounds-check? not ;
 
 M: from-sequence cursor-get-unsafe
-   >from-sequence< nth-unsafe ;
+    >from-sequence< nth-unsafe ;
 
 M: from-sequence cursor-advance
-   [ 1+ ] change-n drop ;
+    [ 1+ ] change-n drop ;
 
 : >input ( seq -- cursor )
-   0 from-sequence boa ; inline
+    0 from-sequence boa ; inline
 
 : iterate ( seq quot iterator -- )
-   [ >input ] 2dip call ; inline
+    [ >input ] 2dip call ; inline
 
 : each ( seq quot -- ) [ cursor-each ] iterate ; inline
 : find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
@@ -82,18 +83,19 @@ M: from-sequence cursor-advance
 TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
 
 M: to-sequence cursor-write
-   seq>> push ;
+    seq>> push ;
 
 : freeze ( cursor -- seq )
-   [ seq>> ] [ exemplar>> ] bi like ; inline
+    [ seq>> ] [ exemplar>> ] bi like ; inline
 
 : >output ( seq -- cursor )
-   [ [ length ] keep new-resizable ] keep
-   to-sequence boa ; inline
+    [ [ length ] keep new-resizable ] keep
+    to-sequence boa ; inline
 
 : transform ( seq quot transformer -- newseq )
-   [ [ >input ] [ >output ] bi ] 2dip
-   [ call ] [ 2drop freeze ] 3bi ; inline
+    [ [ >input ] [ >output ] bi ] 2dip
+    [ call ]
+    [ 2drop freeze ] 3bi ; inline
 
 : map ( seq quot -- ) [ cursor-map ] transform ; inline
 : filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline

From 692b479302c01285c6a9acb7ef95c635da658b60 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 May 2009 12:20:46 -0500
Subject: [PATCH 32/46] Split off local-optimization combinator into
 compiler.cfg.local, factor out CFG -> MR into compiler.cfg.mr, split off GC
 check insertion into a new compiler.cfg.gc-checks pass

---
 .../cfg/alias-analysis/alias-analysis.factor  |  2 +-
 basis/compiler/cfg/checker/checker.factor     |  2 +-
 basis/compiler/cfg/debugger/debugger.factor   | 11 +++------
 basis/compiler/cfg/def-use/def-use.factor     |  4 +++-
 basis/compiler/cfg/gc-checks/authors.txt      |  1 +
 basis/compiler/cfg/gc-checks/gc-checks.factor | 22 +++++++++++++++++
 basis/compiler/cfg/height/height.factor       |  2 +-
 .../cfg/linearization/linearization.factor    | 16 +++----------
 basis/compiler/cfg/liveness/liveness.factor   |  3 ---
 basis/compiler/cfg/local/authors.txt          |  1 +
 basis/compiler/cfg/local/local.factor         | 10 ++++++++
 basis/compiler/cfg/mr/authors.txt             |  1 +
 basis/compiler/cfg/mr/mr.factor               | 14 +++++++++++
 basis/compiler/cfg/rpo/rpo.factor             |  3 ---
 .../stack-analysis-tests.factor               |  2 +-
 .../cfg/stack-analysis/stack-analysis.factor  |  6 ++++-
 .../value-numbering/value-numbering.factor    |  1 +
 .../cfg/write-barrier/write-barrier.factor    |  2 +-
 basis/compiler/compiler.factor                | 24 +++++++++++--------
 19 files changed, 83 insertions(+), 44 deletions(-)
 create mode 100644 basis/compiler/cfg/gc-checks/authors.txt
 create mode 100644 basis/compiler/cfg/gc-checks/gc-checks.factor
 create mode 100644 basis/compiler/cfg/local/authors.txt
 create mode 100644 basis/compiler/cfg/local/local.factor
 create mode 100644 basis/compiler/cfg/mr/authors.txt
 create mode 100644 basis/compiler/cfg/mr/mr.factor

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 384fd65c1a..2385a4c65a 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -4,7 +4,7 @@ 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.rpo
-compiler.cfg.liveness ;
+compiler.cfg.liveness compiler.cfg.local ;
 IN: compiler.cfg.alias-analysis
 
 ! We try to eliminate redundant slot operations using some simple heuristics.
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index bf5adc2d55..b0a279c11b 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -54,5 +54,5 @@ ERROR: undefined-values uses defs ;
     compute-liveness
     [ entry>> live-in assoc-empty? [ bad-live-in ] unless ]
     [ [ check-basic-block ] each-basic-block ]
-    [ build-mr check-mr ]
+    [ flatten-cfg check-mr ]
     tri ;
diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 5c106bfaee..cb56937758 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -7,7 +7,8 @@ parser compiler.tree.builder compiler.tree.optimizer
 compiler.cfg.builder compiler.cfg.linearization
 compiler.cfg.registers compiler.cfg.stack-frame
 compiler.cfg.linear-scan compiler.cfg.two-operand
-compiler.cfg.optimizer ;
+compiler.cfg.liveness compiler.cfg.optimizer
+compiler.cfg.mr ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -18,20 +19,14 @@ M: callable test-cfg
 M: word test-cfg
     [ build-tree optimize-tree ] keep build-cfg ;
 
-SYMBOL: allocate-registers?
-
 : test-mr ( quot -- mrs )
     test-cfg [
         optimize-cfg
-        convert-two-operand
-        allocate-registers? get [ linear-scan ] when
         build-mr
-        allocate-registers? get [ build-stack-frame ] when
     ] map ;
 
 : insn. ( insn -- )
-    tuple>array allocate-registers? get [ but-last ] unless
-    [ pprint bl ] each nl ;
+    tuple>array [ pprint bl ] each nl ;
 
 : mr. ( mrs -- )
     [
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 17e49f59a8..28351ca7b2 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -54,6 +54,7 @@ M: ##phi uses-vregs inputs>> ;
 M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: _dispatch uses-vregs src>> 1array ;
+M: _gc uses-vregs live-in>> ;
 M: insn uses-vregs drop f ;
 
 ! Instructions that use vregs
@@ -67,4 +68,5 @@ UNION: vreg-insn
 ##compare-imm-branch
 _conditional-branch
 _compare-imm-branch
-_dispatch ;
+_dispatch
+_gc ;
diff --git a/basis/compiler/cfg/gc-checks/authors.txt b/basis/compiler/cfg/gc-checks/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/gc-checks/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor
new file mode 100644
index 0000000000..7a47da00a8
--- /dev/null
+++ b/basis/compiler/cfg/gc-checks/gc-checks.factor
@@ -0,0 +1,22 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences assocs
+cpu.architecture compiler.cfg.rpo
+compiler.cfg.liveness compiler.cfg.instructions ;
+IN: compiler.cfg.gc-checks
+
+: gc? ( bb -- ? )
+    instructions>> [ ##allocation? ] any? ;
+
+: object-pointer-regs ( basic-block -- vregs )
+    live-in keys [ reg-class>> int-regs eq? ] filter ;
+
+: insert-gc-check ( basic-block -- )
+    dup gc? [
+        dup
+        [ swap object-pointer-regs \ _gc new-insn suffix ]
+        change-instructions drop
+    ] [ drop ] if ;
+
+: insert-gc-checks ( cfg -- cfg' )
+    dup [ insert-gc-check ] each-basic-block ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
index b91120ccfd..14a0a54715 100644
--- a/basis/compiler/cfg/height/height.factor
+++ b/basis/compiler/cfg/height/height.factor
@@ -2,7 +2,7 @@
 ! 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.liveness ;
+compiler.cfg.liveness compiler.cfg.local ;
 IN: compiler.cfg.height
 
 ! Combine multiple stack height changes into one at the
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 5ad8be2953..2e09e493db 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -12,20 +12,10 @@ IN: compiler.cfg.linearization
 ! Convert CFG IR to machine IR.
 GENERIC: linearize-insn ( basic-block insn -- )
 
-: linearize-insns ( bb insns -- )
-    dup instructions>> [ linearize-insn ] with each ;
-
-: gc? ( bb -- ? )
-    instructions>> [ ##allocation? ] any? ;
-
-: object-pointer-regs ( basic-block -- vregs )
-    live-in keys [ reg-class>> int-regs eq? ] filter ;
-
 : linearize-basic-block ( bb -- )
     [ number>> _label ]
-    [ dup gc? [ object-pointer-regs _gc ] [ drop ] if ]
-    [ linearize-insns ]
-    tri ;
+    [ dup instructions>> [ linearize-insn ] with each ]
+    bi ;
 
 M: insn linearize-insn , drop ;
 
@@ -85,6 +75,6 @@ M: ##dispatch linearize-insn
         bi
     ] { } make ;
 
-: build-mr ( cfg -- mr )
+: flatten-cfg ( cfg -- mr )
     [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
     <mr> ;
diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor
index 72609cf4d9..6c40bb3782 100644
--- a/basis/compiler/cfg/liveness/liveness.factor
+++ b/basis/compiler/cfg/liveness/liveness.factor
@@ -76,6 +76,3 @@ SYMBOL: work-list
     H{ } clone live-outs set
     dup post-order add-to-work-list
     work-list get [ liveness-step ] slurp-deque ;
-
-: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
-    [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/local/authors.txt b/basis/compiler/cfg/local/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/local/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/local/local.factor b/basis/compiler/cfg/local/local.factor
new file mode 100644
index 0000000000..bf336a8d2a
--- /dev/null
+++ b/basis/compiler/cfg/local/local.factor
@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ;
+IN: compiler.cfg.local
+
+: optimize-basic-block ( bb init-quot insn-quot -- )
+    [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
+
+: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
+    [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ;
diff --git a/basis/compiler/cfg/mr/authors.txt b/basis/compiler/cfg/mr/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/mr/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor
new file mode 100644
index 0000000000..49f7c793e5
--- /dev/null
+++ b/basis/compiler/cfg/mr/mr.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg.linearization compiler.cfg.two-operand
+compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan
+compiler.cfg.stack-frame compiler.cfg.rpo ;
+IN: compiler.cfg.mr
+
+: build-mr ( cfg -- mr )
+    convert-two-operand
+    compute-liveness
+    insert-gc-checks
+    linear-scan
+    flatten-cfg
+    build-stack-frame ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index d01f5ee864..c6ea2ee8b1 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/basis/compiler/cfg/rpo/rpo.factor
@@ -34,6 +34,3 @@ SYMBOL: visited
 
 : each-basic-block ( cfg quot -- )
     [ reverse-post-order ] dip each ; inline
-
-: optimize-basic-block ( bb init-quot insn-quot -- )
-    [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index bd0e539173..383bd2e637 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -31,7 +31,7 @@ IN: compiler.cfg.stack-analysis.tests
     dup check-for-redundant-ops ;
 
 : linearize ( cfg -- mr )
-    build-mr instructions>> ;
+    flatten-cfg instructions>> ;
 
 [ ] [ [ ] test-stack-analysis drop ] unit-test
 
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index dfc99883c4..c1ed2615c3 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -98,9 +98,13 @@ UNION: sync-if-back-edge
     ##compare-imm-branch
     ##dispatch ;
 
+SYMBOL: local-only?
+
+t local-only? set-global
+
 M: sync-if-back-edge visit
     basic-block get [ successors>> ] [ number>> ] bi
-    '[ number>> _ < ] any?
+    '[ number>> _ < local-only? get or ] any?
     [ sync-state ] when
     , ;
 
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index cc62c0f0c1..9f5473c62f 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/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.local
 compiler.cfg.liveness
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index 52d5170138..b260b0464e 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -2,7 +2,7 @@
 ! 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
-compiler.cfg.liveness ;
+compiler.cfg.liveness compiler.cfg.local ;
 IN: compiler.cfg.write-barrier
 
 ! Eliminate redundant write barrier hits.
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index ae58c3bd3e..eee00bfccb 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -3,13 +3,20 @@
 USING: accessors kernel namespaces arrays sequences io words fry
 continuations vocabs assocs dlists definitions math graphs generic
 generic.single combinators deques search-deques macros
-source-files.errors stack-checker stack-checker.state
-stack-checker.inlining stack-checker.errors combinators.short-circuit
-compiler.errors compiler.units compiler.tree.builder
-compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
-compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.cfg.rpo
-compiler.codegen compiler.utilities ;
+source-files.errors combinators.short-circuit
+
+stack-checker stack-checker.state stack-checker.inlining stack-checker.errors
+
+compiler.errors compiler.units compiler.utilities
+
+compiler.tree.builder
+compiler.tree.optimizer
+
+compiler.cfg.builder
+compiler.cfg.optimizer
+compiler.cfg.mr
+
+compiler.codegen ;
 IN: compiler
 
 SYMBOL: compile-queue
@@ -146,10 +153,7 @@ t compile-dependencies? set-global
 : backend ( nodes word -- )
     build-cfg [
         optimize-cfg
-        convert-two-operand
-        linear-scan
         build-mr
-        build-stack-frame
         generate
         save-asm
     ] each ;

From 1a52414bb1090f2e5fabff078c5c9f49880cf4d8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 May 2009 18:21:11 -0500
Subject: [PATCH 33/46] Rename _gc to ##gc

---
 basis/compiler/cfg/def-use/def-use.factor           | 7 ++++---
 basis/compiler/cfg/gc-checks/gc-checks.factor       | 2 +-
 basis/compiler/cfg/instructions/instructions.factor | 4 ++--
 basis/compiler/cfg/stack-frame/stack-frame.factor   | 2 +-
 4 files changed, 8 insertions(+), 7 deletions(-)

diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 28351ca7b2..1484b3ec72 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -51,10 +51,10 @@ M: ##alien-getter uses-vregs src>> 1array ;
 M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
 M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: ##phi uses-vregs inputs>> ;
+M: ##gc uses-vregs live-in>> ;
 M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: _dispatch uses-vregs src>> 1array ;
-M: _gc uses-vregs live-in>> ;
 M: insn uses-vregs drop f ;
 
 ! Instructions that use vregs
@@ -66,7 +66,8 @@ UNION: vreg-insn
 ##fixnum-overflow
 ##conditional-branch
 ##compare-imm-branch
+##phi
+##gc
 _conditional-branch
 _compare-imm-branch
-_dispatch
-_gc ;
+_dispatch ;
diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor
index 7a47da00a8..91e79ea2dd 100644
--- a/basis/compiler/cfg/gc-checks/gc-checks.factor
+++ b/basis/compiler/cfg/gc-checks/gc-checks.factor
@@ -14,7 +14,7 @@ IN: compiler.cfg.gc-checks
 : insert-gc-check ( basic-block -- )
     dup gc? [
         dup
-        [ swap object-pointer-regs \ _gc new-insn suffix ]
+        [ swap object-pointer-regs \ ##gc new-insn prefix ]
         change-instructions drop
     ] [ drop ] if ;
 
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index d2d444a4a5..314a66ba9c 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -223,14 +223,14 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
 INSN: ##compare-float-branch < ##conditional-branch ;
 INSN: ##compare-float < ##binary cc temp ;
 
+INSN: ##gc live-in ;
+
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;
 INSN: _epilogue stack-frame ;
 
 INSN: _label id ;
 
-INSN: _gc live-in ;
-
 INSN: _branch label ;
 
 INSN: _dispatch src temp ;
diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index d545b6d15c..fd11260f97 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -32,8 +32,8 @@ M: insn compute-stack-frame*
         frame-required? on
     ] when ;
 
-\ _gc t frame-required? set-word-prop
 \ _spill t frame-required? set-word-prop
+\ ##gc t frame-required? set-word-prop
 \ ##fixnum-add t frame-required? set-word-prop
 \ ##fixnum-sub t frame-required? set-word-prop
 \ ##fixnum-mul t frame-required? set-word-prop

From 32f17f3e14e009e2e841318ef524f870cd5cd037 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 May 2009 18:21:23 -0500
Subject: [PATCH 34/46] Fix scoping issue in
 compiler.cfg.linear-scan.assignment

---
 .../cfg/linear-scan/assignment/assignment.factor | 16 +++++++++-------
 1 file changed, 9 insertions(+), 7 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index f21b9e5db8..c7e3380f83 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -13,13 +13,13 @@ IN: compiler.cfg.linear-scan.assignment
 ! but since we never have too many machine registers (around 30
 ! at most) and we probably won't have that many live at any one
 ! time anyway, it is not a problem to check each element.
-SYMBOL: active-intervals
+TUPLE: active-intervals seq ;
 
 : add-active ( live-interval -- )
-    active-intervals get push ;
+    active-intervals get seq>> push ;
 
 : lookup-register ( vreg -- reg )
-    active-intervals get [ vreg>> = ] with find nip reg>> ;
+    active-intervals get seq>> [ vreg>> = ] with find nip reg>> ;
 
 ! Minheap of live intervals which still need a register allocation
 SYMBOL: unhandled-intervals
@@ -41,8 +41,7 @@ SYMBOL: unhandled-intervals
 
 : expire-old-intervals ( n -- )
     active-intervals get
-    swap '[ end>> _ = ] partition
-    active-intervals set
+    [ swap '[ end>> _ = ] partition ] change-seq drop
     [ insert-spill ] each ;
 
 : insert-reload ( live-interval -- )
@@ -65,14 +64,17 @@ GENERIC: assign-registers-in-insn ( insn -- )
     [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
 
 M: vreg-insn assign-registers-in-insn
-    active-intervals get over all-vregs '[ vreg>> _ member? ] filter
+    active-intervals get seq>> over all-vregs '[ vreg>> _ member? ] filter
     [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
     >>regs drop ;
 
 M: insn assign-registers-in-insn drop ;
 
+: <active-intervals> ( -- obj )
+    V{ } clone active-intervals boa ;
+
 : init-assignment ( live-intervals -- )
-    V{ } clone active-intervals set
+    <active-intervals> active-intervals set
     <min-heap> unhandled-intervals set
     init-unhandled ;
 

From 2c8223fdaf259aa6aa1de1248d4d848ec227b863 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 May 2009 19:04:26 -0500
Subject: [PATCH 35/46] Fix loop handling in stack-analysis

---
 .../cfg/optimizer/optimizer-tests.factor      |  1 +
 .../stack-analysis-tests.factor               |  5 +++--
 .../cfg/stack-analysis/stack-analysis.factor  | 19 ++++++++++++-------
 3 files changed, 16 insertions(+), 9 deletions(-)

diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
index 923fe828b5..b95a8c79ea 100644
--- a/basis/compiler/cfg/optimizer/optimizer-tests.factor
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -28,6 +28,7 @@ IN: compiler.cfg.optimizer.tests
     [ [ 2 fixnum* ] when 3 ]
     [ [ 2 fixnum+ ] when 3 ]
     [ [ 2 fixnum- ] when 3 ]
+    [ 10000 [ ] times ]
 } [
     [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
 ] each
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index 383bd2e637..4455d5e208 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -106,7 +106,8 @@ IN: compiler.cfg.stack-analysis.tests
 
 ! Sync before a back-edge, not after
 ! ##peeks should be inserted before a ##loop-entry
-[ 1 ] [
+! Don't optimize out the constants
+[ 1 t ] [
     [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
-    [ ##add-imm? ] count
+    [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
 ] unit-test
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index c1ed2615c3..4ebdf7012f 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -87,8 +87,7 @@ GENERIC: visit ( insn -- )
 ! Instructions which don't have any effect on the stack
 UNION: neutral-insn
     ##flushable
-    ##effect
-    ##loop-entry ;
+    ##effect ;
 
 M: neutral-insn visit , ;
 
@@ -96,17 +95,23 @@ UNION: sync-if-back-edge
     ##branch
     ##conditional-branch
     ##compare-imm-branch
-    ##dispatch ;
+    ##dispatch
+    ##loop-entry ;
 
 SYMBOL: local-only?
 
 t local-only? set-global
 
+: back-edge? ( from to -- ? )
+    [ number>> ] bi@ > ;
+
+: sync-state? ( -- ? )
+    basic-block get successors>>
+    [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
+    local-only? get or ;
+
 M: sync-if-back-edge visit
-    basic-block get [ successors>> ] [ number>> ] bi
-    '[ number>> _ < local-only? get or ] any?
-    [ sync-state ] when
-    , ;
+    sync-state? [ sync-state ] when , ;
 
 : adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
 

From fc152ef2102f1560b0a750397622b1d106c2bbbc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 May 2009 23:28:08 -0500
Subject: [PATCH 36/46] Various improvements aimed at getting local
 optimization regressions fixed: - Rename _gc to ##gc - Absolute labels are
 now supported - Generate _dispatch-label

---
 basis/compiler/codegen/codegen.factor      |  7 +++--
 basis/compiler/codegen/fixup/fixup.factor  | 35 ++++++++++++----------
 basis/cpu/architecture/architecture.factor |  1 +
 basis/cpu/x86/x86.factor                   |  3 ++
 vm/code_block.cpp                          |  2 +-
 5 files changed, 29 insertions(+), 19 deletions(-)

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 11b4e153f6..223fc8edff 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -92,9 +92,12 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
 
 M: ##return generate-insn drop %return ;
 
-M: ##dispatch generate-insn
+M: _dispatch generate-insn
     [ src>> register ] [ temp>> register ] bi %dispatch ;
 
+M: _dispatch-label generate-insn
+    label>> lookup-label %dispatch-label ;
+
 : >slot< ( insn -- dst obj slot tag )
     {
         [ dst>> register ]
@@ -234,7 +237,7 @@ M: ##write-barrier generate-insn
     [ table>> register ]
     tri %write-barrier ;
 
-M: _gc generate-insn drop %gc ;
+M: ##gc generate-insn drop %gc ;
 
 M: ##loop-entry generate-insn drop %loop-entry ;
 
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index d0c874feb0..bd1364dde1 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -16,30 +16,33 @@ SYMBOL: label-table
 
 M: label fixup* compiled-offset >>offset drop ;
 
-TUPLE: label-fixup label class ;
+: offset-for-class ( class -- n )
+    rc-absolute-cell = cell 4 ? compiled-offset swap - ;
+
+TUPLE: label-fixup { label label } { class integer } ;
 
 : label-fixup ( label class -- ) \ label-fixup boa , ;
 
-M: label-fixup fixup*
-    dup class>> rc-absolute?
-    [ "Absolute labels not supported" throw ] when
-    [ class>> ] [ label>> ] bi compiled-offset 4 - swap
-    3array label-table get push ;
-
-TUPLE: rel-fixup class type ;
-
-: rel-fixup ( class type -- ) \ rel-fixup boa , ;
-
 : push-4 ( value vector -- )
     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
     swap set-alien-unsigned-4 ;
 
+: add-relocation-entry ( type class offset -- )
+      { 0 24 28 } bitfield relocation-table get push-4 ;
+
+M: label-fixup fixup*
+    [ class>> dup offset-for-class ] [ label>> ] bi
+    [ drop [ rt-here ] 2dip add-relocation-entry ]
+    [ 3array label-table get push ]
+    3bi ;
+
+TUPLE: rel-fixup { class integer } { type integer } ;
+
+: rel-fixup ( class type -- ) \ rel-fixup boa , ;
+
 M: rel-fixup fixup*
-    [ type>> ]
-    [ class>> ]
-    [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
-    { 0 24 28 } bitfield
-    relocation-table get push-4 ;
+    [ type>> ] [ class>> dup offset-for-class ] bi
+    add-relocation-entry ;
 
 M: integer fixup* , ;
 
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 98d0c5326b..e0e4343a60 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -52,6 +52,7 @@ HOOK: %jump-label cpu ( label -- )
 HOOK: %return cpu ( -- )
 
 HOOK: %dispatch cpu ( src temp -- )
+HOOK: %dispatch-label cpu ( src temp -- )
 
 HOOK: %slot cpu ( dst obj slot tag temp -- )
 HOOK: %slot-imm cpu ( dst obj slot tag -- )
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 8ab247f5e5..24832ac227 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -79,6 +79,9 @@ M: x86 %return ( -- ) 0 RET ;
 : align-code ( n -- )
     0 <repetition> % ;
 
+M: x86 %dispatch-label ( label -- )
+    0 cell, rc-absolute-cell label-fixup ;
+
 :: (%slot) ( obj slot tag temp -- op )
     temp slot obj [+] LEA
     temp tag neg [+] ; inline
diff --git a/vm/code_block.cpp b/vm/code_block.cpp
index 2ce69ebfde..050e154c28 100755
--- a/vm/code_block.cpp
+++ b/vm/code_block.cpp
@@ -159,7 +159,7 @@ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
 	case RT_XT_PIC_TAIL:
 		return (cell)word_xt_pic_tail(untag<word>(ARG));
 	case RT_HERE:
-		return offset + (short)untag_fixnum(ARG);
+		return offset + untag_fixnum(ARG);
 	case RT_THIS:
 		return (cell)(compiled + 1);
 	case RT_STACK_CHAIN:

From b389dcf441bd5da76d004a7bfa6c3432c7bc90ae Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Jun 2009 02:32:36 -0500
Subject: [PATCH 37/46] Redo compiler.codegen.fixup and get %dispatch to work

---
 basis/compiler/codegen/codegen-tests.factor | 14 ++++
 basis/compiler/codegen/codegen.factor       | 25 +++---
 basis/compiler/codegen/fixup/fixup.factor   | 91 +++++++++++----------
 basis/cpu/architecture/architecture.factor  |  9 +-
 basis/cpu/x86/x86.factor                    |  2 +-
 vm/code_block.cpp                           |  5 +-
 6 files changed, 81 insertions(+), 65 deletions(-)
 create mode 100644 basis/compiler/codegen/codegen-tests.factor

diff --git a/basis/compiler/codegen/codegen-tests.factor b/basis/compiler/codegen/codegen-tests.factor
new file mode 100644
index 0000000000..9c3817bad6
--- /dev/null
+++ b/basis/compiler/codegen/codegen-tests.factor
@@ -0,0 +1,14 @@
+IN: compiler.codegen.tests
+USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
+compiler.constants ;
+
+[ ] [ [ ] with-fixup drop ] unit-test
+[ ] [ [ \ + %call ] with-fixup drop ] unit-test
+
+[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
+[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
+
+! Error checking
+[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 223fc8edff..3962902c62 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -26,14 +26,6 @@ SYMBOL: registers
 : ?register ( obj -- operand )
     dup vreg? [ register ] when ;
 
-: generate-insns ( insns -- code )
-    [
-        [
-            dup regs>> registers set
-            generate-insn
-        ] each
-    ] { } make fixup ;
-
 TUPLE: asm label code calls ;
 
 SYMBOL: calls
@@ -51,17 +43,22 @@ SYMBOL: labels
 
 : init-generator ( word -- )
     H{ } clone labels set
-    V{ } clone literal-table set
     V{ } clone calls set
     compiling-word set
     compiled-stack-traces? [ compiling-word get add-literal ] when ;
 
+: generate-insns ( asm -- code )
+    [
+        [ word>> init-generator ]
+        [
+            instructions>>
+            [ [ regs>> registers set ] [ generate-insn ] bi ] each
+        ] bi
+    ] with-fixup ;
+
 : generate ( mr -- asm )
     [
-        [ label>> ]
-        [ word>> init-generator ]
-        [ instructions>> generate-insns ] tri
-        calls get
+        [ label>> ] [ generate-insns ] bi calls get
         asm boa
     ] with-scope ;
 
@@ -487,7 +484,7 @@ M: _epilogue generate-insn
     stack-frame>> total-size>> %epilogue ;
 
 M: _label generate-insn
-    id>> lookup-label , ;
+    id>> lookup-label resolve-label ;
 
 M: _branch generate-insn
     label>> lookup-label %jump-label ;
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index bd1364dde1..5520508788 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -4,51 +4,48 @@ USING: arrays byte-arrays byte-vectors generic assocs hashtables
 io.binary kernel kernel.private math namespaces make sequences
 words quotations strings alien.accessors alien.strings layouts
 system combinators math.bitwise math.order
-accessors growable cpu.architecture compiler.constants ;
+accessors growable compiler.constants ;
 IN: compiler.codegen.fixup
 
-GENERIC: fixup* ( obj -- )
+! Literal table
+SYMBOL: literal-table
+
+: add-literal ( obj -- ) literal-table get push ;
+
+! Labels
+SYMBOL: label-table
+
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
 
 : compiled-offset ( -- n ) building get length ;
 
-SYMBOL: relocation-table
-SYMBOL: label-table
-
-M: label fixup* compiled-offset >>offset drop ;
+: resolve-label ( label/name -- )
+    dup label? [ get ] unless
+    compiled-offset >>offset drop ;
 
 : offset-for-class ( class -- n )
     rc-absolute-cell = cell 4 ? compiled-offset swap - ;
 
-TUPLE: label-fixup { label label } { class integer } ;
+TUPLE: label-fixup { label label } { class integer } { offset integer } ;
 
-: label-fixup ( label class -- ) \ label-fixup boa , ;
+: label-fixup ( label class -- )
+    dup offset-for-class \ label-fixup boa label-table get push ;
+
+! Relocation table
+SYMBOL: relocation-table
 
 : push-4 ( value vector -- )
     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
     swap set-alien-unsigned-4 ;
 
 : add-relocation-entry ( type class offset -- )
-      { 0 24 28 } bitfield relocation-table get push-4 ;
+    { 0 24 28 } bitfield relocation-table get push-4 ;
 
-M: label-fixup fixup*
-    [ class>> dup offset-for-class ] [ label>> ] bi
-    [ drop [ rt-here ] 2dip add-relocation-entry ]
-    [ 3array label-table get push ]
-    3bi ;
-
-TUPLE: rel-fixup { class integer } { type integer } ;
-
-: rel-fixup ( class type -- ) \ rel-fixup boa , ;
-
-M: rel-fixup fixup*
-    [ type>> ] [ class>> dup offset-for-class ] bi
-    add-relocation-entry ;
-
-M: integer fixup* , ;
-
-SYMBOL: literal-table
-
-: add-literal ( obj -- ) literal-table get push ;
+: rel-fixup ( class type -- )
+    swap dup offset-for-class add-relocation-entry ;
 
 : add-dlsym-literals ( symbol dll -- )
     [ string>symbol add-literal ] [ add-literal ] bi* ;
@@ -77,22 +74,34 @@ SYMBOL: literal-table
 : rel-here ( offset class -- )
     [ add-literal ] dip rt-here rel-fixup ;
 
+! And the rest
+: resolve-offset ( label-fixup -- offset )
+    label>> offset>> [ "Unresolved label" throw ] unless* ;
+
+: resolve-absolute-label ( label-fixup -- )
+    dup resolve-offset neg add-literal
+    [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
+
+: resolve-relative-label ( label-fixup -- )
+    [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
+
+: resolve-labels ( label-fixups -- labels' )
+    [ class>> rc-absolute? ] partition
+    [ [ resolve-absolute-label ] each ]
+    [ [ resolve-relative-label ] map concat ]
+    bi* ;
+
 : init-fixup ( -- )
-    BV{ } clone relocation-table set
-    V{ } clone label-table set ;
+    V{ } clone literal-table set
+    V{ } clone label-table set
+    BV{ } clone relocation-table set ;
 
-: resolve-labels ( labels -- labels' )
-    [
-        first3 offset>>
-        [ "Unresolved label" throw ] unless*
-        3array
-    ] map concat ;
-
-: fixup ( fixup-directives -- code )
+: with-fixup ( quot -- code )
     [
         init-fixup
-        [ fixup* ] each
+        call
+        label-table [ resolve-labels ] change
         literal-table get >array
         relocation-table get >byte-array
-        label-table get resolve-labels
-    ] B{ } make 4array ;
+        label-table get
+    ] B{ } make 4array ; inline
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index e0e4343a60..f7f91524c3 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -5,13 +5,6 @@ memory namespaces make sequences layouts system hashtables
 classes alien byte-arrays combinators words sets fry ;
 IN: cpu.architecture
 
-! Labels
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-: define-label ( name -- ) <label> swap set ;
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
 ! Register classes
 SINGLETON: int-regs
 SINGLETON: single-float-regs
@@ -52,7 +45,7 @@ HOOK: %jump-label cpu ( label -- )
 HOOK: %return cpu ( -- )
 
 HOOK: %dispatch cpu ( src temp -- )
-HOOK: %dispatch-label cpu ( src temp -- )
+HOOK: %dispatch-label cpu ( label -- )
 
 HOOK: %slot cpu ( dst obj slot tag temp -- )
 HOOK: %slot-imm cpu ( dst obj slot tag -- )
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 24832ac227..1a2c2e3ee1 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -74,7 +74,7 @@ M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
 M: x86 %return ( -- ) 0 RET ;
 
 : code-alignment ( align -- n )
-    [ building get [ integer? ] count dup ] dip align swap - ;
+    [ building get length dup ] dip align swap - ;
 
 : align-code ( n -- )
     0 <repetition> % ;
diff --git a/vm/code_block.cpp b/vm/code_block.cpp
index 050e154c28..aaf8e25866 100755
--- a/vm/code_block.cpp
+++ b/vm/code_block.cpp
@@ -159,7 +159,10 @@ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
 	case RT_XT_PIC_TAIL:
 		return (cell)word_xt_pic_tail(untag<word>(ARG));
 	case RT_HERE:
-		return offset + untag_fixnum(ARG);
+	{
+		fixnum arg = untag_fixnum(ARG);
+		return (arg >= 0 ? offset + arg : (cell)(compiled +1) - arg);
+	}
 	case RT_THIS:
 		return (cell)(compiled + 1);
 	case RT_STACK_CHAIN:

From f09b36424c52752d8a427e6f2286e5275a4b9dcc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Jun 2009 02:32:42 -0500
Subject: [PATCH 38/46] Code cleanup

---
 basis/compiler/compiler.factor | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index eee00bfccb..7527f6b339 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -96,11 +96,11 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
 : not-compiled-def ( word error -- def )
     '[ _ _ not-compiled ] [ ] like ;
 
+: deoptimize* ( word -- * )
+    dup def>> deoptimize-with ;
+
 : ignore-error ( word error -- * )
-    drop
-    [ clear-compiler-error ]
-    [ dup def>> deoptimize-with ]
-    bi ;
+    drop [ clear-compiler-error ] [ deoptimize* ] bi ;
 
 : remember-error ( word error -- * )
     [ swap <compiler-error> compiler-error ]
@@ -124,13 +124,13 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
 : contains-breakpoints? ( -- ? )
     dependencies get keys [ "break?" word-prop ] any? ;
 
-: frontend ( word -- nodes )
+: frontend ( word -- tree )
     #! If the word contains breakpoints, don't optimize it, since
     #! the walker does not support this.
     dup optimize? [
         [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
-        contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
-    ] [ dup def>> deoptimize-with ] if ;
+        contains-breakpoints? [ nip deoptimize* ] [ drop ] if
+    ] [ deoptimize* ] if ;
 
 : compile-dependency ( word -- )
     #! If a word calls an unoptimized word, try to compile the callee.
@@ -150,7 +150,7 @@ t compile-dependencies? set-global
     [ compile-dependencies ]
     bi ;
 
-: backend ( nodes word -- )
+: backend ( tree word -- )
     build-cfg [
         optimize-cfg
         build-mr

From 3a9922d1610503cacd9ed7f89a122cf1ebb63fdb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Jun 2009 03:00:10 -0500
Subject: [PATCH 39/46] Fix compiler errors

---
 basis/compiler/cfg/local/local.factor                     | 2 +-
 basis/compiler/cfg/rpo/rpo.factor                         | 3 +--
 basis/compiler/cfg/two-operand/two-operand.factor         | 4 ++--
 basis/compiler/cfg/value-numbering/rewrite/rewrite.factor | 2 +-
 basis/compiler/codegen/fixup/fixup.factor                 | 2 +-
 5 files changed, 6 insertions(+), 7 deletions(-)

diff --git a/basis/compiler/cfg/local/local.factor b/basis/compiler/cfg/local/local.factor
index bf336a8d2a..5d78397998 100644
--- a/basis/compiler/cfg/local/local.factor
+++ b/basis/compiler/cfg/local/local.factor
@@ -7,4 +7,4 @@ IN: compiler.cfg.local
     [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
 
 : local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
-    [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ;
+    [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline
\ No newline at end of file
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index c6ea2ee8b1..f6a40e17d0 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/basis/compiler/cfg/rpo/rpo.factor
@@ -1,8 +1,7 @@
 ! 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
-compiler.cfg.liveness ;
+assocs fry compiler.cfg compiler.cfg.instructions ;
 IN: compiler.cfg.rpo
 
 SYMBOL: visited
diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor
index d5fb1e56cf..a3a83b9d14 100644
--- a/basis/compiler/cfg/two-operand/two-operand.factor
+++ b/basis/compiler/cfg/two-operand/two-operand.factor
@@ -15,12 +15,12 @@ IN: compiler.cfg.two-operand
 
 : make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline
 
-: convert-two-operand/integer ( insn -- insns )
+: convert-two-operand/integer ( insn -- )
     [ [ dst>> ] [ src1>> ] bi ##copy ]
     [ dup dst>> >>src1 , ]
     bi ; inline
 
-: convert-two-operand/float ( insn -- insns )
+: convert-two-operand/float ( insn -- )
     [ [ dst>> ] [ src1>> ] bi ##copy-float ]
     [ dup dst>> >>src1 , ]
     bi ; inline
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index c53a001d28..8653aaab04 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -79,7 +79,7 @@ M: ##compare-imm-branch rewrite
     [ dst>> ]
     [ src2>> ]
     [ src1>> vreg>vn vn>constant ] tri
-    cc= f i \ ##compare-imm boa ;
+    cc= i \ ##compare-imm new-insn ;
 
 M: ##compare rewrite
     dup flip-comparison? [
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index 5520508788..d44f6afd99 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -82,7 +82,7 @@ SYMBOL: relocation-table
     dup resolve-offset neg add-literal
     [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
 
-: resolve-relative-label ( label-fixup -- )
+: resolve-relative-label ( label-fixup -- label )
     [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
 
 : resolve-labels ( label-fixups -- labels' )

From d558545b65870e64c16fa1d5688d6e90dc692886 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Jun 2009 03:05:49 -0500
Subject: [PATCH 40/46] Remove obsolete optimization

---
 .../cfg/value-numbering/rewrite/rewrite.factor     | 14 --------------
 1 file changed, 14 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 8653aaab04..7630d0a658 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -114,18 +114,4 @@ M: ##compare-imm rewrite
         ] when
     ] when ;
 
-: dispatch-offset ( expr -- n )
-    [ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
-    \ ##sub-imm eq? [ neg ] when ;
-
-: add-dispatch-offset? ( insn -- expr ? )
-    src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
-
-M: ##dispatch rewrite
-    dup add-dispatch-offset? [
-        [ clone ] dip
-        [ in1>> vn>vreg >>src ]
-        [ dispatch-offset '[ _ + ] change-offset ] bi
-    ] [ drop ] if ;
-
 M: insn rewrite ;

From 7dd08892b250107b7550db039a62a84b77d1d6dd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Jun 2009 03:19:35 -0500
Subject: [PATCH 41/46] Fix for recent word renaming

---
 basis/compiler/cfg/iterator/iterator.factor           | 2 +-
 basis/compiler/cfg/linearization/linearization.factor | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor
index 9daf27451c..eb7f71ad60 100644
--- a/basis/compiler/cfg/iterator/iterator.factor
+++ b/basis/compiler/cfg/iterator/iterator.factor
@@ -41,5 +41,5 @@ DEFER: (tail-call?)
     ] all? ;
 
 : terminate-call? ( -- ? )
-    node-stack get peek
+    node-stack get last
     rest-slice [ f ] [ first #terminate? ] if-empty ;
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 2e09e493db..53ca56907d 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -51,7 +51,7 @@ M: ##branch linearize-insn
     [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
 
 : with-regs ( insn quot -- )
-    over regs>> [ call ] dip building get peek (>>regs) ; inline
+    over regs>> [ call ] dip building get last (>>regs) ; inline
 
 M: ##compare-branch linearize-insn
     [ binary-conditional _compare-branch ] with-regs emit-branch ;

From 19d62850355737acce952782e18ec2eec483b868 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Mon, 1 Jun 2009 09:34:28 -0500
Subject: [PATCH 42/46] fix load error

---
 basis/compiler/cfg/checker/checker.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index b0a279c11b..4aa2088143 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -8,7 +8,7 @@ IN: compiler.cfg.checker
 ERROR: last-insn-not-a-jump insn ;
 
 : check-last-instruction ( bb -- )
-    peek dup {
+    last dup {
         [ ##branch? ]
         [ ##dispatch? ]
         [ ##conditional-branch? ]

From a4a2ae8a78c1e9e3a41478c0becf3757bb412d72 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 1 Jun 2009 13:35:04 -0500
Subject: [PATCH 43/46] send \r\n instead of \n for windows telnet clients

---
 extra/managed-server/chat/chat.factor | 21 ++++++++++++---------
 1 file changed, 12 insertions(+), 9 deletions(-)

diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor
index 8835e3d8a6..4e841ec95e 100644
--- a/extra/managed-server/chat/chat.factor
+++ b/extra/managed-server/chat/chat.factor
@@ -18,6 +18,9 @@ chat-docs [ H{ } clone ] initialize
 
 CONSTANT: line-beginning "-!- "
 
+: send-line ( string -- )
+    write "\r\n" write flush ;
+
 : handle-me ( string -- )
     [
         [ "* " username " " ] dip
@@ -29,15 +32,15 @@ CONSTANT: line-beginning "-!- "
 : handle-help ( string -- )
     [
         "Commands: "
-        commands get keys natural-sort ", " join append print flush
+        commands get keys natural-sort ", " join append send-line
     ] [
         chat-docs get ?at
-        [ print flush ]
-        [ "Unknown command: " prepend print flush ] if
+        [ send-line ]
+        [ "Unknown command: " prepend send-line ] if
     ] if-empty ;
 
 : usage ( string -- )
-    chat-docs get at print flush ;
+    chat-docs get at send-line ;
 
 : username-taken-string ( username -- string )
     "The username ``" "'' is already in use; try again." surround ;
@@ -53,7 +56,7 @@ CONSTANT: line-beginning "-!- "
         "nick" usage
     ] [
         dup clients key? [
-            username-taken-string print flush
+            username-taken-string send-line
         ] [
             [ username swap warn-name-changed ]
             [ username clients rename-at ]
@@ -70,12 +73,12 @@ CONSTANT: line-beginning "-!- "
 Displays the documentation for a command.">
 "help" add-command
 
-[ drop clients keys [ "``" "''" surround ] map ", " join print flush ]
+[ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
 <" Syntax: /who
 Shows the list of connected users.">
 "who" add-command
 
-[ drop gmt timestamp>rfc822 print flush ]
+[ drop gmt timestamp>rfc822 send-line ]
 <" Syntax: /time
 Returns the current GMT time."> "time" add-command
 
@@ -96,7 +99,7 @@ Disconnects a user from the chat server."> "quit" add-command
     dup " " split1 swap >lower commands get at* [
         call( string -- ) drop
     ] [
-        2drop "Unknown command: " prepend print flush
+        2drop "Unknown command: " prepend send-line
     ] if ;
 
 : <chat-server> ( port -- managed-server )
@@ -123,7 +126,7 @@ M: chat-server handle-client-disconnect
     ] "" append-outputs-as send-everyone ;
 
 M: chat-server handle-already-logged-in
-    username username-taken-string print flush ;
+    username username-taken-string send-line ;
 
 M: chat-server handle-managed-client*
     readln dup f = [ t client (>>quit?) ] when

From 1f0bd22365b4099c90da34631c3ee28c19c4d6a4 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Mon, 1 Jun 2009 22:32:47 +0200
Subject: [PATCH 44/46] FUEL: Support for SYNTAX: parsing word.

---
 misc/fuel/fuel-syntax.el | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el
index 61aa2b7cdd..3fc16e7af6 100644
--- a/misc/fuel/fuel-syntax.el
+++ b/misc/fuel/fuel-syntax.el
@@ -59,7 +59,7 @@
     "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
     "QUALIFIED-WITH:" "QUALIFIED:"
     "read-only" "RENAME:" "REQUIRE:"  "REQUIRES:"
-    "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:"
+    "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
     "TUPLE:" "t" "t?" "TYPEDEF:"
     "UNION:" "USE:" "USING:"
     "VARS:"))
@@ -109,7 +109,7 @@
   (format "\\_<\\(%s\\)?: +\\_<\\(\\w+\\)\\_>"
           (regexp-opt
            '(":" "GENERIC" "DEFER" "HOOK" "MAIN" "MATH" "POSTPONE"
-             "SYMBOL" "RENAME"))))
+             "SYMBOL" "SYNTAX" "RENAME"))))
 
 (defconst fuel-syntax--alias-definition-regex
   "^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
@@ -156,6 +156,7 @@
                                            "INTERSECTION:"
                                            "M" "MACRO" "MACRO:"
                                            "MEMO" "MEMO:" "METHOD"
+                                           "SYNTAX"
                                            "PREDICATE" "PRIMITIVE"
                                            "UNION"))
 

From 45e6683c62cf0d0d8d62f7faaaff0c05c9f6805a Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Mon, 1 Jun 2009 23:09:30 +0200
Subject: [PATCH 45/46] FUEL: developer-name is not overriden in scaffolds if
 so desired.

---
 extra/fuel/fuel.factor     | 10 ++++++----
 misc/fuel/fuel-scaffold.el |  3 ++-
 2 files changed, 8 insertions(+), 5 deletions(-)

diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor
index 5d4149867b..ded10b66cb 100644
--- a/extra/fuel/fuel.factor
+++ b/extra/fuel/fuel.factor
@@ -134,14 +134,16 @@ PRIVATE>
 
 ! Scaffold support
 
+: fuel-scaffold-name ( devname -- )
+    [ developer-name set ] when* ;
+
 : fuel-scaffold-vocab ( root name devname -- )
-    developer-name set dup [ scaffold-vocab ] dip
+    [ fuel-scaffold-name dup [ scaffold-vocab ] dip ] with-scope
     dup require vocab-source-path (normalize-path) fuel-eval-set-result ;
 
 : fuel-scaffold-help ( name devname -- )
-    developer-name set
-    dup require dup scaffold-help vocab-docs-path
-    (normalize-path) fuel-eval-set-result ;
+    [ fuel-scaffold-name dup require dup scaffold-help ] with-scope
+    vocab-docs-path (normalize-path) fuel-eval-set-result ;
 
 : fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
 
diff --git a/misc/fuel/fuel-scaffold.el b/misc/fuel/fuel-scaffold.el
index ac400c5622..711862b615 100644
--- a/misc/fuel/fuel-scaffold.el
+++ b/misc/fuel/fuel-scaffold.el
@@ -28,7 +28,8 @@
 
 (defcustom fuel-scaffold-developer-name user-full-name
   "The name to be inserted as yours in scaffold templates."
-  :type 'string
+  :type '(choice string
+                 (const :tag "Factor's value for developer-name" nil))
   :group 'fuel-scaffold)
 
 

From 2675533bed0e42b661744f3a469896d8d3063ce6 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Mon, 1 Jun 2009 23:24:05 +0200
Subject: [PATCH 46/46] FUEL: Use by default Factor's developer-name in
 scaffolds.

---
 misc/fuel/fuel-scaffold.el | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/misc/fuel/fuel-scaffold.el b/misc/fuel/fuel-scaffold.el
index 711862b615..b1c4462503 100644
--- a/misc/fuel/fuel-scaffold.el
+++ b/misc/fuel/fuel-scaffold.el
@@ -26,7 +26,7 @@
   "Options for FUEL's scaffolding."
   :group 'fuel)
 
-(defcustom fuel-scaffold-developer-name user-full-name
+(defcustom fuel-scaffold-developer-name nil
   "The name to be inserted as yours in scaffold templates."
   :type '(choice string
                  (const :tag "Factor's value for developer-name" nil))