From a91547a652bcf77d4e4defc38b479dda40679c2c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 21 Jun 2009 00:58:36 -0500
Subject: [PATCH 01/42] 50% speedup using unsafe nth/set-nth/exchange in
 checksums.sha

---
 basis/checksums/sha/sha.factor | 104 ++++++++++++++++-----------------
 1 file changed, 51 insertions(+), 53 deletions(-)

diff --git a/basis/checksums/sha/sha.factor b/basis/checksums/sha/sha.factor
index 287c39b2a1..35262bb0b0 100644
--- a/basis/checksums/sha/sha.factor
+++ b/basis/checksums/sha/sha.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel splitting grouping math sequences namespaces make
-io.binary math.bitwise checksums checksums.common
-sbufs strings combinators.smart math.ranges fry combinators
-accessors locals checksums.stream multiline literals
-generalizations ;
+USING: accessors checksums checksums.common checksums.stream
+combinators combinators.smart fry generalizations grouping
+io.binary kernel literals locals make math math.bitwise
+math.ranges multiline namespaces sbufs sequences
+sequences.private splitting strings ;
 IN: checksums.sha
 
 SINGLETON: sha1
@@ -230,21 +230,21 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
 
 : prepare-M-256 ( n seq -- )
     {
-        [ [ 16 - ] dip nth ]
-        [ [ 15 - ] dip nth s0-256 ]
-        [ [ 7 - ] dip nth ]
-        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ [ 16 - ] dip nth-unsafe ]
+        [ [ 15 - ] dip nth-unsafe s0-256 ]
+        [ [ 7 - ] dip nth-unsafe ]
+        [ [ 2 - ] dip nth-unsafe s1-256 w+ w+ w+ ]
         [ ]
-    } 2cleave set-nth ; inline
+    } 2cleave set-nth-unsafe ; inline
 
 : prepare-M-512 ( n seq -- )
     {
-        [ [ 16 - ] dip nth ]
-        [ [ 15 - ] dip nth s0-512 ]
-        [ [ 7 - ] dip nth ]
-        [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+        [ [ 16 - ] dip nth-unsafe ]
+        [ [ 15 - ] dip nth-unsafe s0-512 ]
+        [ [ 7 - ] dip nth-unsafe ]
+        [ [ 2 - ] dip nth-unsafe s1-512 w+ w+ w+ ]
         [ ]
-    } 2cleave set-nth ; inline
+    } 2cleave set-nth-unsafe ; inline
 
 : ch ( x y z -- x' )
     [ bitxor bitand ] keep bitxor ; inline
@@ -258,36 +258,36 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
 GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
 
 :: T1-256 ( n M H sha2 -- T1 )
-    n M nth
-    n sha2 K>> nth +
+    n M nth-unsafe
+    n sha2 K>> nth-unsafe +
     e H slice3 ch w+
-    e H nth S1-256 w+
-    h H nth w+ ; inline
+    e H nth-unsafe S1-256 w+
+    h H nth-unsafe w+ ; inline
 
 : T2-256 ( H -- T2 )
-    [ a swap nth S0-256 ]
+    [ a swap nth-unsafe S0-256 ]
     [ a swap slice3 maj w+ ] bi ; inline
 
 :: T1-512 ( n M H sha2 -- T1 )
-    n M nth
-    n sha2 K>> nth +
+    n M nth-unsafe
+    n sha2 K>> nth-unsafe +
     e H slice3 ch w+
-    e H nth S1-512 w+
-    h H nth w+ ; inline
+    e H nth-unsafe S1-512 w+
+    h H nth-unsafe w+ ; inline
 
 : T2-512 ( H -- T2 )
-    [ a swap nth S0-512 ]
+    [ a swap nth-unsafe S0-512 ]
     [ a swap slice3 maj w+ ] bi ; inline
 
 : update-H ( T1 T2 H -- )
-    h g pick exchange
-    g f pick exchange
-    f e pick exchange
-    pick d pick nth w+ e pick set-nth
-    d c pick exchange
-    c b pick exchange
-    b a pick exchange
-    [ w+ a ] dip set-nth ; inline
+    h g pick exchange-unsafe
+    g f pick exchange-unsafe
+    f e pick exchange-unsafe
+    pick d pick nth-unsafe w+ e pick set-nth-unsafe
+    d c pick exchange-unsafe
+    c b pick exchange-unsafe
+    b a pick exchange-unsafe
+    [ w+ a ] dip set-nth-unsafe ; inline
 
 : prepare-message-schedule ( seq sha2 -- w-seq )
     [ word-size>> <sliced-groups> [ be> ] map ]
@@ -309,7 +309,7 @@ M: sha2-short checksum-block
     [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
 
 : seq>byte-array ( seq n -- string )
-    '[ _ >be ] map B{ } join ;
+    '[ _ >be ] map B{ } concat-as ;
 
 : sha1>checksum ( sha2 -- bytes )
     H>> 4 seq>byte-array ;
@@ -342,16 +342,14 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
     drop
     [ <sha-256-state> ] dip add-checksum-stream get-checksum ;
 
-
-
 : sha1-W ( t seq -- )
     {
-        [ [ 3 - ] dip nth ]
-        [ [ 8 - ] dip nth bitxor ]
-        [ [ 14 - ] dip nth bitxor ]
-        [ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
+        [ [ 3 - ] dip nth-unsafe ]
+        [ [ 8 - ] dip nth-unsafe bitxor ]
+        [ [ 14 - ] dip nth-unsafe bitxor ]
+        [ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ]
         [ ]
-    } 2cleave set-nth ;
+    } 2cleave set-nth-unsafe ;
 
 : prepare-sha1-message-schedule ( seq -- w-seq )
     4 <sliced-groups> [ be> ] map
@@ -368,11 +366,11 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
     } case ;
 
 :: inner-loop ( n H W K -- temp )
-    a H nth :> A
-    b H nth :> B
-    c H nth :> C
-    d H nth :> D
-    e H nth :> E
+    a H nth-unsafe :> A
+    b H nth-unsafe :> B
+    c H nth-unsafe :> C
+    d H nth-unsafe :> D
+    e H nth-unsafe :> E
     [
         A 5 bitroll-32
 
@@ -380,19 +378,19 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
 
         E
 
-        n K nth
+        n K nth-unsafe
 
-        n W nth
+        n W nth-unsafe
     ] sum-outputs 32 bits ;
 
 :: process-sha1-chunk ( bytes H W K state -- )
     80 [
         H W K inner-loop
-        d H nth e H set-nth
-        c H nth d H set-nth
-        b H nth 30 bitroll-32 c H set-nth
-        a H nth b H set-nth
-        a H set-nth
+        d H nth-unsafe e H set-nth-unsafe
+        c H nth-unsafe d H set-nth-unsafe
+        b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
+        a H nth-unsafe b H set-nth-unsafe
+        a H set-nth-unsafe
     ] each
     state [ H [ w+ ] 2map ] change-H drop ; inline
 

From b8cdf23aa529d12338427949b82f28e08533df17 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 21 Jun 2009 00:59:06 -0500
Subject: [PATCH 02/42] add scaffold words for default vocab roots

---
 basis/tools/scaffold/scaffold.factor | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor
index 5c8b868483..5fdc5ce087 100755
--- a/basis/tools/scaffold/scaffold.factor
+++ b/basis/tools/scaffold/scaffold.factor
@@ -266,6 +266,14 @@ PRIVATE>
         [ nip require ]
     } 2cleave ;
 
+: scaffold-core ( string -- ) "resource:core" swap scaffold-vocab ;
+
+: scaffold-basis ( string -- ) "resource:basis" swap scaffold-vocab ;
+
+: scaffold-extra ( string -- ) "resource:extra" swap scaffold-vocab ;
+
+: scaffold-work ( string -- ) "resource:work" swap scaffold-vocab ;
+
 <PRIVATE
 
 : tests-file-string ( vocab -- string )

From b0ad79493e16b56ac0a1d157c6b00997555263ad Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 22 Jun 2009 11:55:42 -0500
Subject: [PATCH 03/42] fix cursor 3map

---
 extra/cursors/cursors-tests.factor | 5 +++++
 extra/cursors/cursors.factor       | 9 +++++----
 2 files changed, 10 insertions(+), 4 deletions(-)

diff --git a/extra/cursors/cursors-tests.factor b/extra/cursors/cursors-tests.factor
index 8294eb05e8..8821d4570c 100644
--- a/extra/cursors/cursors-tests.factor
+++ b/extra/cursors/cursors-tests.factor
@@ -37,3 +37,8 @@ IN: cursors.tests
 
 [ { 111 222 } ]
 [ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test
+
+: test-3map ( -- seq )
+     { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ;
+
+[ { 111 222 } ] [ test-3map ] unit-test
diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor
index 14cc1fdf7f..dc08656f7e 100644
--- a/extra/cursors/cursors.factor
+++ b/extra/cursors/cursors.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generalizations kernel math sequences
-sequences.private ;
+sequences.private fry ;
 IN: cursors
 
 GENERIC: cursor-done? ( cursor -- ? )
@@ -127,12 +127,13 @@ M: to-sequence cursor-write
 : 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
 
 : find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
-    3 nover 3array [ cursor-done? ] any?
-    [ 4 ndrop t ] [ [ [ cursor-get-unsafe ] tri@ ] dip call ] if ; inline
+    [ 3 ndrop t ] swap '[ [ cursor-get-unsafe ] tri@ @ ]
+    [ 3 ndup 3 narray [ cursor-done? ] any? ] 2dip if ; inline
 
 : cursor-until3 ( cursor cursor quot -- )
     [ find-done3? not ]
-    [ drop [ cursor-advance ] tri@ ] bi-curry bi-curry bi-curry bi-curry while ; inline
+    [ drop [ cursor-advance ] tri@ ]
+    bi-curry bi-curry bi-curry bi-curry while ; inline
 
 : cursor-each3 ( cursor cursor quot -- )
     [ f ] compose cursor-until3 ; inline

From 3b8733de015c37556890603bdf007365721f39bd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 26 Jun 2009 17:29:55 -0500
Subject: [PATCH 04/42] Redesign compiler.cfg.stack-analysis to make
 compiler.cfg.height redundant, and to fix some problems

---
 basis/compiler/cfg/debugger/debugger.factor   | 15 ++-
 basis/compiler/cfg/height/height.factor       | 55 -----------
 basis/compiler/cfg/height/summary.txt         |  1 -
 .../cfg/linear-scan/debugger/debugger.factor  |  3 -
 .../cfg/linear-scan/linear-scan-tests.factor  |  6 --
 .../linear-scan/resolve/resolve-tests.factor  |  3 +-
 basis/compiler/cfg/optimizer/optimizer.factor |  3 +-
 basis/compiler/cfg/registers/registers.factor |  7 +-
 .../stack-analysis/merge/merge-tests.factor   | 93 ++++++++++++++++++
 .../cfg/stack-analysis/merge/merge.factor     | 95 +++++++++++--------
 .../stack-analysis-tests.factor               | 34 ++++++-
 .../cfg/stack-analysis/stack-analysis.factor  | 62 +++---------
 .../cfg/stack-analysis/state/state.factor     | 22 +++--
 13 files changed, 233 insertions(+), 166 deletions(-)
 delete mode 100644 basis/compiler/cfg/height/height.factor
 delete mode 100644 basis/compiler/cfg/height/summary.txt
 create mode 100644 basis/compiler/cfg/stack-analysis/merge/merge-tests.factor

diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index cb56937758..60805124cd 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences quotations namespaces io
+USING: kernel words sequences quotations namespaces io vectors
 classes.tuple accessors prettyprint prettyprint.config
 prettyprint.backend prettyprint.custom prettyprint.sections
 parser compiler.tree.builder compiler.tree.optimizer
@@ -8,7 +8,7 @@ compiler.cfg.builder compiler.cfg.linearization
 compiler.cfg.registers compiler.cfg.stack-frame
 compiler.cfg.linear-scan compiler.cfg.two-operand
 compiler.cfg.liveness compiler.cfg.optimizer
-compiler.cfg.mr ;
+compiler.cfg.mr compiler.cfg ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -49,3 +49,12 @@ M: vreg pprint*
 M: ds-loc pprint* \ D pprint-loc ;
 
 M: rs-loc pprint* \ R pprint-loc ;
+
+: test-bb ( insns n -- )
+    [ <basic-block> swap >>number swap >>instructions ] keep set ;
+
+: test-diamond ( -- )
+    1 get 1vector 0 get (>>successors)
+    2 get 3 get V{ } 2sequence 1 get (>>successors)
+    4 get 1vector 2 get (>>successors)
+    4 get 1vector 3 get (>>successors) ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
deleted file mode 100644
index 14a0a54715..0000000000
--- a/basis/compiler/cfg/height/height.factor
+++ /dev/null
@@ -1,55 +0,0 @@
-! 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.liveness compiler.cfg.local ;
-IN: compiler.cfg.height
-
-! Combine multiple stack height changes into one at the
-! start of the basic block.
-
-SYMBOL: ds-height
-SYMBOL: rs-height
-
-GENERIC: compute-heights ( insn -- )
-
-M: ##inc-d compute-heights n>> ds-height [ + ] change ;
-M: ##inc-r compute-heights n>> rs-height [ + ] change ;
-M: insn compute-heights drop ;
-
-GENERIC: normalize-height* ( insn -- insn' )
-
-: normalize-inc-d/r ( insn stack -- insn' )
-    swap n>> '[ _ - ] change f ; inline
-
-M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
-M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
-
-GENERIC: loc-stack ( loc -- stack )
-
-M: ds-loc loc-stack drop ds-height ;
-M: rs-loc loc-stack drop rs-height ;
-
-GENERIC: <loc> ( n stack -- loc )
-
-M: ds-loc <loc> drop <ds-loc> ;
-M: rs-loc <loc> drop <rs-loc> ;
-
-: normalize-peek/replace ( insn -- insn' )
-    [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
-
-M: ##peek normalize-height* normalize-peek/replace ;
-M: ##replace normalize-height* normalize-peek/replace ;
-
-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 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
-    rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
-
-: normalize-height ( cfg -- cfg' )
-    [ drop ] [ height-step ] local-optimization ;
diff --git a/basis/compiler/cfg/height/summary.txt b/basis/compiler/cfg/height/summary.txt
deleted file mode 100644
index ce1974ad60..0000000000
--- a/basis/compiler/cfg/height/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Stack height normalization coalesces height changes at start of basic block
diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
index 401241722f..be3fb2bea8 100644
--- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor
+++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
@@ -34,6 +34,3 @@ IN: compiler.cfg.linear-scan.debugger
 
 : live-intervals. ( seq -- )
     [ interval-picture ] map simple-table. ;
-
-: test-bb ( insns n -- )
-    [ <basic-block> swap >>number swap >>instructions ] keep set ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 60dfbd83bc..49352da0f7 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -1563,12 +1563,6 @@ V{
     T{ ##return }
 } 4 test-bb
 
-: test-diamond ( -- )
-    1 get 1vector 0 get (>>successors)
-    2 get 3 get V{ } 2sequence 1 get (>>successors)
-    4 get 1vector 2 get (>>successors)
-    4 get 1vector 3 get (>>successors) ;
-
 test-diamond
 
 { 1 2 3 4 } test-linear-scan-on-cfg
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index 3e98d6c9f0..d575450f43 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -3,7 +3,8 @@ compiler.cfg.linear-scan.debugger
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
-compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
+compiler.cfg.registers compiler.cfg.rpo
+compiler.cfg.debugger cpu.architecture kernel
 namespaces tools.test vectors ;
 IN: compiler.cfg.linear-scan.resolve.tests
 
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 9d481ef1d2..60c2380f7e 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -25,9 +25,8 @@ SYMBOL: check-optimizer?
 : optimize-cfg ( cfg -- cfg' )
     [
         compute-predecessors
-        delete-useless-blocks
+        ! delete-useless-blocks
         delete-useless-conditionals
-        normalize-height
         stack-analysis
         compute-liveness
         alias-analysis
diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor
index 0882bed06e..71f313be5a 100644
--- a/basis/compiler/cfg/registers/registers.factor
+++ b/basis/compiler/cfg/registers/registers.factor
@@ -8,7 +8,12 @@ TUPLE: vreg { reg-class read-only } { n read-only } ;
 SYMBOL: vreg-counter
 : next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
 
-! Stack locations
+! Stack locations -- 'n' is an index starting from the top of the stack
+! going down. So 0 is the top of the stack, 1 is what would be the top
+! of the stack after a 'drop', and so on.
+
+! ##inc-d and ##inc-r affect locations as follows. Location D 0 before
+! an ##inc-d 1 becomes D 1 after ##inc-d 1.
 TUPLE: loc { n read-only } ;
 
 TUPLE: ds-loc < loc ;
diff --git a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
new file mode 100644
index 0000000000..e519308974
--- /dev/null
+++ b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
@@ -0,0 +1,93 @@
+IN: compiler.cfg.stack-analysis.merge.tests
+USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
+compiler.cfg.instructions compiler.cfg.stack-analysis.state
+compiler.cfg compiler.cfg.registers compiler.cfg.debugger
+cpu.architecture make assocs
+sequences kernel classes ;
+
+[
+    { D 0 }
+    { V int-regs 0 V int-regs 1 }
+] [
+    <state>
+
+    <basic-block> V{ T{ ##branch } } >>instructions
+    <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+    <state> H{ { D 0 V int-regs 0 } } >>locs>vregs
+    <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+    [ merge-locs locs>vregs>> keys ] { } make first inputs>>
+] unit-test
+
+[
+    { D 0 }
+    ##peek
+] [
+    <state>
+
+    <basic-block> V{ T{ ##branch } } >>instructions
+    <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+    [
+        <state>
+        <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+        [ merge-locs locs>vregs>> keys ] { } make drop
+    ] keep first instructions>> first class
+] unit-test
+
+[
+    0 ##inc-d
+] [
+    <state>
+
+    <basic-block> V{ T{ ##branch } } >>instructions
+    <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+    [
+        <state> -1 >>ds-height
+        <state> 2array
+
+        [ merge-ds-heights ds-height>> ] { } make drop
+    ] keep first instructions>> first class
+] unit-test
+
+[
+    0
+    { D 0 }
+    { 1 1 }
+] [
+    <state>
+
+    <basic-block> V{ T{ ##branch } } >>instructions
+    <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+    [
+        <state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
+        <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+        [ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop
+    ] keep
+    [ instructions>> length ] map
+] unit-test
+
+[
+    -1
+    { D -1 }
+    { 1 1 }
+] [
+    <state>
+
+    <basic-block> V{ T{ ##branch } } >>instructions
+    <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+    [
+        <state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
+        <state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
+
+        [ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop
+        [ ds-height>> ] [ locs>vregs>> keys ] bi
+    ] keep
+    [ instructions>> length ] map
+] unit-test
diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor
index 9db6d595bf..25b0c30033 100644
--- a/basis/compiler/cfg/stack-analysis/merge/merge.factor
+++ b/basis/compiler/cfg/stack-analysis/merge/merge.factor
@@ -1,65 +1,83 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs sequences accessors fry combinators grouping
-sets compiler.cfg compiler.cfg.hats
+sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.stack-analysis.state ;
 IN: compiler.cfg.stack-analysis.merge
 
+! XXX critical edges
+
 : initial-state ( bb states -- state ) 2drop <state> ;
 
 : single-predecessor ( bb states -- state ) nip first clone ;
 
-ERROR: must-equal-failed seq ;
+: save-ds-height ( n -- )
+    dup 0 = [ drop ] [ ##inc-d ] if ;
 
-: must-equal ( seq -- elt )
-    dup all-equal? [ first ] [ must-equal-failed ] if ;
+: merge-ds-heights ( state predecessors states -- state )
+    [ ds-height>> ] map dup all-equal?
+    [ nip first >>ds-height ]
+    [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
 
-: merge-heights ( state predecessors states -- state )
-    nip
-    [ [ ds-height>> ] map must-equal >>ds-height ]
-    [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
+: save-rs-height ( n -- )
+    dup 0 = [ drop ] [ ##inc-r ] if ;
 
-: insert-peek ( predecessor loc -- vreg )
-    ! XXX critical edges
-    '[ _ ^^peek ] add-instructions ;
+: merge-rs-heights ( state predecessors states -- state )
+    [ rs-height>> ] map dup all-equal?
+    [ nip first >>rs-height ]
+    [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
 
-: merge-loc ( predecessors locs>vregs loc -- vreg )
+: assoc-map-values ( assoc quot -- assoc' )
+    '[ _ dip ] assoc-map ; inline
+
+: translate-locs ( assoc state -- assoc' )
+    '[ _ translate-loc ] assoc-map-values ;
+
+: untranslate-locs ( assoc state -- assoc' )
+    '[ _ untranslate-loc ] assoc-map-values ;
+
+: collect-locs ( loc-maps states -- assoc )
+    ! assoc maps locs to sequences of vregs
+    [ untranslate-locs ] 2map
+    [ [ keys ] map concat prune ] keep
+    '[ dup _ [ at ] with map ] H{ } map>assoc ;
+
+: insert-peek ( predecessor state loc -- vreg )
+    '[ _ _ swap translate-loc ^^peek ] add-instructions ;
+
+: merge-loc ( predecessors states 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 [ 2nip ] [ drop _ insert-peek ] if ] 3map
     dup all-equal? [ first ] [ ^^phi ] if ;
 
-: (merge-locs) ( predecessors assocs -- assoc )
-    dup [ keys ] map concat prune
-    [ [ 2nip ] [ merge-loc ] 3bi ] with with
-    H{ } map>assoc ;
+:: merge-locs ( state predecessors states -- state )
+    states [ locs>vregs>> ] map states collect-locs
+    [| key value |
+        key
+        predecessors states value key merge-loc
+    ] assoc-map
+    state translate-locs
+    state (>>locs>vregs)
+    state ;
 
-: merge-locs ( state predecessors states -- state )
-    [ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
-
-: merge-actual-loc ( locs>vregs loc -- vreg )
-    '[ [ _ ] dip at ] map
+: merge-actual-loc ( vregs -- vreg/f )
     dup all-equal? [ first ] [ drop f ] if ;
 
-: merge-actual-locs ( state predecessors states -- state )
-    nip
-    [ actual-locs>vregs>> ] map
-    dup [ keys ] map concat prune
-    [ [ nip ] [ merge-actual-loc ] 2bi ] with
-    H{ } map>assoc
-    [ nip ] assoc-filter
+: merge-actual-locs ( state states -- state )
+    [ [ actual-locs>vregs>> ] map ] keep collect-locs
+    [ merge-actual-loc ] assoc-map [ nip ] assoc-filter
+    over translate-locs
     >>actual-locs>vregs ;
 
-: merge-changed-locs ( state predecessors states -- state )
-    nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
+: merge-changed-locs ( state states -- state )
+    [ changed-locs>> ] map assoc-combine >>changed-locs ;
 
 ERROR: cannot-merge-poisoned states ;
 
 : multiple-predecessors ( bb states -- state )
     dup [ not ] any? [
-        [ <state> ] 2dip
-        sift merge-heights
+        2drop <state>
     ] [
         dup [ poisoned?>> ] any? [
             cannot-merge-poisoned
@@ -67,10 +85,11 @@ ERROR: cannot-merge-poisoned states ;
             [ state new ] 2dip
             [ predecessors>> ] dip
             {
+                [ merge-ds-heights ]
+                [ merge-rs-heights ]
                 [ merge-locs ]
-                [ merge-actual-locs ]
-                [ merge-heights ]
-                [ merge-changed-locs ]
+                [ nip merge-actual-locs ]
+                [ nip merge-changed-locs ]
             } 2cleave
         ] if
     ] if ;
@@ -82,4 +101,4 @@ ERROR: cannot-merge-poisoned states ;
         { 0 [ initial-state ] }
         { 1 [ single-predecessor ] }
         [ drop multiple-predecessors ]
-    } case ;
\ No newline at end of file
+    } case ;
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index 3501825704..cb0a800927 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -4,7 +4,7 @@ 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 compiler.cfg.useless-blocks
-sets namespaces ;
+sets namespaces arrays cpu.architecture ;
 IN: compiler.cfg.stack-analysis.tests
 
 ! Fundamental invariant: a basic block should not load or store a value more than once
@@ -113,3 +113,35 @@ local-only? off
     [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
     [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
 ] unit-test
+
+! Correct height tracking
+[ D 1 D 0 ] [
+    [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
+    reverse-post-order 2 swap nth
+    instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
+] unit-test
+
+[ D 1 ] [
+    V{ T{ ##branch } } 0 test-bb
+
+    V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb
+
+    V{
+        T{ ##peek f V int-regs 1 D 2 }
+        T{ ##inc-d f -1 }
+        T{ ##branch }
+    } 2 test-bb
+
+    V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb
+
+    V{ T{ ##return } } 4 test-bb
+
+    test-diamond
+
+    cfg new 0 get >>entry
+    compute-predecessors
+    stack-analysis
+    drop
+
+    3 get instructions>> second loc>>
+] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index 3946e0b897..0e06a2fdf5 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -13,32 +13,14 @@ compiler.cfg.stack-analysis.state
 compiler.cfg.stack-analysis.merge ;
 IN: compiler.cfg.stack-analysis
 
-! Convert stack operations to register operations
-GENERIC: height-for ( loc -- n )
-
-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
-
-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 -- ? )
-    dup untranslate-loc n>> 0 <
+    dup state get 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 ] [ untranslate-loc ##replace ] if
+        [ 2drop ] [ state get untranslate-loc ##replace ] if
     ] assoc-each ;
 
 ERROR: poisoned-state state ;
@@ -46,6 +28,8 @@ ERROR: poisoned-state state ;
 : sync-state ( -- )
     state get {
         [ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
+        [ ds-height>> save-ds-height ]
+        [ rs-height>> save-rs-height ]
         [ save-changed-locs ]
         [ clear-state ]
     } cleave ;
@@ -55,18 +39,16 @@ ERROR: poisoned-state state ;
 ! Abstract interpretation
 GENERIC: visit ( insn -- )
 
-: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
+M: ##inc-d visit
+    n>> state get [ + ] change-ds-height drop ;
 
-M: ##inc-d visit [ , ] [ n>> adjust-ds ] bi ;
-
-: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
-
-M: ##inc-r visit [ , ] [ n>> adjust-rs ] bi ;
+M: ##inc-r visit
+    n>> state get [ + ] change-rs-height drop ;
 
 ! Instructions which don't have any effect on the stack
 UNION: neutral-insn
-    ##flushable
-    ##effect ;
+    ##effect
+    ##flushable ;
 
 M: neutral-insn visit , ;
 
@@ -97,20 +79,16 @@ M: sync-if-back-edge visit
     [ ##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 ;
+    [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
+    [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
 
 M: ##replace visit
-    [ src>> resolve ] [ loc>> translate-loc ] bi
+    [ src>> resolve ] [ loc>> state get translate-loc ] bi
     record-replace ;
 
 M: ##copy visit
     [ call-next-method ] [ record-copy ] bi ;
 
-M: ##call visit
-    [ call-next-method ] [ height>> adjust-ds ] bi ;
-
 ! Instructions that poison the stack state
 UNION: poison-insn
     ##jump
@@ -133,21 +111,11 @@ UNION: kill-vreg-insn
     ##fixnum-add
     ##fixnum-sub
     ##alien-invoke
-    ##alien-indirect ;
+    ##alien-indirect
+    ##alien-callback ;
 
 M: kill-vreg-insn visit sync-state , ;
 
-: visit-alien-node ( node -- )
-    params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-ds ;
-
-M: ##alien-invoke visit
-    [ call-next-method ] [ visit-alien-node ] bi ;
-
-M: ##alien-indirect visit
-    [ call-next-method ] [ visit-alien-node ] bi ;
-
-M: ##alien-callback visit , ;
-
 ! Maps basic-blocks to states
 SYMBOLS: state-in state-out ;
 
diff --git a/basis/compiler/cfg/stack-analysis/state/state.factor b/basis/compiler/cfg/stack-analysis/state/state.factor
index d8cec0183f..f701b84763 100644
--- a/basis/compiler/cfg/stack-analysis/state/state.factor
+++ b/basis/compiler/cfg/stack-analysis/state/state.factor
@@ -1,11 +1,14 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets math ;
+USING: kernel accessors namespaces assocs sets math
+compiler.cfg.registers ;
 IN: compiler.cfg.stack-analysis.state
 
 TUPLE: state
 locs>vregs actual-locs>vregs changed-locs
-ds-height rs-height poisoned? ;
+{ ds-height integer }
+{ rs-height integer }
+poisoned? ;
 
 : <state> ( -- state )
     state new
@@ -33,11 +36,14 @@ M: state clone
     dup changed-loc state get locs>vregs>> set-at ;
 
 : clear-state ( state -- )
-    [ locs>vregs>> clear-assoc ]
-    [ actual-locs>vregs>> clear-assoc ]
-    [ changed-locs>> clear-assoc ]
-    tri ;
+    0 >>ds-height 0 >>rs-height
+    [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
+    [ clear-assoc ] tri@ ;
 
-: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
+GENERIC# translate-loc 1 ( loc state -- loc' )
+M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - <ds-loc> ;
+M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
 
-: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
+GENERIC# untranslate-loc 1 ( loc state -- loc' )
+M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
+M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;

From 6cb496607588a4e3f5a6563f3f00bf69b11aef0f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 26 Jun 2009 17:44:33 -0500
Subject: [PATCH 05/42] Fix bootstrap and unit test

---
 basis/compiler/cfg/optimizer/optimizer.factor               | 1 -
 .../compiler/cfg/stack-analysis/stack-analysis-tests.factor | 6 +++---
 2 files changed, 3 insertions(+), 4 deletions(-)

diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 60c2380f7e..e789fc9c21 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -3,7 +3,6 @@
 USING: kernel sequences accessors combinators namespaces
 compiler.cfg.predecessors
 compiler.cfg.useless-blocks
-compiler.cfg.height
 compiler.cfg.stack-analysis
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index cb0a800927..e01d870bf2 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -2,7 +2,7 @@ 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.height compiler.cfg.rpo
+compiler.cfg.checker compiler.cfg.rpo
 compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
 sets namespaces arrays cpu.architecture ;
 IN: compiler.cfg.stack-analysis.tests
@@ -25,7 +25,6 @@ IN: compiler.cfg.stack-analysis.tests
     compute-predecessors
     delete-useless-blocks
     delete-useless-conditionals
-    normalize-height
     stack-analysis
     dup check-cfg
     dup check-for-redundant-ops ;
@@ -115,10 +114,11 @@ local-only? off
 ] unit-test
 
 ! Correct height tracking
-[ D 1 D 0 ] [
+[ t ] [
     [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
     reverse-post-order 2 swap nth
     instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
+    2array { D 1 D 0 } set=
 ] unit-test
 
 [ D 1 ] [

From 1dd223668e8c4dc4013489dfe9ef9425bebcff53 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 26 Jun 2009 21:46:59 -0500
Subject: [PATCH 06/42] add collect-values to histogram

---
 extra/histogram/histogram.factor | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/extra/histogram/histogram.factor b/extra/histogram/histogram.factor
index 70ddfd3af5..d5c6ab3778 100755
--- a/extra/histogram/histogram.factor
+++ b/extra/histogram/histogram.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences assocs ;
+USING: kernel sequences assocs fry ;
 IN: histogram
 
 <PRIVATE
@@ -24,3 +24,6 @@ PRIVATE>
 
 : histogram ( seq -- hashtable )
     [ inc-at ] sequence>hashtable ;
+
+: collect-values ( seq quot: ( obj hashtable -- ) -- hash )
+    '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline

From c7a04858eea64d40640bbbf4759ac664ad57335b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 26 Jun 2009 21:48:21 -0500
Subject: [PATCH 07/42] add spill-temp to compiler.cfg.instructions, implement
 parallel register assignment in linear-scan.resolve

---
 .../cfg/instructions/instructions.factor      |   2 +
 .../linear-scan/resolve/resolve-tests.factor  | 154 +++++++++++++++++-
 .../cfg/linear-scan/resolve/resolve.factor    | 126 +++++++++++++-
 3 files changed, 271 insertions(+), 11 deletions(-)

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 1bf94985a6..5b3e1af930 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -247,3 +247,5 @@ INSN: _spill src class n ;
 INSN: _reload dst class n ;
 INSN: _copy dst src class ;
 INSN: _spill-counts counts ;
+
+SYMBOL: temp-spill
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index 3e98d6c9f0..717cf36e14 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -1,10 +1,10 @@
-USING: accessors arrays compiler.cfg compiler.cfg.instructions
-compiler.cfg.linear-scan.debugger
+USING: accessors arrays classes compiler.cfg
+compiler.cfg.instructions compiler.cfg.linear-scan.debugger
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
 compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
-namespaces tools.test vectors ;
+multiline namespaces tools.test vectors ;
 IN: compiler.cfg.linear-scan.resolve.tests
 
 [ { 1 2 3 4 5 6 } ] [
@@ -62,4 +62,150 @@ T{ live-interval
 
 [ f ] [
     1 get test-live-interval-2 reload-from
-] unit-test
\ No newline at end of file
+] unit-test
+
+[
+    {
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ _copy { dst 5 } { src 4 } { class int-regs } }
+        T{ _spill { src 1 } { class int-regs } { n 6 } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n 6 } }
+        T{ _spill { src 1 } { class float-regs } { n 7 } }
+        T{ _copy { dst 1 } { src 0 } { class float-regs } }
+        T{ _reload { dst 0 } { class float-regs } { n 7 } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
+        T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
+        T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _spill { src 1 } { class int-regs } { n 3 } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 0 } { src 2 } { class int-regs } }
+        T{ _reload { dst 2 } { class int-regs } { n 3 } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _spill { src 1 } { class int-regs } { n 3 } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 0 } { src 2 } { class int-regs } }
+        T{ _reload { dst 2 } { class int-regs } { n 3 } }
+    }
+] [
+    {
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 2 } { src 0 } { class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    { }
+] [
+    {
+       T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    { T{ _spill { src 4 } { class int-regs } { n 4 } } }
+] [
+    {
+       T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index 55a2eab41b..b29a661fbf 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -1,9 +1,11 @@
-! Copyright (C) 2009 Slava Pestov
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math namespaces sequences
-classes.tuple classes.parser parser fry words make arrays
-locals combinators compiler.cfg.linear-scan.live-intervals
-compiler.cfg.liveness compiler.cfg.instructions ;
+USING: accessors arrays assocs classes.parser classes.tuple
+combinators combinators.short-circuit compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness
+fry hashtables histogram kernel locals make math math.order
+namespaces parser prettyprint random sequences sets
+sorting.functor sorting.slots words ;
 IN: compiler.cfg.linear-scan.resolve
 
 <<
@@ -75,8 +77,118 @@ M: memory->register >insn
 M: register->register >insn
     [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
 
+GENERIC: >collision-table ( operation -- )
+
+M: memory->memory >collision-table
+    [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
+
+M: register->memory >collision-table
+    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
+
+M: memory->register >collision-table
+    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
+
+M: register->register >collision-table
+    [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
+
+SYMBOL: froms
+SYMBOL: tos
+
+SINGLETONS: memory register ;
+
+GENERIC: from-loc ( operation -- obj )
+M: memory->memory from-loc drop memory ;
+M: register->memory from-loc drop register ;
+M: memory->register from-loc drop memory ;
+M: register->register from-loc drop register ;
+
+GENERIC: to-loc ( operation -- obj )
+M: memory->memory to-loc drop memory ;
+M: register->memory to-loc drop memory ;
+M: memory->register to-loc drop register ;
+M: register->register to-loc drop register ;
+
+: from-reg ( operation -- seq )
+    [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
+
+: to-reg ( operation -- seq )
+    [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
+
+: (trace-chain) ( pair -- )
+    to-reg froms get at [
+        dup length 1 = [
+            first [ , ] [ (trace-chain) ] bi
+        ] [
+            drop
+        ] if
+    ] when* ;
+
+: trace-chain ( pair -- seq )
+    [ [ , ] [ (trace-chain) ] bi ] { } make reverse ;
+
+: start? ( operations -- pair )
+    from-reg tos get key? not ;
+
+: init-temp-spill ( operations -- )
+    [ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce
+    1 + temp-spill set ;
+
+: set-tos/froms ( operations -- )
+    {
+        [ [ from-reg ] collect-values froms set ]
+        [ [ to-reg ] collect-values tos set ]
+    } cleave ;
+
+: trace-chains ( operations -- operations' )
+    [ set-tos/froms ]
+    [ [ start? ] filter [ trace-chain ] map concat ] bi ;
+
+: break-cycle-n ( operations -- operations' )
+    unclip [ trace-chains ] dip
+    [
+        [ from>> temp-spill get ]
+        [ reg-class>> ] bi \ register->memory boa
+    ] [
+        [ to>> temp-spill [ get ] [ inc ] bi swap ]
+        [ reg-class>> ] bi \ memory->register boa
+    ] bi [ 1array ] bi@ surround ;
+
+: break-cycle ( operations -- operations' )
+    dup length {
+        { 1 [ drop { } ] }
+        [ drop break-cycle-n ]
+    } case ;
+
+: follow-cycle ( obj -- seq )
+   dup dup associate [
+        [ to-reg froms get at first dup dup ] dip
+        [ maybe-set-at ] keep swap
+    ] loop nip keys ;
+
+: (group-cycles) ( seq -- )
+    [
+        unclip follow-cycle [ diff ] keep , (group-cycles)
+    ] unless-empty ;
+
+: group-cycles ( seq -- seqs )
+    [ (group-cycles) ] { } make ;
+
+: partition-mappings ( mappings -- no-cycles cycles )
+    [ start? not ] partition
+    [ trace-chain ] map concat tuck diff ;
+
+: parallel-mappings ( operations -- seq )
+    partition-mappings [
+        group-cycles [ break-cycle ] map concat append
+    ] unless-empty ;
+
 : mapping-instructions ( mappings -- insns )
-    [ [ >insn ] each ] { } make ;
+    [
+        [ init-temp-spill ]
+        [ set-tos/froms ]
+        [ parallel-mappings ] tri
+        [ [ >insn ] each ] { } make
+    ] with-scope ;
 
 : fork? ( from to -- ? )
     [ successors>> length 1 >= ]
@@ -115,4 +227,4 @@ M: register->register >insn
     dup successors>> [ resolve-edge-data-flow ] with each ;
 
 : resolve-data-flow ( rpo -- )
-    [ resolve-block-data-flow ] each ;
\ No newline at end of file
+    [ resolve-block-data-flow ] each ;

From 12df05da5db49f85ceaf132e239217746fc460b5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 27 Jun 2009 17:32:37 -0500
Subject: [PATCH 08/42] compiler.cfg.stack-analysis: Fix case where both an
 ##inc-d/r and a ##peek get inserted

---
 .../cfg/stack-analysis/merge/merge.factor     | 10 ++--
 .../stack-analysis-tests.factor               | 49 ++++++++++++-------
 2 files changed, 37 insertions(+), 22 deletions(-)

diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor
index 25b0c30033..a17f31b956 100644
--- a/basis/compiler/cfg/stack-analysis/merge/merge.factor
+++ b/basis/compiler/cfg/stack-analysis/merge/merge.factor
@@ -42,20 +42,20 @@ IN: compiler.cfg.stack-analysis.merge
     [ [ keys ] map concat prune ] keep
     '[ dup _ [ at ] with map ] H{ } map>assoc ;
 
-: insert-peek ( predecessor state loc -- vreg )
-    '[ _ _ swap translate-loc ^^peek ] add-instructions ;
+: insert-peek ( predecessor loc -- vreg )
+    '[ _ ^^peek ] add-instructions ;
 
-: merge-loc ( predecessors states vregs loc -- vreg )
+: merge-loc ( predecessors vregs loc -- vreg )
     ! Insert a ##phi in the current block where the input
     ! is the vreg storing loc from each predecessor block
-    '[ dup [ 2nip ] [ drop _ insert-peek ] if ] 3map
+    '[ [ ] [ _ insert-peek ] ?if ] 2map
     dup all-equal? [ first ] [ ^^phi ] if ;
 
 :: merge-locs ( state predecessors states -- state )
     states [ locs>vregs>> ] map states collect-locs
     [| key value |
         key
-        predecessors states value key merge-loc
+        predecessors value key merge-loc
     ] assoc-map
     state translate-locs
     state (>>locs>vregs)
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index e01d870bf2..33bd0fadc9 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -8,26 +8,11 @@ sets namespaces arrays cpu.architecture ;
 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 ( cfg -- )
-    [
-        instructions>>
-        [
-            [ ##peek? ] filter [ loc>> ] map duplicates empty?
-            [ "Redundant peeks" throw ] unless
-        ] [
-            [ ##replace? ] filter [ loc>> ] map duplicates empty?
-            [ "Redundant replaces" throw ] unless
-        ] bi
-    ] each-basic-block ;
-
 : test-stack-analysis ( quot -- cfg )
     dup cfg? [ test-cfg first ] unless
     compute-predecessors
-    delete-useless-blocks
-    delete-useless-conditionals
     stack-analysis
-    dup check-cfg
-    dup check-for-redundant-ops ;
+    dup check-cfg ;
 
 : linearize ( cfg -- mr )
     flatten-cfg instructions>> ;
@@ -116,7 +101,7 @@ local-only? off
 ! Correct height tracking
 [ t ] [
     [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
-    reverse-post-order 2 swap nth
+    reverse-post-order 3 swap nth
     instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
     2array { D 1 D 0 } set=
 ] unit-test
@@ -144,4 +129,34 @@ local-only? off
     drop
 
     3 get instructions>> second loc>>
+] unit-test
+
+! Do inserted ##peeks reference the correct stack location if
+! an ##inc-d/r was also inserted?
+[ D 0 ] [
+    V{ T{ ##branch } } 0 test-bb
+
+    V{ T{ ##branch } } 1 test-bb
+
+    V{
+        T{ ##peek f V int-regs 1 D 0 }
+        T{ ##branch }
+    } 2 test-bb
+
+    V{
+        T{ ##call f \ + -1 }
+        T{ ##inc-d f 1 }
+        T{ ##branch }
+    } 3 test-bb
+
+    V{ T{ ##return } } 4 test-bb
+
+    test-diamond
+
+    cfg new 0 get >>entry
+    compute-predecessors
+    stack-analysis
+    drop
+
+    3 get instructions>> [ ##peek? ] find nip loc>>
 ] unit-test
\ No newline at end of file

From b2d3b588f0b3236c7382733c21fe5bbd9679ed63 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 28 Jun 2009 16:43:17 -0500
Subject: [PATCH 09/42] fix bug in linear-scan.resolve by rewriting entire
 algorithm

---
 .../linear-scan/resolve/resolve-tests.factor  | 147 ++++++++----------
 .../cfg/linear-scan/resolve/resolve.factor    |  82 +++++-----
 2 files changed, 110 insertions(+), 119 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index fad1c022ef..7579b46175 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -65,83 +65,15 @@ T{ live-interval
     1 get test-live-interval-2 reload-from
 ] unit-test
 
-[
-    {
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    }
-] [
-    {
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-    } trace-chains
-] unit-test
-
-[
-    {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    }
-] [
-    {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
-] unit-test
-
-[
-    {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    }
-] [
-    {
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
-] unit-test
-
-[
-    {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    }
-] [
-    {
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
-] unit-test
-
-[
-    {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    }
-] [
-    {
-        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
-] unit-test
-
 [
     {
         T{ _copy { dst 5 } { src 4 } { class int-regs } }
-        T{ _spill { src 1 } { class int-regs } { n 6 } }
-        T{ _copy { dst 1 } { src 0 } { class int-regs } }
-        T{ _reload { dst 0 } { class int-regs } { n 6 } }
-        T{ _spill { src 1 } { class float-regs } { n 7 } }
-        T{ _copy { dst 1 } { src 0 } { class float-regs } }
-        T{ _reload { dst 0 } { class float-regs } { n 7 } }
+        T{ _spill { src 0 } { class int-regs } { n 6 } }
+        T{ _copy { dst 0 } { src 1 } { class int-regs } }
+        T{ _reload { dst 1 } { class int-regs } { n 6 } }
+        T{ _spill { src 0 } { class float-regs } { n 7 } }
+        T{ _copy { dst 0 } { src 1 } { class float-regs } }
+        T{ _reload { dst 1 } { class float-regs } { n 7 } }
     }
 ] [
     {
@@ -155,10 +87,10 @@ T{ live-interval
 
 [
     {
-        T{ _spill { src 1 } { class int-regs } { n 3 } }
-        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _spill { src 0 } { class int-regs } { n 3 } }
         T{ _copy { dst 0 } { src 2 } { class int-regs } }
-        T{ _reload { dst 2 } { class int-regs } { n 3 } }
+        T{ _copy { dst 2 } { src 1 } { class int-regs } }
+        T{ _reload { dst 1 } { class int-regs } { n 3 } }
     }
 ] [
     {
@@ -170,10 +102,10 @@ T{ live-interval
 
 [
     {
-        T{ _spill { src 1 } { class int-regs } { n 3 } }
-        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _spill { src 0 } { class int-regs } { n 3 } }
         T{ _copy { dst 0 } { src 2 } { class int-regs } }
-        T{ _reload { dst 2 } { class int-regs } { n 3 } }
+        T{ _copy { dst 2 } { src 1 } { class int-regs } }
+        T{ _reload { dst 1 } { class int-regs } { n 3 } }
     }
 ] [
     {
@@ -210,3 +142,58 @@ T{ live-interval
        T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
     } mapping-instructions
 ] unit-test
+
+
+[
+    {
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 2 } { src 0 } { class int-regs } }
+        T{ _copy { dst 0 } { src 3 } { class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 2 } { src 0 } { class int-regs } }
+        T{ _spill { src 3 } { class int-regs } { n 5 } }
+        T{ _copy { dst 4 } { src 0 } { class int-regs } }
+        T{ _copy { dst 3 } { src 4 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n 5 } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _copy { dst 2 } { src 0 } { class int-regs } }
+        T{ _copy { dst 9 } { src 1 } { class int-regs } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _spill { src 3 } { class int-regs } { n 10 } }
+        T{ _copy { dst 4 } { src 0 } { class int-regs } }
+        T{ _copy { dst 3 } { src 4 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n 10 } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
+        T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index b29a661fbf..a9e3372fe4 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -3,9 +3,9 @@
 USING: accessors arrays assocs classes.parser classes.tuple
 combinators combinators.short-circuit compiler.cfg.instructions
 compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness
-fry hashtables histogram kernel locals make math math.order
+fry hashtables kernel locals make math math.order
 namespaces parser prettyprint random sequences sets
-sorting.functor sorting.slots words ;
+sorting.functor sorting.slots words io ;
 IN: compiler.cfg.linear-scan.resolve
 
 <<
@@ -114,38 +114,40 @@ M: register->register to-loc drop register ;
 : to-reg ( operation -- seq )
     [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
 
-: (trace-chain) ( pair -- )
-    to-reg froms get at [
-        dup length 1 = [
-            first [ , ] [ (trace-chain) ] bi
-        ] [
-            drop
-        ] if
-    ] when* ;
-
-: trace-chain ( pair -- seq )
-    [ [ , ] [ (trace-chain) ] bi ] { } make reverse ;
-
 : start? ( operations -- pair )
     from-reg tos get key? not ;
 
+: independent-assignment? ( operations -- pair )
+    to-reg froms get key? not ;
+
 : init-temp-spill ( operations -- )
     [ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce
     1 + temp-spill set ;
 
 : set-tos/froms ( operations -- )
     {
-        [ [ from-reg ] collect-values froms set ]
-        [ [ to-reg ] collect-values tos set ]
+        [ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
+        [ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
     } cleave ;
 
-: trace-chains ( operations -- operations' )
-    [ set-tos/froms ]
-    [ [ start? ] filter [ trace-chain ] map concat ] bi ;
+:: (trace-chain) ( obj hashtable -- )
+    obj to-reg froms get at* [
+        obj over hashtable clone [ maybe-set-at ] keep swap
+        [ (trace-chain) ] [ , drop ] if
+    ] [
+        drop hashtable ,
+    ] if ;
+
+: trace-chain ( obj -- seq )
+    [
+        dup dup associate (trace-chain)
+    ] { } make [ keys ] map concat reverse ;
+
+: trace-chains ( seq -- seq' )
+    [ trace-chain ] map concat ;
 
 : break-cycle-n ( operations -- operations' )
-    unclip [ trace-chains ] dip
-    [
+    unclip [
         [ from>> temp-spill get ]
         [ reg-class>> ] bi \ register->memory boa
     ] [
@@ -155,32 +157,30 @@ M: register->register to-loc drop register ;
 
 : break-cycle ( operations -- operations' )
     dup length {
-        { 1 [ drop { } ] }
+        { 1 [ ] }
         [ drop break-cycle-n ]
     } case ;
 
-: follow-cycle ( obj -- seq )
-   dup dup associate [
-        [ to-reg froms get at first dup dup ] dip
-        [ maybe-set-at ] keep swap
-    ] loop nip keys ;
-
 : (group-cycles) ( seq -- )
     [
-        unclip follow-cycle [ diff ] keep , (group-cycles)
+        dup set-tos/froms
+        unclip trace-chain
+        [ diff ] keep , (group-cycles)
     ] unless-empty ;
 
 : group-cycles ( seq -- seqs )
     [ (group-cycles) ] { } make ;
 
-: partition-mappings ( mappings -- no-cycles cycles )
-    [ start? not ] partition
-    [ trace-chain ] map concat tuck diff ;
+: remove-dead-mappings ( seq -- seq' )
+    prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
 
 : parallel-mappings ( operations -- seq )
-    partition-mappings [
-        group-cycles [ break-cycle ] map concat append
-    ] unless-empty ;
+    [
+        [ independent-assignment? not ] partition %
+        [ start? not ] partition
+        [ trace-chain ] map concat dup %
+        diff group-cycles [ break-cycle ] map concat %
+    ] { } make remove-dead-mappings ;
 
 : mapping-instructions ( mappings -- insns )
     [
@@ -191,15 +191,19 @@ M: register->register to-loc drop register ;
     ] with-scope ;
 
 : fork? ( from to -- ? )
-    [ successors>> length 1 >= ]
-    [ predecessors>> length 1 = ] bi* and ; inline
+    {
+        [ drop successors>> length 1 >= ]
+        [ nip predecessors>> length 1 = ]
+    } 2&& ; inline
 
 : insert-position/fork ( from to -- before after )
     nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
 
 : join? ( from to -- ? )
-    [ successors>> length 1 = ]
-    [ predecessors>> length 1 >= ] bi* and ; inline
+    {
+        [ drop successors>> length 1 = ]
+        [ nip predecessors>> length 1 >= ]
+    } 2&& ; inline
 
 : insert-position/join ( from to -- before after )
     drop instructions>> dup pop 1array ;

From b63133f9f6bb42bca7a9c85e4edb869b5e1a49c7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 28 Jun 2009 22:52:28 -0500
Subject: [PATCH 10/42] compiler.cfg.stack-analysis: fix another corner case
 with ##peek insertion, and fix changed-loc merging

---
 .../cfg/stack-analysis/merge/merge.factor     | 25 ++++++-----
 .../stack-analysis-tests.factor               | 44 +++++++++++++++++++
 .../cfg/stack-analysis/stack-analysis.factor  |  6 +--
 3 files changed, 61 insertions(+), 14 deletions(-)

diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor
index a17f31b956..04643a31f0 100644
--- a/basis/compiler/cfg/stack-analysis/merge/merge.factor
+++ b/basis/compiler/cfg/stack-analysis/merge/merge.factor
@@ -37,25 +37,25 @@ IN: compiler.cfg.stack-analysis.merge
     '[ _ untranslate-loc ] assoc-map-values ;
 
 : collect-locs ( loc-maps states -- assoc )
-    ! assoc maps locs to sequences of vregs
+    ! assoc maps locs to sequences
     [ untranslate-locs ] 2map
     [ [ keys ] map concat prune ] keep
     '[ dup _ [ at ] with map ] H{ } map>assoc ;
 
-: insert-peek ( predecessor loc -- vreg )
-    '[ _ ^^peek ] add-instructions ;
+: insert-peek ( predecessor loc state -- vreg )
+    '[ _ _ translate-loc ^^peek ] add-instructions ;
 
-: merge-loc ( predecessors vregs loc -- vreg )
+: merge-loc ( predecessors vregs loc state -- vreg )
     ! Insert a ##phi in the current block where the input
     ! is the vreg storing loc from each predecessor block
-    '[ [ ] [ _ insert-peek ] ?if ] 2map
+    '[ [ ] [ _ _ insert-peek ] ?if ] 2map
     dup all-equal? [ first ] [ ^^phi ] if ;
 
 :: merge-locs ( state predecessors states -- state )
     states [ locs>vregs>> ] map states collect-locs
     [| key value |
         key
-        predecessors value key merge-loc
+        predecessors value key state merge-loc
     ] assoc-map
     state translate-locs
     state (>>locs>vregs)
@@ -64,14 +64,17 @@ IN: compiler.cfg.stack-analysis.merge
 : merge-actual-loc ( vregs -- vreg/f )
     dup all-equal? [ first ] [ drop f ] if ;
 
-: merge-actual-locs ( state states -- state )
-    [ [ actual-locs>vregs>> ] map ] keep collect-locs
+:: merge-actual-locs ( state states -- state )
+    states [ actual-locs>vregs>> ] map states collect-locs
     [ merge-actual-loc ] assoc-map [ nip ] assoc-filter
-    over translate-locs
-    >>actual-locs>vregs ;
+    state translate-locs
+    state (>>actual-locs>vregs)
+    state ;
 
 : merge-changed-locs ( state states -- state )
-    [ changed-locs>> ] map assoc-combine >>changed-locs ;
+    [ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine
+    over translate-locs
+    >>changed-locs ;
 
 ERROR: cannot-merge-poisoned states ;
 
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index 33bd0fadc9..8dd698a6d5 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -158,5 +158,49 @@ local-only? off
     stack-analysis
     drop
 
+    3 get instructions>> [ ##peek? ] find nip loc>>
+] unit-test
+
+! Missing ##replace
+[ t ] [
+    [ 0 2over dup not [ [ /mod ] dip ] when ] test-stack-analysis
+    reverse-post-order last
+    instructions>> [ ##replace? ] filter [ loc>> ] map
+    { D 0 D 1 D 2 } set=
+] unit-test
+
+! Inserted ##peeks reference the wrong stack location
+[ t ] [
+    [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
+    eliminate-dead-code reverse-post-order 3 swap nth
+    instructions>> [ ##peek? ] filter [ loc>> ] map
+    { D 1 D 2 } set=
+] unit-test
+
+[ D 0 ] [
+    V{ T{ ##branch } } 0 test-bb
+
+    V{ T{ ##branch } } 1 test-bb
+
+    V{
+        T{ ##peek f V int-regs 1 D 0 }
+        T{ ##inc-d f 1 }
+        T{ ##branch }
+    } 2 test-bb
+
+    V{
+        T{ ##inc-d f 1 }
+        T{ ##branch }
+    } 3 test-bb
+
+    V{ T{ ##return } } 4 test-bb
+
+    test-diamond
+
+    cfg new 0 get >>entry
+    compute-predecessors
+    stack-analysis
+    drop
+
     3 get instructions>> [ ##peek? ] find nip loc>>
 ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index 0e06a2fdf5..5679d8bd11 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -18,10 +18,10 @@ IN: compiler.cfg.stack-analysis
     [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
 
 : save-changed-locs ( state -- )
-    [ changed-locs>> ] [ locs>vregs>> ] bi '[
-        _ at swap 2dup redundant-replace?
+    [ changed-locs>> keys ] [ locs>vregs>> ] bi '[
+        dup _ at swap 2dup redundant-replace?
         [ 2drop ] [ state get untranslate-loc ##replace ] if
-    ] assoc-each ;
+    ] each ;
 
 ERROR: poisoned-state state ;
 

From 5754bf0028ad1f91c00c60e9c3dad021b55e021e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 28 Jun 2009 22:58:35 -0500
Subject: [PATCH 11/42] compiler.cfg.linear-scan.resolve: remove redundant
 vocabs from using list

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

diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index b29a661fbf..3901971873 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -1,11 +1,10 @@
 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes.parser classes.tuple
-combinators combinators.short-circuit compiler.cfg.instructions
-compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness
-fry hashtables histogram kernel locals make math math.order
-namespaces parser prettyprint random sequences sets
-sorting.functor sorting.slots words ;
+combinators combinators.short-circuit fry hashtables kernel locals
+make math math.order namespaces sequences sets words parser histogram
+compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals
+compiler.cfg.liveness ;
 IN: compiler.cfg.linear-scan.resolve
 
 <<
@@ -134,10 +133,9 @@ M: register->register to-loc drop register ;
     1 + temp-spill set ;
 
 : set-tos/froms ( operations -- )
-    {
-        [ [ from-reg ] collect-values froms set ]
-        [ [ to-reg ] collect-values tos set ]
-    } cleave ;
+    [ [ from-reg ] collect-values froms set ]
+    [ [ to-reg ] collect-values tos set ]
+    bi ;
 
 : trace-chains ( operations -- operations' )
     [ set-tos/froms ]

From c2d4c422522ce6cab2731ac588c0eb23b98d59d7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 29 Jun 2009 01:59:53 -0500
Subject: [PATCH 12/42] Fix conflict

---
 .../linear-scan/resolve/resolve-tests.factor  | 147 ++++++++----------
 .../cfg/linear-scan/resolve/resolve.factor    |  80 +++++-----
 2 files changed, 109 insertions(+), 118 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index fad1c022ef..7579b46175 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -65,83 +65,15 @@ T{ live-interval
     1 get test-live-interval-2 reload-from
 ] unit-test
 
-[
-    {
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    }
-] [
-    {
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-    } trace-chains
-] unit-test
-
-[
-    {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    }
-] [
-    {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
-] unit-test
-
-[
-    {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    }
-] [
-    {
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
-] unit-test
-
-[
-    {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    }
-] [
-    {
-        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
-] unit-test
-
-[
-    {
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    }
-] [
-    {
-        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
-        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
-        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
-    } trace-chains
-] unit-test
-
 [
     {
         T{ _copy { dst 5 } { src 4 } { class int-regs } }
-        T{ _spill { src 1 } { class int-regs } { n 6 } }
-        T{ _copy { dst 1 } { src 0 } { class int-regs } }
-        T{ _reload { dst 0 } { class int-regs } { n 6 } }
-        T{ _spill { src 1 } { class float-regs } { n 7 } }
-        T{ _copy { dst 1 } { src 0 } { class float-regs } }
-        T{ _reload { dst 0 } { class float-regs } { n 7 } }
+        T{ _spill { src 0 } { class int-regs } { n 6 } }
+        T{ _copy { dst 0 } { src 1 } { class int-regs } }
+        T{ _reload { dst 1 } { class int-regs } { n 6 } }
+        T{ _spill { src 0 } { class float-regs } { n 7 } }
+        T{ _copy { dst 0 } { src 1 } { class float-regs } }
+        T{ _reload { dst 1 } { class float-regs } { n 7 } }
     }
 ] [
     {
@@ -155,10 +87,10 @@ T{ live-interval
 
 [
     {
-        T{ _spill { src 1 } { class int-regs } { n 3 } }
-        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _spill { src 0 } { class int-regs } { n 3 } }
         T{ _copy { dst 0 } { src 2 } { class int-regs } }
-        T{ _reload { dst 2 } { class int-regs } { n 3 } }
+        T{ _copy { dst 2 } { src 1 } { class int-regs } }
+        T{ _reload { dst 1 } { class int-regs } { n 3 } }
     }
 ] [
     {
@@ -170,10 +102,10 @@ T{ live-interval
 
 [
     {
-        T{ _spill { src 1 } { class int-regs } { n 3 } }
-        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _spill { src 0 } { class int-regs } { n 3 } }
         T{ _copy { dst 0 } { src 2 } { class int-regs } }
-        T{ _reload { dst 2 } { class int-regs } { n 3 } }
+        T{ _copy { dst 2 } { src 1 } { class int-regs } }
+        T{ _reload { dst 1 } { class int-regs } { n 3 } }
     }
 ] [
     {
@@ -210,3 +142,58 @@ T{ live-interval
        T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
     } mapping-instructions
 ] unit-test
+
+
+[
+    {
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 2 } { src 0 } { class int-regs } }
+        T{ _copy { dst 0 } { src 3 } { class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 2 } { src 0 } { class int-regs } }
+        T{ _spill { src 3 } { class int-regs } { n 5 } }
+        T{ _copy { dst 4 } { src 0 } { class int-regs } }
+        T{ _copy { dst 3 } { src 4 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n 5 } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _copy { dst 2 } { src 0 } { class int-regs } }
+        T{ _copy { dst 9 } { src 1 } { class int-regs } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _spill { src 3 } { class int-regs } { n 10 } }
+        T{ _copy { dst 4 } { src 0 } { class int-regs } }
+        T{ _copy { dst 3 } { src 4 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n 10 } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
+        T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index 3901971873..182686a0fa 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs classes.parser classes.tuple
 combinators combinators.short-circuit fry hashtables kernel locals
-make math math.order namespaces sequences sets words parser histogram
+make math math.order namespaces sequences sets words parser
 compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals
 compiler.cfg.liveness ;
 IN: compiler.cfg.linear-scan.resolve
@@ -113,37 +113,39 @@ M: register->register to-loc drop register ;
 : to-reg ( operation -- seq )
     [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
 
-: (trace-chain) ( pair -- )
-    to-reg froms get at [
-        dup length 1 = [
-            first [ , ] [ (trace-chain) ] bi
-        ] [
-            drop
-        ] if
-    ] when* ;
-
-: trace-chain ( pair -- seq )
-    [ [ , ] [ (trace-chain) ] bi ] { } make reverse ;
-
 : start? ( operations -- pair )
     from-reg tos get key? not ;
 
+: independent-assignment? ( operations -- pair )
+    to-reg froms get key? not ;
+
 : init-temp-spill ( operations -- )
     [ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce
     1 + temp-spill set ;
 
 : set-tos/froms ( operations -- )
-    [ [ from-reg ] collect-values froms set ]
-    [ [ to-reg ] collect-values tos set ]
+    [ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
+    [ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
     bi ;
 
-: trace-chains ( operations -- operations' )
-    [ set-tos/froms ]
-    [ [ start? ] filter [ trace-chain ] map concat ] bi ;
+:: (trace-chain) ( obj hashtable -- )
+    obj to-reg froms get at* [
+        obj over hashtable clone [ maybe-set-at ] keep swap
+        [ (trace-chain) ] [ , drop ] if
+    ] [
+        drop hashtable ,
+    ] if ;
+
+: trace-chain ( obj -- seq )
+    [
+        dup dup associate (trace-chain)
+    ] { } make [ keys ] map concat reverse ;
+
+: trace-chains ( seq -- seq' )
+    [ trace-chain ] map concat ;
 
 : break-cycle-n ( operations -- operations' )
-    unclip [ trace-chains ] dip
-    [
+    unclip [
         [ from>> temp-spill get ]
         [ reg-class>> ] bi \ register->memory boa
     ] [
@@ -153,32 +155,30 @@ M: register->register to-loc drop register ;
 
 : break-cycle ( operations -- operations' )
     dup length {
-        { 1 [ drop { } ] }
+        { 1 [ ] }
         [ drop break-cycle-n ]
     } case ;
 
-: follow-cycle ( obj -- seq )
-   dup dup associate [
-        [ to-reg froms get at first dup dup ] dip
-        [ maybe-set-at ] keep swap
-    ] loop nip keys ;
-
 : (group-cycles) ( seq -- )
     [
-        unclip follow-cycle [ diff ] keep , (group-cycles)
+        dup set-tos/froms
+        unclip trace-chain
+        [ diff ] keep , (group-cycles)
     ] unless-empty ;
 
 : group-cycles ( seq -- seqs )
     [ (group-cycles) ] { } make ;
 
-: partition-mappings ( mappings -- no-cycles cycles )
-    [ start? not ] partition
-    [ trace-chain ] map concat tuck diff ;
+: remove-dead-mappings ( seq -- seq' )
+    prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
 
 : parallel-mappings ( operations -- seq )
-    partition-mappings [
-        group-cycles [ break-cycle ] map concat append
-    ] unless-empty ;
+    [
+        [ independent-assignment? not ] partition %
+        [ start? not ] partition
+        [ trace-chain ] map concat dup %
+        diff group-cycles [ break-cycle ] map concat %
+    ] { } make remove-dead-mappings ;
 
 : mapping-instructions ( mappings -- insns )
     [
@@ -189,15 +189,19 @@ M: register->register to-loc drop register ;
     ] with-scope ;
 
 : fork? ( from to -- ? )
-    [ successors>> length 1 >= ]
-    [ predecessors>> length 1 = ] bi* and ; inline
+    {
+        [ drop successors>> length 1 >= ]
+        [ nip predecessors>> length 1 = ]
+    } 2&& ; inline
 
 : insert-position/fork ( from to -- before after )
     nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
 
 : join? ( from to -- ? )
-    [ successors>> length 1 = ]
-    [ predecessors>> length 1 >= ] bi* and ; inline
+    {
+        [ drop successors>> length 1 = ]
+        [ nip predecessors>> length 1 >= ]
+    } 2&& ; inline
 
 : insert-position/join ( from to -- before after )
     drop instructions>> dup pop 1array ;

From 9b1796cd2682edcb07013e6d81fa81a942539801 Mon Sep 17 00:00:00 2001
From: Samuel Tardieu <sam@rfc1149.net>
Date: Mon, 29 Jun 2009 16:55:44 +0200
Subject: [PATCH 13/42] Add divisors to math.primes.factors

---
 basis/math/primes/factors/factors-docs.factor  | 6 +++++-
 basis/math/primes/factors/factors-tests.factor | 4 +++-
 basis/math/primes/factors/factors.factor       | 6 +++++-
 3 files changed, 13 insertions(+), 3 deletions(-)

diff --git a/basis/math/primes/factors/factors-docs.factor b/basis/math/primes/factors/factors-docs.factor
index f9fe4d5dcb..b22d1ba1a5 100644
--- a/basis/math/primes/factors/factors-docs.factor
+++ b/basis/math/primes/factors/factors-docs.factor
@@ -1,7 +1,7 @@
 USING: help.markup help.syntax math sequences ;
 IN: math.primes.factors
 
-{ factors group-factors unique-factors } related-words
+{ divisors factors group-factors unique-factors } related-words
 
 HELP: factors
 { $values { "n" "a positive integer" } { "seq" sequence } }
@@ -21,3 +21,7 @@ HELP: unique-factors
 HELP: totient
 { $values { "n" "a positive integer" } { "t" integer } }
 { $description { "Return the number of integers between 1 and " { $snippet "n-1" } " that are relatively prime to " { $snippet "n" } "." } } ;
+
+HELP: divisors
+{ $values { "n" "a positive integer" } { "seq" sequence } }
+{ $description { "Return the ordered list of divisors of " { $snippet "n" } ", including 1 and " { $snippet "n" } "." } } ;
diff --git a/basis/math/primes/factors/factors-tests.factor b/basis/math/primes/factors/factors-tests.factor
index 8e2e10711a..eea59b6f9b 100644
--- a/basis/math/primes/factors/factors-tests.factor
+++ b/basis/math/primes/factors/factors-tests.factor
@@ -1,4 +1,4 @@
-USING: math.primes.factors tools.test ;
+USING: math.primes.factors sequences tools.test ;
 
 { { 999983 999983 1000003 } } [ 999969000187000867 factors ] unit-test
 { { } } [ -5 factors ] unit-test
@@ -8,3 +8,5 @@ USING: math.primes.factors tools.test ;
 { 0 } [ 1 totient ] unit-test
 { { 425612003 } } [ 425612003 factors ] unit-test
 { { 13 4253 15823 32472893749823741 } } [ 28408516453955558205925627 factors ] unit-test
+{ { 1 2 3 4 6 8 12 24 } } [ 24 divisors ] unit-test
+{ 24 } [ 360 divisors length ] unit-test
diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor
index f5fa468687..439d55ee8d 100644
--- a/basis/math/primes/factors/factors.factor
+++ b/basis/math/primes/factors/factors.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays combinators kernel make math math.functions
-math.primes sequences ;
+math.primes math.ranges sequences sequences.product sorting ;
 IN: math.primes.factors
 
 <PRIVATE
@@ -41,3 +41,7 @@ PRIVATE>
         { [ dup 2 < ] [ drop 0 ] }
         [ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ]
     } cond ; foldable
+
+: divisors ( n -- seq )
+    group-factors [ first2 [0,b] [ ^ ] with map ] map
+    [ product ] product-map natural-sort ;

From 7fc239d638b582f001cf83e004363220953d1940 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 29 Jun 2009 16:37:40 -0500
Subject: [PATCH 14/42] compiler.cfg.stack-analysis: fix typos in unit tests

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

diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index 8dd698a6d5..1bef0c3967 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -163,7 +163,7 @@ local-only? off
 
 ! Missing ##replace
 [ t ] [
-    [ 0 2over dup not [ [ /mod ] dip ] when ] test-stack-analysis
+    [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
     reverse-post-order last
     instructions>> [ ##replace? ] filter [ loc>> ] map
     { D 0 D 1 D 2 } set=
@@ -174,7 +174,7 @@ local-only? off
     [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
     eliminate-dead-code reverse-post-order 3 swap nth
     instructions>> [ ##peek? ] filter [ loc>> ] map
-    { D 1 D 2 } set=
+    { R 0 D 0 D 1 } set=
 ] unit-test
 
 [ D 0 ] [

From 6044d2fb50dbe25b034900840580cfe5b5303c95 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 30 Jun 2009 14:56:58 -0500
Subject: [PATCH 15/42] working on imagebin

---
 extra/webapps/imagebin/imagebin.factor | 23 ++++++++++++++++++-----
 1 file changed, 18 insertions(+), 5 deletions(-)

diff --git a/extra/webapps/imagebin/imagebin.factor b/extra/webapps/imagebin/imagebin.factor
index f347377d95..7c63c51eee 100755
--- a/extra/webapps/imagebin/imagebin.factor
+++ b/extra/webapps/imagebin/imagebin.factor
@@ -1,10 +1,15 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel furnace.actions html.forms
-http.server.dispatchers db db.tuples db.types urls
-furnace.redirection multiline http namespaces ;
+USING: accessors db db.tuples db.types furnace.actions
+furnace.redirection html.forms http http.server
+http.server.dispatchers io.directories io.pathnames kernel
+multiline namespaces urls ;
 IN: webapps.imagebin
 
+SYMBOL: image-directory
+
+image-directory [ "resource:images" ] initialize
+
 TUPLE: imagebin < dispatcher ;
 
 TUPLE: image id path ;
@@ -16,24 +21,32 @@ image "IMAGE" {
 
 : <uploaded-image-action> ( -- action )
     <page-action>
+        image-directory get >>temporary-directory
         { imagebin "uploaded-image" } >>template ;
 
 SYMBOL: my-post-data
 : <upload-image-action> ( -- action )
     <page-action>
         { imagebin "upload-image" } >>template
+        image-directory get >>temporary-directory
         [
-            
-            ! request get post-data>> my-post-data set-global
+            "file1" param [
+                temporary-path>> image-directory get move-file
+            ] when*
             ! image new
             !    "file" value
                 ! insert-tuple
             "uploaded-image" <redirect>
         ] >>submit ;
 
+: initialize-image-directory ( -- )
+    image-directory get make-directories ;
+
 : <imagebin> ( -- responder )
     imagebin new-dispatcher
         <upload-image-action> "" add-responder
         <upload-image-action> "upload-image" add-responder
         <uploaded-image-action> "uploaded-image" add-responder ;
 
+initialize-image-directory
+<imagebin> main-responder set-global

From 5ae6eb089d22c6c9622508a6e118454bafcfc17f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 30 Jun 2009 15:31:48 -0500
Subject: [PATCH 16/42] add branch splitting pass to compiler.cfg

---
 .../compiler/cfg/branch-splitting/authors.txt |  1 +
 .../branch-splitting/branch-splitting.factor  | 29 +++++++++++++++++++
 2 files changed, 30 insertions(+)
 create mode 100644 basis/compiler/cfg/branch-splitting/authors.txt
 create mode 100644 basis/compiler/cfg/branch-splitting/branch-splitting.factor

diff --git a/basis/compiler/cfg/branch-splitting/authors.txt b/basis/compiler/cfg/branch-splitting/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/compiler/cfg/branch-splitting/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
new file mode 100644
index 0000000000..2b3d88191c
--- /dev/null
+++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
@@ -0,0 +1,29 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit compiler.cfg.def-use
+compiler.cfg.rpo kernel math sequences ;
+IN: compiler.cfg.branch-splitting
+
+: split-branch ( branch -- )
+    [
+        [ instructions>> ] [ predecessors>> ] bi [
+            instructions>> [ pop* ] [ push-all ] bi
+        ] with each
+    ] [
+        [ successors>> ] [ predecessors>> ] bi [
+            [ drop clone ] change-successors drop
+        ] with each
+    ] bi ;
+
+: split-branches? ( bb -- ? )
+    {
+        [ predecessors>> length 1 >= ]
+        [ successors>> length 1 <= ]
+        [ instructions>> [ defs-vregs ] any? not ]
+        [ instructions>> [ temp-vregs ] any? not ]
+    } 1&& ;
+
+: split-branches ( cfg -- cfg' )
+    dup [
+        dup split-branches? [ split-branch ] [ drop ] if
+    ] each-basic-block f >>post-order ;

From d888d13efe7e1cdce044881badd9d89708775677 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 30 Jun 2009 15:40:13 -0500
Subject: [PATCH 17/42] spill to spill-temp, not to virtual spill addresses

---
 .../linear-scan/resolve/resolve-tests.factor  | 26 +++++++++----------
 .../cfg/linear-scan/resolve/resolve.factor    | 20 +++++---------
 2 files changed, 20 insertions(+), 26 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index 7579b46175..df9f29e999 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -68,12 +68,12 @@ T{ live-interval
 [
     {
         T{ _copy { dst 5 } { src 4 } { class int-regs } }
-        T{ _spill { src 0 } { class int-regs } { n 6 } }
+        T{ _spill { src 0 } { class int-regs } { n spill-temp } }
         T{ _copy { dst 0 } { src 1 } { class int-regs } }
-        T{ _reload { dst 1 } { class int-regs } { n 6 } }
-        T{ _spill { src 0 } { class float-regs } { n 7 } }
+        T{ _reload { dst 1 } { class int-regs } { n spill-temp } }
+        T{ _spill { src 0 } { class float-regs } { n spill-temp } }
         T{ _copy { dst 0 } { src 1 } { class float-regs } }
-        T{ _reload { dst 1 } { class float-regs } { n 7 } }
+        T{ _reload { dst 1 } { class float-regs } { n spill-temp } }
     }
 ] [
     {
@@ -87,10 +87,10 @@ T{ live-interval
 
 [
     {
-        T{ _spill { src 0 } { class int-regs } { n 3 } }
+        T{ _spill { src 0 } { class int-regs } { n spill-temp } }
         T{ _copy { dst 0 } { src 2 } { class int-regs } }
         T{ _copy { dst 2 } { src 1 } { class int-regs } }
-        T{ _reload { dst 1 } { class int-regs } { n 3 } }
+        T{ _reload { dst 1 } { class int-regs } { n spill-temp } }
     }
 ] [
     {
@@ -102,10 +102,10 @@ T{ live-interval
 
 [
     {
-        T{ _spill { src 0 } { class int-regs } { n 3 } }
+        T{ _spill { src 0 } { class int-regs } { n spill-temp } }
         T{ _copy { dst 0 } { src 2 } { class int-regs } }
         T{ _copy { dst 2 } { src 1 } { class int-regs } }
-        T{ _reload { dst 1 } { class int-regs } { n 3 } }
+        T{ _reload { dst 1 } { class int-regs } { n spill-temp } }
     }
 ] [
     {
@@ -136,7 +136,7 @@ T{ live-interval
 ] unit-test
 
 [
-    { T{ _spill { src 4 } { class int-regs } { n 4 } } }
+    { T{ _spill { src 4 } { class int-regs } { n spill-temp } } }
 ] [
     {
        T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
@@ -162,10 +162,10 @@ T{ live-interval
     {
         T{ _copy { dst 1 } { src 0 } { class int-regs } }
         T{ _copy { dst 2 } { src 0 } { class int-regs } }
-        T{ _spill { src 3 } { class int-regs } { n 5 } }
+        T{ _spill { src 3 } { class int-regs } { n spill-temp } }
         T{ _copy { dst 4 } { src 0 } { class int-regs } }
         T{ _copy { dst 3 } { src 4 } { class int-regs } }
-        T{ _reload { dst 0 } { class int-regs } { n 5 } }
+        T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
     }
 ] [
     {
@@ -182,10 +182,10 @@ T{ live-interval
         T{ _copy { dst 2 } { src 0 } { class int-regs } }
         T{ _copy { dst 9 } { src 1 } { class int-regs } }
         T{ _copy { dst 1 } { src 0 } { class int-regs } }
-        T{ _spill { src 3 } { class int-regs } { n 10 } }
+        T{ _spill { src 3 } { class int-regs } { n spill-temp } }
         T{ _copy { dst 4 } { src 0 } { class int-regs } }
         T{ _copy { dst 3 } { src 4 } { class int-regs } }
-        T{ _reload { dst 0 } { class int-regs } { n 10 } }
+        T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
     }
 ] [
     {
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index 182686a0fa..b996520546 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -68,10 +68,10 @@ M: memory->memory >insn
     [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
 
 M: register->memory >insn
-    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
+    [ from>> ] [ reg-class>> ] bi spill-temp _spill ;
 
 M: memory->register >insn
-    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
+    [ to>> ] [ reg-class>> ] bi spill-temp _reload ;
 
 M: register->register >insn
     [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
@@ -82,10 +82,10 @@ M: memory->memory >collision-table
     [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
 
 M: register->memory >collision-table
-    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
+    [ from>> ] [ reg-class>> ] bi spill-temp _spill ;
 
 M: memory->register >collision-table
-    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
+    [ to>> ] [ reg-class>> ] bi spill-temp _reload ;
 
 M: register->register >collision-table
     [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
@@ -119,10 +119,6 @@ M: register->register to-loc drop register ;
 : independent-assignment? ( operations -- pair )
     to-reg froms get key? not ;
 
-: init-temp-spill ( operations -- )
-    [ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce
-    1 + temp-spill set ;
-
 : set-tos/froms ( operations -- )
     [ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
     [ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
@@ -146,10 +142,10 @@ M: register->register to-loc drop register ;
 
 : break-cycle-n ( operations -- operations' )
     unclip [
-        [ from>> temp-spill get ]
+        [ from>> spill-temp ]
         [ reg-class>> ] bi \ register->memory boa
     ] [
-        [ to>> temp-spill [ get ] [ inc ] bi swap ]
+        [ to>> spill-temp swap ]
         [ reg-class>> ] bi \ memory->register boa
     ] bi [ 1array ] bi@ surround ;
 
@@ -182,9 +178,7 @@ M: register->register to-loc drop register ;
 
 : mapping-instructions ( mappings -- insns )
     [
-        [ init-temp-spill ]
-        [ set-tos/froms ]
-        [ parallel-mappings ] tri
+        [ set-tos/froms ] [ parallel-mappings ] bi
         [ [ >insn ] each ] { } make
     ] with-scope ;
 

From ecf44c98bce196c4207a77274a8118ca2b4475cd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 16:07:58 -0500
Subject: [PATCH 18/42] compiler.cfg.linear-scan: compute-free-pos was broken
 in the case where more than one inactive interval had the same physical
 register assigned

---
 .../linear-scan/allocation/allocation.factor  | 24 +++++---
 .../linear-scan/assignment/assignment.factor  | 10 +++-
 .../cfg/linear-scan/linear-scan-tests.factor  | 56 ++++++++++++++++++-
 3 files changed, 79 insertions(+), 11 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 4425050d4b..d948fe37ff 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs heaps kernel namespaces sequences fry math
-combinators arrays sorting compiler.utilities
+math.order combinators arrays sorting compiler.utilities
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation.coalescing
 compiler.cfg.linear-scan.allocation.spilling
@@ -12,17 +12,23 @@ IN: compiler.cfg.linear-scan.allocation
 : free-positions ( new -- assoc )
     vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
 
-: active-positions ( new -- assoc )
-    vreg>> active-intervals-for [ reg>> 0 ] H{ } map>assoc ;
+: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
 
-: inactive-positions ( new -- assoc )
-    dup vreg>> inactive-intervals-for
-    [ [ reg>> swap ] keep relevant-ranges intersect-live-ranges ]
-    with H{ } map>assoc ;
+: active-positions ( new assoc -- )
+    [ vreg>> active-intervals-for ] dip
+    '[ [ 0 ] dip reg>> _ add-use-position ] each ;
+
+: inactive-positions ( new assoc -- )
+    [ [ vreg>> inactive-intervals-for ] keep ] dip
+    '[
+        [ _ relevant-ranges intersect-live-ranges ] [ reg>> ] bi
+        _ add-use-position
+    ] each ;
 
 : compute-free-pos ( new -- free-pos )
-    [ free-positions ] [ inactive-positions ] [ active-positions ] tri
-    3array assoc-combine >alist alist-max ;
+    dup free-positions
+    [ inactive-positions ] [ active-positions ] [ nip ] 2tri
+    >alist alist-max ;
 
 : no-free-registers? ( result -- ? )
     second 0 = ; inline
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index e55f42e774..1a7f32a0ea 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -104,8 +104,16 @@ GENERIC: assign-registers-in-insn ( insn -- )
 : all-vregs ( insn -- vregs )
     [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
 
+SYMBOL: check-assignment?
+
+ERROR: overlapping-registers intervals ;
+
 : active-intervals ( insn -- intervals )
-    insn#>> pending-intervals get [ covers? ] with filter ;
+    insn#>> pending-intervals get [ covers? ] with filter
+    check-assignment? get [
+        dup [ reg>> ] map all-unique?
+        [ overlapping-registers ] unless
+    ] when ;
 
 M: vreg-insn assign-registers-in-insn
     dup [ active-intervals ] [ all-vregs ] bi
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 49352da0f7..5d11e2a5a0 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -18,10 +18,12 @@ compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.allocation.splitting
 compiler.cfg.linear-scan.allocation.spilling
-compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.debugger ;
 
+FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
+
 check-allocation? on
+check-assignment? on
 
 [
     { T{ live-range f 1 10 } T{ live-range f 15 15 } }
@@ -1417,6 +1419,58 @@ USING: math.private ;
     relevant-ranges intersect-live-ranges
 ] unit-test
 
+! compute-free-pos had problems because it used map>assoc where the sequence
+! had multiple keys
+[ { 0 10 } ] [
+    H{ { int-regs { 0 1 } } } registers set
+    H{
+        { int-regs
+          {
+              T{ live-interval
+                 { vreg V int-regs 1 }
+                 { start 0 }
+                 { end 20 }
+                 { reg 0 }
+                 { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
+                 { uses V{ 0 2 10 20 } }
+              }
+
+              T{ live-interval
+                 { vreg V int-regs 2 }
+                 { start 4 }
+                 { end 40 }
+                 { reg 0 }
+                 { ranges V{ T{ live-range f 4 6 } T{ live-range f 30 40 } } }
+                 { uses V{ 4 6 30 40 } }
+              }
+          }
+        }
+    } inactive-intervals set
+    H{
+        { int-regs
+          {
+              T{ live-interval
+                 { vreg V int-regs 3 }
+                 { start 0 }
+                 { end 40 }
+                 { reg 1 }
+                 { ranges V{ T{ live-range f 0 40 } } }
+                 { uses V{ 0 40 } }
+              }
+          }
+        }
+    } active-intervals set
+
+    T{ live-interval
+       { vreg V int-regs 4 }
+        { start 8 }
+        { end 10 }
+        { ranges V{ T{ live-range f 8 10 } } }
+        { uses V{ 8 10 } }
+    }
+    compute-free-pos
+] unit-test
+
 ! Bug in live spill slots calculation
 
 V{ T{ ##prologue } T{ ##branch } } 0 test-bb

From ae3f36c165e8ba820fa640cf89224927c803c030 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 16:08:16 -0500
Subject: [PATCH 19/42] disjoint-sets: add some tests for compiler bug;
 eventually more tests should be written for this vocab

---
 basis/disjoint-sets/disjoint-sets-tests.factor | 16 ++++++++++++++++
 1 file changed, 16 insertions(+)
 create mode 100644 basis/disjoint-sets/disjoint-sets-tests.factor

diff --git a/basis/disjoint-sets/disjoint-sets-tests.factor b/basis/disjoint-sets/disjoint-sets-tests.factor
new file mode 100644
index 0000000000..74746f1a3a
--- /dev/null
+++ b/basis/disjoint-sets/disjoint-sets-tests.factor
@@ -0,0 +1,16 @@
+IN: disjoint-sets.testes
+USING: tools.test disjoint-sets namespaces slots.private ;
+
+SYMBOL: +blah+
+-405534154 +blah+ 1 set-slot
+
+SYMBOL: uf
+
+[ ] [
+    <disjoint-set> uf set
+    +blah+ uf get add-atom
+    19026 uf get add-atom
+    19026 +blah+ uf get equate
+] unit-test
+
+[ 2 ] [ 19026 uf get equiv-set-size ] unit-test

From c5ffb08f5b31c2096383517aede44ef1de9cf95b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 30 Jun 2009 16:44:14 -0500
Subject: [PATCH 20/42] fix bug where traversal order was lost

---
 .../cfg/instructions/instructions.factor      |  2 +-
 .../linear-scan/resolve/resolve-tests.factor  | 30 +++++++++----------
 .../cfg/linear-scan/resolve/resolve.factor    | 22 +++++++++++---
 3 files changed, 34 insertions(+), 20 deletions(-)

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 5b3e1af930..4ce9c59e7e 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -248,4 +248,4 @@ INSN: _reload dst class n ;
 INSN: _copy dst src class ;
 INSN: _spill-counts counts ;
 
-SYMBOL: temp-spill
+SYMBOL: spill-temp
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index df9f29e999..feb9ac2504 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -68,12 +68,12 @@ T{ live-interval
 [
     {
         T{ _copy { dst 5 } { src 4 } { class int-regs } }
-        T{ _spill { src 0 } { class int-regs } { n spill-temp } }
-        T{ _copy { dst 0 } { src 1 } { class int-regs } }
-        T{ _reload { dst 1 } { class int-regs } { n spill-temp } }
-        T{ _spill { src 0 } { class float-regs } { n spill-temp } }
-        T{ _copy { dst 0 } { src 1 } { class float-regs } }
-        T{ _reload { dst 1 } { class float-regs } { n spill-temp } }
+        T{ _spill { src 1 } { class int-regs } { n spill-temp } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
+        T{ _spill { src 1 } { class float-regs } { n spill-temp } }
+        T{ _copy { dst 1 } { src 0 } { class float-regs } }
+        T{ _reload { dst 0 } { class float-regs } { n spill-temp } }
     }
 ] [
     {
@@ -87,10 +87,10 @@ T{ live-interval
 
 [
     {
-        T{ _spill { src 0 } { class int-regs } { n spill-temp } }
-        T{ _copy { dst 0 } { src 2 } { class int-regs } }
+        T{ _spill { src 2 } { class int-regs } { n spill-temp } }
         T{ _copy { dst 2 } { src 1 } { class int-regs } }
-        T{ _reload { dst 1 } { class int-regs } { n spill-temp } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
     }
 ] [
     {
@@ -162,10 +162,10 @@ T{ live-interval
     {
         T{ _copy { dst 1 } { src 0 } { class int-regs } }
         T{ _copy { dst 2 } { src 0 } { class int-regs } }
-        T{ _spill { src 3 } { class int-regs } { n spill-temp } }
+        T{ _spill { src 4 } { class int-regs } { n spill-temp } }
         T{ _copy { dst 4 } { src 0 } { class int-regs } }
-        T{ _copy { dst 3 } { src 4 } { class int-regs } }
-        T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
+        T{ _copy { dst 0 } { src 3 } { class int-regs } }
+        T{ _reload { dst 3 } { class int-regs } { n spill-temp } }
     }
 ] [
     {
@@ -182,10 +182,10 @@ T{ live-interval
         T{ _copy { dst 2 } { src 0 } { class int-regs } }
         T{ _copy { dst 9 } { src 1 } { class int-regs } }
         T{ _copy { dst 1 } { src 0 } { class int-regs } }
-        T{ _spill { src 3 } { class int-regs } { n spill-temp } }
+        T{ _spill { src 4 } { class int-regs } { n spill-temp } }
         T{ _copy { dst 4 } { src 0 } { class int-regs } }
-        T{ _copy { dst 3 } { src 4 } { class int-regs } }
-        T{ _reload { dst 0 } { class int-regs } { n spill-temp } }
+        T{ _copy { dst 0 } { src 3 } { class int-regs } }
+        T{ _reload { dst 3 } { class int-regs } { n spill-temp } }
     }
 ] [
     {
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index b996520546..bd7528291d 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -126,22 +126,36 @@ M: register->register to-loc drop register ;
 
 :: (trace-chain) ( obj hashtable -- )
     obj to-reg froms get at* [
+        dup ,
         obj over hashtable clone [ maybe-set-at ] keep swap
-        [ (trace-chain) ] [ , drop ] if
+        [ (trace-chain) ] [ 2drop ] if
     ] [
-        drop hashtable ,
+        drop
     ] if ;
 
 : trace-chain ( obj -- seq )
     [
+        dup ,
         dup dup associate (trace-chain)
-    ] { } make [ keys ] map concat reverse ;
+    ] { } make prune reverse ;
+
 
 : trace-chains ( seq -- seq' )
     [ trace-chain ] map concat ;
 
-: break-cycle-n ( operations -- operations' )
+ERROR: resolve-error ;
+
+: split-cycle ( operations -- chain spilled-operation )
     unclip [
+        [ set-tos/froms ]
+        [
+            [ start? ] find nip
+            [ resolve-error ] unless* trace-chain
+        ] bi
+    ] dip ;
+
+: break-cycle-n ( operations -- operations' )
+    split-cycle [
         [ from>> spill-temp ]
         [ reg-class>> ] bi \ register->memory boa
     ] [

From 4782c737ab0e51afeefc84d7a639a5c492bb0ad8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 16:47:22 -0500
Subject: [PATCH 21/42] cpu.x86: don't clobber src in %dispatch

---
 basis/cpu/x86/32/32.factor | 4 ++--
 basis/cpu/x86/64/64.factor | 4 ++--
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index b591b254f8..e908f52952 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -29,10 +29,10 @@ M: x86.32 temp-reg-2 EDX ;
 
 M:: x86.32 %dispatch ( src temp -- )
     ! Load jump table base.
-    src HEX: ffffffff ADD
+    temp src HEX: ffffffff [+] LEA
     0 rc-absolute-cell rel-here
     ! Go
-    src HEX: 7f [+] JMP
+    temp HEX: 7f [+] JMP
     ! Fix up the displacement above
     cell code-alignment
     [ 7 + building get dup pop* push ]
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 3a7221c239..2c8fb3f18f 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -27,8 +27,8 @@ M:: x86.64 %dispatch ( src temp -- )
     temp HEX: ffffffff MOV
     0 rc-absolute-cell rel-here
     ! Add jump table base
-    src temp ADD
-    src HEX: 7f [+] JMP
+    temp src ADD
+    temp HEX: 7f [+] JMP
     ! Fix up the displacement above
     cell code-alignment
     [ 15 + building get dup pop* push ]

From 5b328e500111b57bc3287fc601dff74b00e42283 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 30 Jun 2009 17:39:36 -0500
Subject: [PATCH 22/42] imagebin does the right thing now

---
 extra/webapps/imagebin/imagebin.factor    | 55 ++++++++++-------------
 extra/webapps/imagebin/uploaded-image.xml |  2 +-
 2 files changed, 25 insertions(+), 32 deletions(-)

diff --git a/extra/webapps/imagebin/imagebin.factor b/extra/webapps/imagebin/imagebin.factor
index 7c63c51eee..bb8720466c 100755
--- a/extra/webapps/imagebin/imagebin.factor
+++ b/extra/webapps/imagebin/imagebin.factor
@@ -1,52 +1,45 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors db db.tuples db.types furnace.actions
-furnace.redirection html.forms http http.server
-http.server.dispatchers io.directories io.pathnames kernel
-multiline namespaces urls ;
+USING: accessors furnace.actions furnace.redirection
+html.forms http http.server http.server.dispatchers
+io.directories io.encodings.utf8 io.files io.pathnames
+kernel math.parser multiline namespaces sequences urls ;
 IN: webapps.imagebin
 
-SYMBOL: image-directory
-
-image-directory [ "resource:images" ] initialize
-
-TUPLE: imagebin < dispatcher ;
-
-TUPLE: image id path ;
-
-image "IMAGE" {
-    { "id" "ID" INTEGER +db-assigned-id+ }
-    { "path" "PATH" { VARCHAR 256 } +not-null+ }
-} define-persistent
+TUPLE: imagebin < dispatcher path n ;
 
 : <uploaded-image-action> ( -- action )
     <page-action>
-        image-directory get >>temporary-directory
         { imagebin "uploaded-image" } >>template ;
 
-SYMBOL: my-post-data
+: next-image-path ( -- path )
+    imagebin get
+    [ path>> ] [ n>> number>string ] bi append-path ; 
+
+M: imagebin call-responder*
+    [ imagebin set ] [ call-next-method ] bi ;
+
+: move-image ( mime-file -- )
+    next-image-path
+    [ [ temporary-path>> ] dip move-file ]
+    [ [ filename>> ] dip ".txt" append utf8 set-file-contents ] 2bi ;
+
 : <upload-image-action> ( -- action )
     <page-action>
         { imagebin "upload-image" } >>template
-        image-directory get >>temporary-directory
         [
-            "file1" param [
-                temporary-path>> image-directory get move-file
-            ] when*
-            ! image new
-            !    "file" value
-                ! insert-tuple
+            "file1" param [ move-image ] when*
+            "file2" param [ move-image ] when*
+            "file3" param [ move-image ] when*
             "uploaded-image" <redirect>
         ] >>submit ;
 
-: initialize-image-directory ( -- )
-    image-directory get make-directories ;
-
-: <imagebin> ( -- responder )
+: <imagebin> ( image-directory -- responder )
     imagebin new-dispatcher
+        swap [ make-directories ] [ >>path ] bi
+        0 >>n
         <upload-image-action> "" add-responder
         <upload-image-action> "upload-image" add-responder
         <uploaded-image-action> "uploaded-image" add-responder ;
 
-initialize-image-directory
-<imagebin> main-responder set-global
+"resource:images" <imagebin> main-responder set-global
diff --git a/extra/webapps/imagebin/uploaded-image.xml b/extra/webapps/imagebin/uploaded-image.xml
index 903be5cca4..79dfabc924 100644
--- a/extra/webapps/imagebin/uploaded-image.xml
+++ b/extra/webapps/imagebin/uploaded-image.xml
@@ -2,6 +2,6 @@
 <html>
 <head><title>Uploaded</title></head>
 <body>
-hi from uploaded-image
+You uploaded something!
 </body>
 </html>

From 87aabfc053a0c1b3e6a8e12463016e202e161520 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 18:10:53 -0500
Subject: [PATCH 23/42] compiler.cfg.linear-scan.assignment: get
 check-assignment? to work with coalescing

---
 .../compiler/cfg/linear-scan/assignment/assignment.factor  | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 1a7f32a0ea..ea717f9218 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -108,11 +108,14 @@ SYMBOL: check-assignment?
 
 ERROR: overlapping-registers intervals ;
 
+: check-assignment ( intervals -- )
+    dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
+    dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
+
 : active-intervals ( insn -- intervals )
     insn#>> pending-intervals get [ covers? ] with filter
     check-assignment? get [
-        dup [ reg>> ] map all-unique?
-        [ overlapping-registers ] unless
+        dup check-assignment
     ] when ;
 
 M: vreg-insn assign-registers-in-insn

From 554559c0b17027b3c00852a9a47b4e2089f4853a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 18:11:15 -0500
Subject: [PATCH 24/42] %dispatch: sometimes the generated sequence is one byte
 longer, so instead of hard-coding it, compute the right length

---
 basis/cpu/x86/32/32.factor | 4 +++-
 basis/cpu/x86/64/64.factor | 4 +++-
 2 files changed, 6 insertions(+), 2 deletions(-)

diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index e908f52952..86cd53712d 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -30,12 +30,14 @@ M: x86.32 temp-reg-2 EDX ;
 M:: x86.32 %dispatch ( src temp -- )
     ! Load jump table base.
     temp src HEX: ffffffff [+] LEA
+    building get length cell - :> start
     0 rc-absolute-cell rel-here
     ! Go
     temp HEX: 7f [+] JMP
+    building get length :> end
     ! Fix up the displacement above
     cell code-alignment
-    [ 7 + building get dup pop* push ]
+    [ end start - + building get dup pop* push ]
     [ align-code ]
     bi ;
 
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 2c8fb3f18f..5390d7e0c8 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -23,15 +23,17 @@ M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
 
 M:: x86.64 %dispatch ( src temp -- )
+    building get length :> start
     ! Load jump table base.
     temp HEX: ffffffff MOV
     0 rc-absolute-cell rel-here
     ! Add jump table base
     temp src ADD
     temp HEX: 7f [+] JMP
+    building get length :> end
     ! Fix up the displacement above
     cell code-alignment
-    [ 15 + building get dup pop* push ]
+    [ end start - 2 - + building get dup pop* push ]
     [ align-code ]
     bi ;
 

From 6efe62a49a296ba9810737edce4e08c6aa1fe944 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 18:11:45 -0500
Subject: [PATCH 25/42] compiler.cfg.stack-analysis: enable global optimization

---
 basis/compiler/cfg/stack-analysis/stack-analysis.factor | 7 +------
 1 file changed, 1 insertion(+), 6 deletions(-)

diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index 5679d8bd11..1e7f33c7e0 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -59,17 +59,12 @@ UNION: sync-if-back-edge
     ##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 ;
+    [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
 
 M: sync-if-back-edge visit
     sync-state? [ sync-state ] when , ;

From 79a60c8bc5234139522034e925f2e3a4e5794a73 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 18:22:54 -0500
Subject: [PATCH 26/42] compiler.cfg.stack-analysis: fix tests

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

diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index 1bef0c3967..6f4b88e28e 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -17,8 +17,6 @@ IN: compiler.cfg.stack-analysis.tests
 : linearize ( cfg -- mr )
     flatten-cfg instructions>> ;
 
-local-only? off
-
 [ ] [ [ ] test-stack-analysis drop ] unit-test
 
 ! Only peek once

From 97ceba5000bba862d16f18ba57de5a91052a60a3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 30 Jun 2009 18:47:24 -0500
Subject: [PATCH 27/42] make commutative operations with immediates output the
 same IR

---
 .../cfg/intrinsics/fixnum/fixnum.factor       | 43 +++++++++++++------
 .../compiler/cfg/intrinsics/intrinsics.factor | 10 ++---
 2 files changed, 36 insertions(+), 17 deletions(-)

diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index cb5f2e926d..a93fa5d902 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -18,13 +18,14 @@ IN: compiler.cfg.intrinsics.fixnum
     0 cc= ^^compare-imm
     ds-push ;
 
-: (emit-fixnum-imm-op) ( infos insn -- dst )
-    ds-drop
-    [ ds-pop ]
-    [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
-    [ ]
-    tri*
-    call ; inline
+: tag-literal ( n -- tagged )
+    literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+
+: emit-fixnum-imm-op1 ( infos insn -- dst )
+    [ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; inline
+
+: emit-fixnum-imm-op2 ( infos insn -- dst )
+    [ ds-drop ds-pop ] [ second tag-literal ] [ ] tri* call ; inline
 
 : (emit-fixnum-op) ( insn -- dst )
     [ 2inputs ] dip call ; inline
@@ -32,9 +33,22 @@ IN: compiler.cfg.intrinsics.fixnum
 :: emit-fixnum-op ( node insn imm-insn -- )
     [let | infos [ node node-input-infos ] |
         infos second value-info-small-tagged?
-        [ infos imm-insn (emit-fixnum-imm-op) ]
-        [ insn (emit-fixnum-op) ]
-        if
+        [ infos imm-insn emit-fixnum-imm-op2 ]
+        [ insn (emit-fixnum-op) ] if
+        ds-push
+    ] ; inline
+
+:: emit-commutative-fixnum-op ( node insn imm-insn -- )
+    [let | infos [ node node-input-infos ] |
+        infos first value-info-small-tagged?
+        [ infos imm-insn emit-fixnum-imm-op1 ]
+        [
+            infos second value-info-small-tagged? [
+                infos imm-insn emit-fixnum-imm-op2
+            ] [
+                insn (emit-fixnum-op)
+            ] if
+        ] if
         ds-push
     ] ; inline
 
@@ -69,9 +83,14 @@ IN: compiler.cfg.intrinsics.fixnum
     [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
     ds-push ;
 
+: (emit-fixnum-comparison) ( cc -- quot1 quot2 )
+    [ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
+
+: emit-eq ( node cc -- )
+    (emit-fixnum-comparison) emit-commutative-fixnum-op ;
+
 : emit-fixnum-comparison ( node cc -- )
-    [  ^^compare ] [ ^^compare-imm ] bi-curry
-    emit-fixnum-op ;
+    (emit-fixnum-comparison) emit-fixnum-op ;
 
 : emit-bignum>fixnum ( -- )
     ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index ec819f9440..15c9c0cef3 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -103,11 +103,11 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
-        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
+        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op iterate-next ] }
         { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
+        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op iterate-next ] }
+        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op iterate-next ] }
+        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op iterate-next ] }
         { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
         { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
         { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
@@ -116,7 +116,7 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
         { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
         { \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
-        { \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] }
+        { \ kernel:eq? [ cc= emit-eq iterate-next ] }
         { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
         { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
         { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }

From f82484543357bf1f280c808ff53116df326791ae Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 30 Jun 2009 18:48:52 -0500
Subject: [PATCH 28/42] remove duplicate using

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

diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
index b95a8c79ea..ee601f2337 100644
--- a/basis/compiler/cfg/optimizer/optimizer-tests.factor
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -1,6 +1,7 @@
-USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
-compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
-sequences.private math sbufs math.private slots.private strings ;
+USING: arrays sequences tools.test compiler.cfg.checker
+compiler.cfg.debugger compiler.cfg.def-use sets kernel
+kernel.private fry slots.private vectors sequences.private
+math sbufs math.private strings ;
 IN: compiler.cfg.optimizer.tests
 
 ! Miscellaneous tests

From 89fbc8efb414aea524a201e10b9442f6cec2532d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 20:13:35 -0500
Subject: [PATCH 29/42] compiler.cfg.tco: Tail call optimization moved out of
 compiler.cfg.builder into its own pass

---
 basis/compiler/cfg/builder/builder.factor     |  74 ++++-------
 .../cfg/intrinsics/fixnum/fixnum.factor       |  16 +--
 .../compiler/cfg/intrinsics/intrinsics.factor | 125 +++++++++---------
 basis/compiler/cfg/iterator/iterator.factor   |  45 -------
 basis/compiler/cfg/iterator/summary.txt       |   1 -
 .../cfg/linearization/linearization.factor    |  13 +-
 basis/compiler/cfg/optimizer/optimizer.factor |   2 +
 basis/compiler/cfg/tco/tco.factor             |  83 ++++++++++++
 8 files changed, 180 insertions(+), 179 deletions(-)
 delete mode 100644 basis/compiler/cfg/iterator/iterator.factor
 delete mode 100644 basis/compiler/cfg/iterator/summary.txt
 create mode 100644 basis/compiler/cfg/tco/tco.factor

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index d323263fc7..f4421e3ef4 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators hashtables kernel
 math fry namespaces make sequences words byte-arrays
@@ -11,7 +11,6 @@ compiler.tree.propagation.info
 compiler.cfg
 compiler.cfg.hats
 compiler.cfg.stacks
-compiler.cfg.iterator
 compiler.cfg.utilities
 compiler.cfg.registers
 compiler.cfg.intrinsics
@@ -26,10 +25,6 @@ SYMBOL: procedures
 SYMBOL: current-word
 SYMBOL: current-label
 SYMBOL: loops
-SYMBOL: first-basic-block
-
-! Basic block after prologue, makes recursion faster
-SYMBOL: current-label-start
 
 : add-procedure ( -- )
     basic-block get current-word get current-label get
@@ -46,27 +41,22 @@ SYMBOL: current-label-start
 : with-cfg-builder ( nodes word label quot -- )
     '[ begin-procedure @ ] with-scope ; inline
 
-GENERIC: emit-node ( node -- next )
+GENERIC: emit-node ( node -- )
 
 : check-basic-block ( node -- node' )
     basic-block get [ drop f ] unless ; inline
 
 : emit-nodes ( nodes -- )
-    [ current-node emit-node check-basic-block ] iterate-nodes ;
+    [ basic-block get [ emit-node ] [ drop ] if ] each ;
 
 : begin-word ( -- )
-    #! We store the basic block after the prologue as a loop
-    #! labeled by the current word, so that self-recursive
-    #! calls can skip an epilogue/prologue.
     ##prologue
     ##branch
-    begin-basic-block
-    basic-block get first-basic-block set ;
+    begin-basic-block ;
 
 : (build-cfg) ( nodes word label -- )
     [
         begin-word
-        V{ } clone node-stack set
         emit-nodes
     ] with-cfg-builder ;
 
@@ -77,19 +67,16 @@ GENERIC: emit-node ( node -- next )
         ] with-variable
     ] keep ;
 
-: local-recursive-call ( basic-block -- next )
+: local-recursive-call ( basic-block -- )
     ##branch
     basic-block get successors>> push
-    stop-iterating ;
+    basic-block off ;
 
-: 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 ]
-    } cond ;
+: emit-call ( word height -- )
+    over loops get key?
+    [ drop loops get at local-recursive-call ]
+    [ ##call ##branch begin-basic-block ]
+    if ;
 
 ! #recursive
 : recursive-height ( #recursive -- n )
@@ -102,12 +89,11 @@ GENERIC: emit-node ( node -- next )
 : remember-loop ( label -- )
     basic-block get swap loops get set-at ;
 
-: emit-loop ( node -- next )
+: emit-loop ( node -- )
     ##loop-entry
     ##branch
     begin-basic-block
-    [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
-    iterate-next ;
+    [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
 
 M: #recursive emit-node
     dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
@@ -121,7 +107,7 @@ M: #recursive emit-node
     ] with-scope ;
 
 : emit-if ( node -- )
-    children>>  [ emit-branch ] map
+    children>> [ emit-branch ] map
     end-basic-block
     begin-basic-block
     basic-block get '[ [ _ swap successors>> push ] when* ] each ;
@@ -157,11 +143,11 @@ M: #if emit-node
         { [ dup trivial-if? ] [ drop emit-trivial-if ] }
         { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
         [ ds-pop ##branch-t emit-if ]
-    } cond iterate-next ;
+    } cond ;
 
 ! #dispatch
 M: #dispatch emit-node
-    ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
+    ds-pop ^^offset>slot i ##dispatch emit-if ;
 
 ! #call
 M: #call emit-node
@@ -173,7 +159,7 @@ M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
 
 ! #push
 M: #push emit-node
-    literal>> ^^load-literal ds-push iterate-next ;
+    literal>> ^^load-literal ds-push ;
 
 ! #shuffle
 M: #shuffle emit-node
@@ -183,19 +169,18 @@ M: #shuffle emit-node
     [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
     [ nip ] 2tri
     [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
-    [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi
-    iterate-next ;
+    [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
 
 ! #return
 M: #return emit-node
-    drop ##epilogue ##return stop-iterating ;
+    drop ##epilogue ##return ;
 
 M: #return-recursive emit-node
     label>> id>> loops get key?
-    [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
+    [ ##epilogue ##return ] unless ;
 
 ! #terminate
-M: #terminate emit-node drop stop-iterating ;
+M: #terminate emit-node drop ;
 
 ! FFI
 : return-size ( ctype -- n )
@@ -215,9 +200,9 @@ M: #terminate emit-node drop stop-iterating ;
 : alien-stack-frame ( params -- )
     <alien-stack-frame> ##stack-frame ;
 
-: emit-alien-node ( node quot -- next )
+: emit-alien-node ( node quot -- )
     [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
-    ##branch begin-basic-block iterate-next ; inline
+    ##branch begin-basic-block ; inline
 
 M: #alien-invoke emit-node
     [ ##alien-invoke ] emit-alien-node ;
@@ -229,17 +214,16 @@ M: #alien-callback emit-node
     dup params>> xt>> dup
     [
         ##prologue
-        dup [ ##alien-callback ] emit-alien-node drop
+        dup [ ##alien-callback ] emit-alien-node
         ##epilogue
         params>> ##callback-return
-    ] with-cfg-builder
-    iterate-next ;
+    ] with-cfg-builder ;
 
 ! No-op nodes
-M: #introduce emit-node drop iterate-next ;
+M: #introduce emit-node drop ;
 
-M: #copy emit-node drop iterate-next ;
+M: #copy emit-node drop ;
 
-M: #enter-recursive emit-node drop iterate-next ;
+M: #enter-recursive emit-node drop ;
 
-M: #phi emit-node drop iterate-next ;
+M: #phi emit-node drop ;
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index cb5f2e926d..0b391b7de9 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -5,7 +5,6 @@ combinators fry locals
 compiler.tree.propagation.info
 compiler.cfg.hats
 compiler.cfg.stacks
-compiler.cfg.iterator
 compiler.cfg.instructions
 compiler.cfg.utilities
 compiler.cfg.registers ;
@@ -79,15 +78,6 @@ IN: compiler.cfg.intrinsics.fixnum
 : emit-fixnum>bignum ( -- )
     ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
 
-: emit-fixnum-overflow-op ( quot quot-tail -- next )
-    [ 2inputs 1 ##inc-d ] 2dip
-    tail-call? [
-        ##epilogue
-        nip call
-        stop-iterating
-    ] [
-        drop call
-        ##branch
-        begin-basic-block
-        iterate-next
-    ] if ; inline
+: emit-fixnum-overflow-op ( quot -- next )
+    [ 2inputs 1 ##inc-d ] dip call ##branch
+    begin-basic-block ; inline
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index ec819f9440..3bf54b837b 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -8,8 +8,7 @@ compiler.cfg.intrinsics.allot
 compiler.cfg.intrinsics.fixnum
 compiler.cfg.intrinsics.float
 compiler.cfg.intrinsics.slots
-compiler.cfg.intrinsics.misc
-compiler.cfg.iterator ;
+compiler.cfg.intrinsics.misc ;
 QUALIFIED: kernel
 QUALIFIED: arrays
 QUALIFIED: byte-arrays
@@ -95,66 +94,66 @@ IN: compiler.cfg.intrinsics
 : enable-fixnum-log2 ( -- )
     \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
 
-: emit-intrinsic ( node word -- node/f )
+: emit-intrinsic ( node word -- )
     {
-        { \ kernel.private:tag [ drop emit-tag iterate-next ] }
-        { \ kernel.private:getenv [ emit-getenv iterate-next ] }
-        { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
-        { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
-        { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
-        { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
-        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
-        { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
-        { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
-        { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
-        { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
-        { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
-        { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
-        { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
-        { \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
-        { \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] }
-        { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
-        { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
-        { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }
-        { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] }
-        { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] }
-        { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] }
-        { \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] }
-        { \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] }
-        { \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] }
-        { \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] }
-        { \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] }
-        { \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] }
-        { \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] }
-        { \ slots.private:slot [ emit-slot iterate-next ] }
-        { \ slots.private:set-slot [ emit-set-slot iterate-next ] }
-        { \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
-        { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
-        { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
-        { \ arrays:<array> [ emit-<array> iterate-next ] }
-        { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
-        { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
-        { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
-        { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
-        { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] }
-        { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] }
-        { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] }
-        { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] }
-        { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] }
-        { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] }
-        { \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] }
-        { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] }
-        { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] }
-        { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] }
-        { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] }
-        { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] }
+        { \ kernel.private:tag [ drop emit-tag ] }
+        { \ kernel.private:getenv [ emit-getenv ] }
+        { \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
+        { \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] }
+        { \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] }
+        { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] }
+        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
+        { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+        { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
+        { \ math.private:fixnum*fast [ emit-fixnum*fast ] }
+        { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
+        { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
+        { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
+        { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
+        { \ kernel:eq? [ cc= emit-fixnum-comparison ] }
+        { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
+        { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
+        { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+        { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+        { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+        { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+        { \ math.private:float< [ drop cc< emit-float-comparison ] }
+        { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
+        { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
+        { \ math.private:float> [ drop cc> emit-float-comparison ] }
+        { \ math.private:float= [ drop cc= emit-float-comparison ] }
+        { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
+        { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
+        { \ slots.private:slot [ emit-slot ] }
+        { \ slots.private:set-slot [ emit-set-slot ] }
+        { \ strings.private:string-nth [ drop emit-string-nth ] }
+        { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
+        { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
+        { \ arrays:<array> [ emit-<array> ] }
+        { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
+        { \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
+        { \ kernel:<wrapper> [ emit-simple-allot ] }
+        { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+        { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+        { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
+        { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
     } case ;
diff --git a/basis/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor
deleted file mode 100644
index eb7f71ad60..0000000000
--- a/basis/compiler/cfg/iterator/iterator.factor
+++ /dev/null
@@ -1,45 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences kernel compiler.tree ;
-IN: compiler.cfg.iterator
-
-SYMBOL: node-stack
-
-: >node ( cursor -- ) node-stack get push ;
-: node> ( -- cursor ) node-stack get pop ;
-: node@ ( -- cursor ) node-stack get last ;
-: current-node ( -- node ) node@ first ;
-: iterate-next ( -- cursor ) node@ rest-slice ;
-: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
-
-: iterate-nodes ( cursor quot: ( -- ) -- )
-    over empty? [
-        2drop
-    ] [
-        [ swap >node call node> drop ] keep iterate-nodes
-    ] if ; inline recursive
-
-DEFER: (tail-call?)
-
-: tail-phi? ( cursor -- ? )
-    [ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
-
-: (tail-call?) ( cursor -- ? )
-    [ t ] [
-        [
-            first
-            [ #return? ]
-            [ #return-recursive? ]
-            [ #terminate? ] tri or or
-        ] [ tail-phi? ] bi or
-    ] if-empty ;
-
-: tail-call? ( -- ? )
-    node-stack get [
-        rest-slice
-        [ t ] [ (tail-call?) ] if-empty
-    ] all? ;
-
-: terminate-call? ( -- ? )
-    node-stack get last
-    rest-slice [ f ] [ first #terminate? ] if-empty ;
diff --git a/basis/compiler/cfg/iterator/summary.txt b/basis/compiler/cfg/iterator/summary.txt
deleted file mode 100644
index b5afb479bd..0000000000
--- a/basis/compiler/cfg/iterator/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Utility for iterating for high-level IR
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 9e222f1832..8165553a28 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -24,19 +24,8 @@ M: insn linearize-insn , drop ;
     #! don't need to branch.
     [ number>> ] bi@ 1 - = ; inline
 
-: branch-to-branch? ( successor -- ? )
-    #! A branch to a block containing just a jump return is cloned.
-    instructions>> dup length 2 = [
-        [ first ##epilogue? ]
-        [ second [ ##return? ] [ ##jump? ] bi or ] bi and
-    ] [ drop f ] if ;
-
 : emit-branch ( basic-block successor -- )
-    {
-        { [ 2dup useless-branch? ] [ 2drop ] }
-        { [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
-        [ nip number>> _branch ]
-    } cond ;
+    2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
 
 M: ##branch linearize-insn
     drop dup successors>> first emit-branch ;
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index e789fc9c21..c8450a1c47 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors combinators namespaces
+compiler.cfg.tco
 compiler.cfg.predecessors
 compiler.cfg.useless-blocks
 compiler.cfg.stack-analysis
@@ -23,6 +24,7 @@ SYMBOL: check-optimizer?
 
 : optimize-cfg ( cfg -- cfg' )
     [
+        optimize-tail-calls
         compute-predecessors
         ! delete-useless-blocks
         delete-useless-conditionals
diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor
new file mode 100644
index 0000000000..9b223ad980
--- /dev/null
+++ b/basis/compiler/cfg/tco/tco.factor
@@ -0,0 +1,83 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel math
+namespaces sequences fry combinators
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.instructions ;
+IN: compiler.cfg.tco
+
+! Tail call optimization. You must run compute-predecessors after this
+
+: return? ( bb -- ? )
+    instructions>> {
+        [ length 2 = ]
+        [ first ##epilogue? ]
+        [ second ##return? ]
+    } 1&& ;
+
+: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
+
+: tail-call? ( bb -- ? )
+    {
+        [ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ]
+        [ successors>> first return? ]
+    } 1&& ;
+
+: word-tail-call? ( bb -- ? )
+    instructions>> penultimate ##call? ;
+
+: convert-tail-call ( bb quot: ( insn -- tail-insn ) -- )
+    '[
+        instructions>>
+        [ pop* ] [ pop ] [ ] tri
+        [ [ \ ##epilogue new-insn ] dip push ]
+        [ _ dip push ] bi
+    ]
+    [ successors>> delete-all ]
+    bi ; inline
+
+: convert-word-tail-call ( bb -- )
+    [ word>> \ ##jump new-insn ] convert-tail-call ;
+
+: loop-tail-call? ( bb -- ? )
+    instructions>> penultimate
+    { [ ##call? ] [ word>> cfg get label>> eq? ] } 1&& ;
+
+: convert-loop-tail-call ( bb -- )
+    ! If a word calls itself, this becomes a loop in the CFG.
+    [ instructions>> [ pop* ] [ pop* ] [ [ \ ##branch new-insn ] dip push ] tri ]
+    [ successors>> delete-all ]
+    [ [ cfg get entry>> successors>> first ] dip successors>> push ]
+    tri ;
+
+: fixnum-tail-call? ( bb -- ? )
+    instructions>> penultimate
+    { [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] } 1|| ;
+
+GENERIC: convert-fixnum-tail-call* ( src1 src2 insn -- insn' )
+
+M: ##fixnum-add convert-fixnum-tail-call* drop \ ##fixnum-add-tail new-insn ;
+M: ##fixnum-sub convert-fixnum-tail-call* drop \ ##fixnum-sub-tail new-insn ;
+M: ##fixnum-mul convert-fixnum-tail-call* drop \ ##fixnum-mul-tail new-insn ;
+
+: convert-fixnum-tail-call ( bb -- )
+    [
+        [ src1>> ] [ src2>> ] [ ] tri
+        convert-fixnum-tail-call*
+    ] convert-tail-call ;
+
+: optimize-tail-call ( bb -- )
+    dup tail-call? [
+        {
+            { [ dup loop-tail-call? ] [ convert-loop-tail-call ] }
+            { [ dup word-tail-call? ] [ convert-word-tail-call ] }
+            { [ dup fixnum-tail-call? ] [ convert-fixnum-tail-call ] }
+            [ drop ]
+        } cond
+    ] [ drop ] if ;
+
+: optimize-tail-calls ( cfg -- cfg' )
+    dup cfg set
+    dup [ optimize-tail-call ] each-basic-block
+    f >>post-order ;
\ No newline at end of file

From f6b537f4c64ab0a7ea9ad6d5e913ff17a1a6fd84 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 20:16:09 -0500
Subject: [PATCH 30/42] Fix conflict

---
 .../cfg/intrinsics/fixnum/fixnum.factor       | 45 +++++++++++++------
 .../compiler/cfg/intrinsics/intrinsics.factor | 12 ++---
 .../cfg/optimizer/optimizer-tests.factor      |  7 +--
 extra/webapps/imagebin/imagebin.factor        | 42 +++++++++--------
 extra/webapps/imagebin/uploaded-image.xml     |  2 +-
 5 files changed, 67 insertions(+), 41 deletions(-)

diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index 0b391b7de9..e09c80ba39 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences accessors layouts kernel math namespaces
 combinators fry locals
@@ -17,13 +17,14 @@ IN: compiler.cfg.intrinsics.fixnum
     0 cc= ^^compare-imm
     ds-push ;
 
-: (emit-fixnum-imm-op) ( infos insn -- dst )
-    ds-drop
-    [ ds-pop ]
-    [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
-    [ ]
-    tri*
-    call ; inline
+: tag-literal ( n -- tagged )
+    literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+
+: emit-fixnum-imm-op1 ( infos insn -- dst )
+    [ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; inline
+
+: emit-fixnum-imm-op2 ( infos insn -- dst )
+    [ ds-drop ds-pop ] [ second tag-literal ] [ ] tri* call ; inline
 
 : (emit-fixnum-op) ( insn -- dst )
     [ 2inputs ] dip call ; inline
@@ -31,9 +32,22 @@ IN: compiler.cfg.intrinsics.fixnum
 :: emit-fixnum-op ( node insn imm-insn -- )
     [let | infos [ node node-input-infos ] |
         infos second value-info-small-tagged?
-        [ infos imm-insn (emit-fixnum-imm-op) ]
-        [ insn (emit-fixnum-op) ]
-        if
+        [ infos imm-insn emit-fixnum-imm-op2 ]
+        [ insn (emit-fixnum-op) ] if
+        ds-push
+    ] ; inline
+
+:: emit-commutative-fixnum-op ( node insn imm-insn -- )
+    [let | infos [ node node-input-infos ] |
+        infos first value-info-small-tagged?
+        [ infos imm-insn emit-fixnum-imm-op1 ]
+        [
+            infos second value-info-small-tagged? [
+                infos imm-insn emit-fixnum-imm-op2
+            ] [
+                insn (emit-fixnum-op)
+            ] if
+        ] if
         ds-push
     ] ; inline
 
@@ -68,9 +82,14 @@ IN: compiler.cfg.intrinsics.fixnum
     [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
     ds-push ;
 
+: (emit-fixnum-comparison) ( cc -- quot1 quot2 )
+    [ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
+
+: emit-eq ( node -- )
+    cc= (emit-fixnum-comparison) emit-commutative-fixnum-op ;
+
 : emit-fixnum-comparison ( node cc -- )
-    [  ^^compare ] [ ^^compare-imm ] bi-curry
-    emit-fixnum-op ;
+    (emit-fixnum-comparison) emit-fixnum-op ;
 
 : emit-bignum>fixnum ( -- )
     ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 3bf54b837b..df01bba89b 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel combinators cpu.architecture
 compiler.cfg.hats
@@ -102,11 +102,11 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] }
         { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] }
-        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op ] }
         { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
-        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
-        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
-        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op ] }
+        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op ] }
+        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op ] }
         { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
         { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
         { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
@@ -115,7 +115,7 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
         { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
         { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
-        { \ kernel:eq? [ cc= emit-fixnum-comparison ] }
+        { \ kernel:eq? [ emit-eq ] }
         { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
         { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
         { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
index b95a8c79ea..ee601f2337 100644
--- a/basis/compiler/cfg/optimizer/optimizer-tests.factor
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -1,6 +1,7 @@
-USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
-compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
-sequences.private math sbufs math.private slots.private strings ;
+USING: arrays sequences tools.test compiler.cfg.checker
+compiler.cfg.debugger compiler.cfg.def-use sets kernel
+kernel.private fry slots.private vectors sequences.private
+math sbufs math.private strings ;
 IN: compiler.cfg.optimizer.tests
 
 ! Miscellaneous tests
diff --git a/extra/webapps/imagebin/imagebin.factor b/extra/webapps/imagebin/imagebin.factor
index f347377d95..bb8720466c 100755
--- a/extra/webapps/imagebin/imagebin.factor
+++ b/extra/webapps/imagebin/imagebin.factor
@@ -1,39 +1,45 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel furnace.actions html.forms
-http.server.dispatchers db db.tuples db.types urls
-furnace.redirection multiline http namespaces ;
+USING: accessors furnace.actions furnace.redirection
+html.forms http http.server http.server.dispatchers
+io.directories io.encodings.utf8 io.files io.pathnames
+kernel math.parser multiline namespaces sequences urls ;
 IN: webapps.imagebin
 
-TUPLE: imagebin < dispatcher ;
-
-TUPLE: image id path ;
-
-image "IMAGE" {
-    { "id" "ID" INTEGER +db-assigned-id+ }
-    { "path" "PATH" { VARCHAR 256 } +not-null+ }
-} define-persistent
+TUPLE: imagebin < dispatcher path n ;
 
 : <uploaded-image-action> ( -- action )
     <page-action>
         { imagebin "uploaded-image" } >>template ;
 
-SYMBOL: my-post-data
+: next-image-path ( -- path )
+    imagebin get
+    [ path>> ] [ n>> number>string ] bi append-path ; 
+
+M: imagebin call-responder*
+    [ imagebin set ] [ call-next-method ] bi ;
+
+: move-image ( mime-file -- )
+    next-image-path
+    [ [ temporary-path>> ] dip move-file ]
+    [ [ filename>> ] dip ".txt" append utf8 set-file-contents ] 2bi ;
+
 : <upload-image-action> ( -- action )
     <page-action>
         { imagebin "upload-image" } >>template
         [
-            
-            ! request get post-data>> my-post-data set-global
-            ! image new
-            !    "file" value
-                ! insert-tuple
+            "file1" param [ move-image ] when*
+            "file2" param [ move-image ] when*
+            "file3" param [ move-image ] when*
             "uploaded-image" <redirect>
         ] >>submit ;
 
-: <imagebin> ( -- responder )
+: <imagebin> ( image-directory -- responder )
     imagebin new-dispatcher
+        swap [ make-directories ] [ >>path ] bi
+        0 >>n
         <upload-image-action> "" add-responder
         <upload-image-action> "upload-image" add-responder
         <uploaded-image-action> "uploaded-image" add-responder ;
 
+"resource:images" <imagebin> main-responder set-global
diff --git a/extra/webapps/imagebin/uploaded-image.xml b/extra/webapps/imagebin/uploaded-image.xml
index 903be5cca4..79dfabc924 100644
--- a/extra/webapps/imagebin/uploaded-image.xml
+++ b/extra/webapps/imagebin/uploaded-image.xml
@@ -2,6 +2,6 @@
 <html>
 <head><title>Uploaded</title></head>
 <body>
-hi from uploaded-image
+You uploaded something!
 </body>
 </html>

From 189043eae74620ea93d5cc5ba5ae304a1840cbdd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 21:07:39 -0500
Subject: [PATCH 31/42] compiler.cfg.linear-scan.assignment: insert-copy did
 the wrong thing if the second interval had been split. Fixes compilation of
 'trilerp'

---
 basis/compiler/cfg/linear-scan/assignment/assignment.factor | 5 ++++-
 basis/math/vectors/vectors-tests.factor                     | 2 ++
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index ea717f9218..ab03882757 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -50,9 +50,12 @@ ERROR: already-spilled ;
 : handle-spill ( live-interval -- )
     dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
 
+: next-interval ( live-interval -- live-interval' )
+    split-next>> dup split-before>> [ next-interval ] [ ] ?if ;
+
 : insert-copy ( live-interval -- )
     {
-        [ split-next>> reg>> ]
+        [ next-interval reg>> ]
         [ reg>> ]
         [ vreg>> reg-class>> ]
         [ end>> ]
diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor
index 968af6a3aa..3e56644d3e 100644
--- a/basis/math/vectors/vectors-tests.factor
+++ b/basis/math/vectors/vectors-tests.factor
@@ -16,3 +16,5 @@ USING: math.vectors tools.test ;
 [ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test 
 
 [ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
+
+[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
\ No newline at end of file

From 46a3608e3a0a3ab5e610eda1a8400cc5ae481aea Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 21:07:55 -0500
Subject: [PATCH 32/42] compiler.cfg.builder: fix stack effect

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

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index f4421e3ef4..265643f3d7 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -82,7 +82,7 @@ GENERIC: emit-node ( node -- )
 : recursive-height ( #recursive -- n )
     [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
 
-: emit-recursive ( #recursive -- next )
+: emit-recursive ( #recursive -- )
     [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
 

From 9bcdf463a111f50053c2df1acd06de65b09833f0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 21:08:08 -0500
Subject: [PATCH 33/42] compiler.cfg.tco: fix tail call optimization for
 ##fixnum-mul

---
 basis/compiler/cfg/tco/tco.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor
index 9b223ad980..fedf4f627e 100644
--- a/basis/compiler/cfg/tco/tco.factor
+++ b/basis/compiler/cfg/tco/tco.factor
@@ -4,6 +4,7 @@ USING: accessors combinators.short-circuit kernel math
 namespaces sequences fry combinators
 compiler.cfg
 compiler.cfg.rpo
+compiler.cfg.hats
 compiler.cfg.instructions ;
 IN: compiler.cfg.tco
 
@@ -59,7 +60,7 @@ GENERIC: convert-fixnum-tail-call* ( src1 src2 insn -- insn' )
 
 M: ##fixnum-add convert-fixnum-tail-call* drop \ ##fixnum-add-tail new-insn ;
 M: ##fixnum-sub convert-fixnum-tail-call* drop \ ##fixnum-sub-tail new-insn ;
-M: ##fixnum-mul convert-fixnum-tail-call* drop \ ##fixnum-mul-tail new-insn ;
+M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn ;
 
 : convert-fixnum-tail-call ( bb -- )
     [

From fa4f7100958dc59249fe77966354aa11ddc282f4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 21:21:46 -0500
Subject: [PATCH 34/42] compiler.cfg Remove height tracking for ##call
 instructions, wire in ##no-tco instruction

---
 basis/compiler/cfg/builder/builder.factor       | 17 +++++++----------
 .../cfg/instructions/instructions.factor        |  5 ++++-
 .../cfg/stack-analysis/stack-analysis.factor    |  3 ++-
 basis/compiler/cfg/utilities/utilities.factor   |  5 +----
 basis/compiler/codegen/codegen.factor           |  2 ++
 5 files changed, 16 insertions(+), 16 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 265643f3d7..7b7adf848e 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -72,18 +72,15 @@ GENERIC: emit-node ( node -- )
     basic-block get successors>> push
     basic-block off ;
 
-: emit-call ( word height -- )
-    over loops get key?
-    [ drop loops get at local-recursive-call ]
+: emit-call ( word -- )
+    dup loops get key?
+    [ loops get at local-recursive-call ]
     [ ##call ##branch begin-basic-block ]
     if ;
 
 ! #recursive
-: recursive-height ( #recursive -- n )
-    [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
-
 : emit-recursive ( #recursive -- )
-    [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
+    [ label>> id>> emit-call ]
     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
 
 : remember-loop ( label -- )
@@ -152,10 +149,10 @@ M: #dispatch emit-node
 ! #call
 M: #call emit-node
     dup word>> dup "intrinsic" word-prop
-    [ emit-intrinsic ] [ swap call-height emit-call ] if ;
+    [ emit-intrinsic ] [ nip emit-call ] if ;
 
 ! #call-recursive
-M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
+M: #call-recursive emit-node label>> id>> emit-call ;
 
 ! #push
 M: #push emit-node
@@ -180,7 +177,7 @@ M: #return-recursive emit-node
     [ ##epilogue ##return ] unless ;
 
 ! #terminate
-M: #terminate emit-node drop ;
+M: #terminate emit-node drop ##no-tco ;
 
 ! FFI
 : return-size ( ctype -- n )
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 4ce9c59e7e..17a02175d5 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -53,10 +53,13 @@ INSN: ##inc-r { n integer } ;
 
 ! Subroutine calls
 INSN: ##stack-frame stack-frame ;
-INSN: ##call word { height integer } ;
+INSN: ##call word ;
 INSN: ##jump word ;
 INSN: ##return ;
 
+! Dummy instruction that simply inhibits TCO
+INSN: ##no-tco ;
+
 ! Jump tables
 INSN: ##dispatch src temp ;
 
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index 1e7f33c7e0..fb71fe332d 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -48,7 +48,8 @@ M: ##inc-r visit
 ! Instructions which don't have any effect on the stack
 UNION: neutral-insn
     ##effect
-    ##flushable ;
+    ##flushable
+    ##no-tco ;
 
 M: neutral-insn visit , ;
 
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index e415008808..99a138a763 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -35,8 +35,5 @@ 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-height ] bi ##call ##branch begin-basic-block ;
+    word>> ##call ##branch begin-basic-block ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index a1583d2a5d..df6e91aec9 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -67,6 +67,8 @@ SYMBOL: labels
 : lookup-label ( id -- label )
     labels get [ drop <label> ] cache ;
 
+M: ##no-tco generate-insn drop ;
+
 M: ##load-immediate generate-insn
     [ dst>> register ] [ val>> ] bi %load-immediate ;
 

From 139bb68f8e52eb9d97c91e715a8229c2f241646c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 22:11:15 -0500
Subject: [PATCH 35/42] Change branch splitting around a bit, rename
 useless-blocks to useless-conditionals and rewrite it

---
 .../branch-splitting/branch-splitting.factor  | 38 +++++++-----
 basis/compiler/cfg/cfg.factor                 | 13 +++-
 basis/compiler/cfg/optimizer/optimizer.factor |  6 +-
 basis/compiler/cfg/tco/tco.factor             |  1 +
 .../useless-blocks-tests.factor               | 11 ----
 .../cfg/useless-blocks/useless-blocks.factor  | 62 -------------------
 .../summary.txt                               |  0
 .../useless-conditionals.factor               | 22 +++++++
 8 files changed, 62 insertions(+), 91 deletions(-)
 delete mode 100644 basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
 delete mode 100644 basis/compiler/cfg/useless-blocks/useless-blocks.factor
 rename basis/compiler/cfg/{useless-blocks => useless-conditionals}/summary.txt (100%)
 create mode 100644 basis/compiler/cfg/useless-conditionals/useless-conditionals.factor

diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
index 2b3d88191c..f7e9ea9cbf 100644
--- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor
+++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
@@ -1,24 +1,31 @@
-! Copyright (C) 2009 Doug Coleman.
+! Copyright (C) 2009 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit compiler.cfg.def-use
-compiler.cfg.rpo kernel math sequences ;
+USING: accessors combinators.short-circuit kernel math sequences
+compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ;
 IN: compiler.cfg.branch-splitting
 
-: split-branch ( branch -- )
+! Predecessors must be recomputed after this
+
+: split-branch-for ( bb predecessor -- )
     [
-        [ instructions>> ] [ predecessors>> ] bi [
-            instructions>> [ pop* ] [ push-all ] bi
-        ] with each
-    ] [
-        [ successors>> ] [ predecessors>> ] bi [
-            [ drop clone ] change-successors drop
-        ] with each
-    ] bi ;
+        [
+            <basic-block>
+                swap
+                [ instructions>> [ clone ] map >>instructions ]
+                [ successors>> clone >>successors ]
+                bi
+        ] keep
+    ] dip
+    [ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors
+    drop ;
+
+: split-branch ( bb -- )
+    dup predecessors>> [ split-branch-for ] with each ;
 
 : split-branches? ( bb -- ? )
     {
-        [ predecessors>> length 1 >= ]
-        [ successors>> length 1 <= ]
+        [ successors>> empty? ]
+        [ predecessors>> length 1 > ]
         [ instructions>> [ defs-vregs ] any? not ]
         [ instructions>> [ temp-vregs ] any? not ]
     } 1&& ;
@@ -26,4 +33,5 @@ IN: compiler.cfg.branch-splitting
 : split-branches ( cfg -- cfg' )
     dup [
         dup split-branches? [ split-branch ] [ drop ] if
-    ] each-basic-block f >>post-order ;
+    ] each-basic-block
+    f >>post-order ;
diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index dabc7338d2..b279c5b6b2 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -1,7 +1,9 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel arrays vectors accessors
-namespaces math make fry sequences ;
+namespaces math make fry sequences
+combinators.short-circuit
+compiler.cfg.instructions ;
 IN: compiler.cfg
 
 TUPLE: basic-block < identity-tuple
@@ -20,6 +22,15 @@ M: basic-block hashcode* nip id>> ;
         V{ } clone >>predecessors
         \ basic-block counter >>id ;
 
+: empty-block? ( bb -- ? )
+    instructions>> {
+        [ length 1 = ]
+        [ first ##branch? ]
+    } 1&& ;
+
+: skip-empty-blocks ( bb -- bb' )
+    dup empty-block? [ successors>> first skip-empty-blocks ] when ;
+
 : add-instructions ( bb quot -- )
     [ instructions>> building ] dip '[
         building get pop
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index c8450a1c47..d6b1221fef 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -3,8 +3,9 @@
 USING: kernel sequences accessors combinators namespaces
 compiler.cfg.tco
 compiler.cfg.predecessors
-compiler.cfg.useless-blocks
+compiler.cfg.useless-conditionals
 compiler.cfg.stack-analysis
+compiler.cfg.branch-splitting
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
 compiler.cfg.dce
@@ -26,8 +27,9 @@ SYMBOL: check-optimizer?
     [
         optimize-tail-calls
         compute-predecessors
-        ! delete-useless-blocks
         delete-useless-conditionals
+        split-branches
+        compute-predecessors
         stack-analysis
         compute-liveness
         alias-analysis
diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor
index fedf4f627e..df5d962999 100644
--- a/basis/compiler/cfg/tco/tco.factor
+++ b/basis/compiler/cfg/tco/tco.factor
@@ -11,6 +11,7 @@ IN: compiler.cfg.tco
 ! Tail call optimization. You must run compute-predecessors after this
 
 : return? ( bb -- ? )
+    skip-empty-blocks
     instructions>> {
         [ length 2 = ]
         [ first ##epilogue? ]
diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
deleted file mode 100644
index 1d14cef193..0000000000
--- a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
+++ /dev/null
@@ -1,11 +0,0 @@
-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 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
deleted file mode 100644
index cbe006b4d7..0000000000
--- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor
+++ /dev/null
@@ -1,62 +0,0 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-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
-        ] with map
-    ] change-successors drop ;
-
-: update-successor-for-delete ( bb -- )
-    ! 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 ]
-    [ update-successor-for-delete ]
-    bi ;
-
-: delete-basic-block? ( bb -- ? )
-    {
-        [ instructions>> length 1 = ]
-        [ predecessors>> length 1 = ]
-        [ successors>> length 1 = ]
-        [ instructions>> first ##branch? ]
-    } 1&& ;
-
-: delete-useless-blocks ( cfg -- cfg' )
-    dup [
-        dup delete-basic-block? [ delete-basic-block ] [ drop ] if
-    ] each-basic-block
-    f >>post-order ;
-
-: delete-conditional? ( bb -- ? )
-    dup instructions>> [ drop f ] [
-        last class {
-            ##compare-branch
-            ##compare-imm-branch
-            ##compare-float-branch
-        } memq? [ successors>> first2 eq? ] [ drop f ] if
-    ] if-empty ;
-
-: delete-conditional ( bb -- )
-    dup successors>> first 1vector >>successors
-    [ but-last \ ##branch new-insn suffix ] change-instructions
-    drop ;
-
-: delete-useless-conditionals ( cfg -- cfg' )
-    dup [
-        dup delete-conditional? [ delete-conditional ] [ drop ] if
-    ] each-basic-block
-    f >>post-order ;
diff --git a/basis/compiler/cfg/useless-blocks/summary.txt b/basis/compiler/cfg/useless-conditionals/summary.txt
similarity index 100%
rename from basis/compiler/cfg/useless-blocks/summary.txt
rename to basis/compiler/cfg/useless-conditionals/summary.txt
diff --git a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
new file mode 100644
index 0000000000..7c32f3f8f8
--- /dev/null
+++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
@@ -0,0 +1,22 @@
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences math combinators combinators.short-circuit
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+IN: compiler.cfg.useless-conditionals
+
+: delete-conditional? ( bb -- ? )
+    {
+        [ instructions>> length 1 > ]
+        [ instructions>> last class { ##compare-branch ##compare-imm-branch ##compare-float-branch } memq? ]
+        [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
+    } 1&& ;
+
+: delete-conditional ( bb -- )
+    [ first skip-empty-blocks 1vector ] change-successors
+    instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
+
+: delete-useless-conditionals ( cfg -- cfg' )
+    dup [
+        dup delete-conditional? [ delete-conditional ] [ drop ] if
+    ] each-basic-block
+    f >>post-order ;

From 19036c5105b7de72bd09751f6a0a8be2b4777c72 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 22:43:02 -0500
Subject: [PATCH 36/42] Fix possible infinite loop in skip-empty-blocks and
 remove redundant test in compiler.cfg.useless-conditionals

---
 basis/compiler/cfg/cfg.factor                      | 14 ++++++++++++--
 .../useless-conditionals.factor                    |  1 -
 2 files changed, 12 insertions(+), 3 deletions(-)

diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index b279c5b6b2..68d7e15a5d 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays vectors accessors
+USING: kernel arrays vectors accessors assocs sets
 namespaces math make fry sequences
 combinators.short-circuit
 compiler.cfg.instructions ;
@@ -28,8 +28,18 @@ M: basic-block hashcode* nip id>> ;
         [ first ##branch? ]
     } 1&& ;
 
+SYMBOL: visited
+
+: (skip-empty-blocks) ( bb -- bb' )
+    dup visited get key? [
+        dup empty-block? [
+            dup visited get conjoin
+            successors>> first (skip-empty-blocks)
+        ] when
+    ] unless ;
+
 : skip-empty-blocks ( bb -- bb' )
-    dup empty-block? [ successors>> first skip-empty-blocks ] when ;
+    H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
 
 : add-instructions ( bb quot -- )
     [ instructions>> building ] dip '[
diff --git a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
index 7c32f3f8f8..6f4a6eea55 100644
--- a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
+++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
@@ -6,7 +6,6 @@ IN: compiler.cfg.useless-conditionals
 
 : delete-conditional? ( bb -- ? )
     {
-        [ instructions>> length 1 > ]
         [ instructions>> last class { ##compare-branch ##compare-imm-branch ##compare-float-branch } memq? ]
         [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
     } 1&& ;

From cdd95472c7f1c76628519ac7821b4bee353ec1dd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 22:43:32 -0500
Subject: [PATCH 37/42] compiler.cfg.branch-folding: fold away branches where
 both inputs are the same register. This results in 'push' being compiled
 slightly better

---
 .../cfg/branch-folding/branch-folding.factor  | 30 +++++++++++++++++++
 basis/compiler/cfg/optimizer/optimizer.factor |  5 ++++
 2 files changed, 35 insertions(+)
 create mode 100644 basis/compiler/cfg/branch-folding/branch-folding.factor

diff --git a/basis/compiler/cfg/branch-folding/branch-folding.factor b/basis/compiler/cfg/branch-folding/branch-folding.factor
new file mode 100644
index 0000000000..627db63c9f
--- /dev/null
+++ b/basis/compiler/cfg/branch-folding/branch-folding.factor
@@ -0,0 +1,30 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel sequences vectors
+compiler.cfg.instructions compiler.cfg.rpo ;
+IN: compiler.cfg.branch-folding
+
+! Fold comparisons where both inputs are the same. Predecessors must be
+! recomputed after this
+
+: fold-branch? ( bb -- ? )
+    instructions>> last {
+        [ ##compare-branch? ]
+        [ [ src1>> ] [ src2>> ] bi = ]
+    } 1&& ;
+
+: chosen-successor ( bb -- succ )
+    [ instructions>> last cc>> { cc= cc<= cc>= } memq? 0 1 ? ]
+    [ successors>> ]
+    bi nth ;
+
+: fold-branch ( bb -- )
+    dup chosen-successor 1vector >>successors
+    instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
+
+: fold-branches ( cfg -- cfg' )
+    dup [
+        dup fold-branch?
+        [ fold-branch ] [ drop ] if
+    ] each-basic-block
+    f >>post-order ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index d6b1221fef..84eb8a84d1 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -9,6 +9,7 @@ compiler.cfg.branch-splitting
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
 compiler.cfg.dce
+compiler.cfg.branch-folding
 compiler.cfg.write-barrier
 compiler.cfg.liveness
 compiler.cfg.rpo
@@ -24,6 +25,8 @@ SYMBOL: check-optimizer?
     ] when ;
 
 : optimize-cfg ( cfg -- cfg' )
+    ! Note that compute-predecessors has to be called several times.
+    ! The passes that need this document it.
     [
         optimize-tail-calls
         compute-predecessors
@@ -34,6 +37,8 @@ SYMBOL: check-optimizer?
         compute-liveness
         alias-analysis
         value-numbering
+        fold-branches
+        compute-predecessors
         eliminate-dead-code
         eliminate-write-barriers
         eliminate-phis

From 0ad81de3b6818e6256b3ec6758ad374d015799a3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 30 Jun 2009 22:59:53 -0500
Subject: [PATCH 38/42] combine add-imm instructions into a single add

---
 .../value-numbering/rewrite/rewrite.factor    | 49 +++++++++++++------
 1 file changed, 34 insertions(+), 15 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 7630d0a658..30214e3bf9 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -1,12 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences layouts accessors combinators namespaces
-math fry
-compiler.cfg.hats
-compiler.cfg.instructions
+USING: accessors combinators combinators.short-circuit
+compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.simplify
-compiler.cfg.value-numbering.expressions ;
+compiler.cfg.value-numbering.simplify fry kernel layouts math
+namespaces sequences ;
 IN: compiler.cfg.value-numbering.rewrite
 
 GENERIC: rewrite ( insn -- insn' )
@@ -19,8 +18,10 @@ M: ##mul-imm rewrite
 
 : ##branch-t? ( insn -- ? )
     dup ##compare-imm-branch? [
-        [ cc>> cc/= eq? ]
-        [ src2>> \ f tag-number eq? ] bi and
+        {
+            [ cc>> cc/= eq? ]
+            [ src2>> \ f tag-number eq? ]
+        } 1&&
     ] [ drop f ] if ; inline
 
 : rewrite-boolean-comparison? ( insn -- ? )
@@ -47,9 +48,10 @@ M: ##mul-imm rewrite
 
 : rewrite-tagged-comparison? ( insn -- ? )
     #! Are we comparing two tagged fixnums? Then untag them.
-    [ src1>> vreg>expr tag-fixnum-expr? ]
-    [ src2>> tag-mask get bitand 0 = ]
-    bi and ; inline
+    {
+        [ src1>> vreg>expr tag-fixnum-expr? ]
+        [ src2>> tag-mask get bitand 0 = ]
+    } 1&& ; inline
 
 : (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
     [ src1>> vreg>expr in1>> vn>vreg ]
@@ -89,10 +91,11 @@ M: ##compare rewrite
     ] when ;
 
 : rewrite-redundant-comparison? ( insn -- ? )
-    [ src1>> vreg>expr compare-expr? ]
-    [ src2>> \ f tag-number = ]
-    [ cc>> { cc= cc/= } memq? ]
-    tri and and ; inline
+    {
+        [ src1>> vreg>expr compare-expr? ]
+        [ src2>> \ f tag-number = ]
+        [ cc>> { cc= cc/= } memq? ]
+    } 1&& ; inline
 
 : rewrite-redundant-comparison ( insn -- insn' )
     [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
@@ -114,4 +117,20 @@ M: ##compare-imm rewrite
         ] when
     ] when ;
 
+: combine-add-imm? ( insn -- ? )
+    {
+        [ src1>> vreg>expr op>> \ ##add-imm = ]
+        [ src2>> number? ]
+    } 1&& ;
+
+: combine-add-imm ( dst src n -- insn )
+    [ vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ] dip
+    + \ ##add-imm new-insn ;
+
+M: ##add-imm rewrite
+    dup combine-add-imm? [
+        [ dst>> ] [ src1>> ] [ src2>> ] tri combine-add-imm
+        dup number-values
+    ] when ;
+
 M: insn rewrite ;

From ccd847083e9cd90a90606c60c46cb3aeb08a42f3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 30 Jun 2009 23:01:44 -0500
Subject: [PATCH 39/42] optimize fixnum*fast and fixnum-shift-fast

---
 .../compiler/cfg/builder/builder-tests.factor |  4 ++
 .../cfg/intrinsics/fixnum/fixnum.factor       | 48 ++++++++++++-------
 2 files changed, 36 insertions(+), 16 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index 58eae8181b..4a481a09d8 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -18,10 +18,14 @@ kernel.private math ;
     [ 3 fixnum+fast ]
     [ fixnum*fast ]
     [ 3 fixnum*fast ]
+    [ 3 swap fixnum*fast ]
     [ fixnum-shift-fast ]
     [ 10 fixnum-shift-fast ]
     [ -10 fixnum-shift-fast ]
     [ 0 fixnum-shift-fast ]
+    [ 10 swap fixnum-shift-fast ]
+    [ -10 swap fixnum-shift-fast ]
+    [ 0 swap fixnum-shift-fast ]
     [ fixnum-bitnot ]
     [ eq? ]
     [ "hi" eq? ]
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index a93fa5d902..8fbc169098 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -52,18 +52,27 @@ IN: compiler.cfg.intrinsics.fixnum
         ds-push
     ] ; inline
 
-: emit-fixnum-shift-fast ( node -- )
-    dup node-input-infos dup second value-info-small-fixnum? [
-        nip
-        [ ds-drop ds-pop ] dip
-        second literal>> dup sgn {
-            { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
-            {  0 [ drop ] }
-            {  1 [ ^^shl-imm ] }
-        } case
-        ds-push
-    ] [ drop emit-primitive ] if ;
+: (emit-fixnum-shift-fast) ( obj node -- obj )
+    literal>> dup sgn {
+        { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
+        {  0 [ drop ] }
+        {  1 [ ^^shl-imm ] }
+    } case ;
 
+: emit-fixnum-shift-fast ( node -- )
+    dup node-input-infos dup first value-info-small-fixnum? [
+        nip
+        [ ds-pop ds-drop ] dip first (emit-fixnum-shift-fast) ds-push
+    ] [
+        drop
+        dup node-input-infos dup second value-info-small-fixnum? [
+            nip
+            [ ds-drop ds-pop ] dip second (emit-fixnum-shift-fast) ds-push
+        ] [
+            drop emit-primitive
+        ] if
+    ] if ;
+    
 : emit-fixnum-bitnot ( -- )
     ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
 
@@ -73,14 +82,21 @@ IN: compiler.cfg.intrinsics.fixnum
 : (emit-fixnum*fast) ( -- dst )
     2inputs ^^untag-fixnum ^^mul ;
 
-: (emit-fixnum*fast-imm) ( infos -- dst )
-    ds-drop
-    [ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
+: (emit-fixnum*fast-imm1) ( infos -- dst )
+    [ ds-pop ds-drop ] [ first literal>> ] bi* ^^mul-imm ;
+
+: (emit-fixnum*fast-imm2) ( infos -- dst )
+    [ ds-drop ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
 
 : emit-fixnum*fast ( node -- )
     node-input-infos
-    dup second value-info-small-fixnum?
-    [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
+    dup first value-info-small-fixnum?
+    [
+        (emit-fixnum*fast-imm1)
+    ] [
+        dup second value-info-small-fixnum?
+        [ (emit-fixnum*fast-imm2) ] [ drop (emit-fixnum*fast) ] if
+    ] if
     ds-push ;
 
 : (emit-fixnum-comparison) ( cc -- quot1 quot2 )

From 0837732c102bf3e6a0b1969ae5a704ba2b959ec8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 23:03:25 -0500
Subject: [PATCH 40/42] compiler.cfg.builder: emit less crap after a #terminate
 node

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

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 7b7adf848e..8cf141f3f4 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -67,14 +67,14 @@ GENERIC: emit-node ( node -- )
         ] with-variable
     ] keep ;
 
-: local-recursive-call ( basic-block -- )
+: emit-loop-call ( basic-block -- )
     ##branch
     basic-block get successors>> push
     basic-block off ;
 
 : emit-call ( word -- )
     dup loops get key?
-    [ loops get at local-recursive-call ]
+    [ loops get at emit-loop-call ]
     [ ##call ##branch begin-basic-block ]
     if ;
 
@@ -177,7 +177,7 @@ M: #return-recursive emit-node
     [ ##epilogue ##return ] unless ;
 
 ! #terminate
-M: #terminate emit-node drop ##no-tco ;
+M: #terminate emit-node drop ##no-tco basic-block off ;
 
 ! FFI
 : return-size ( ctype -- n )

From 49830913440feb5f9a138069d073fc1858835ee5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 23:07:27 -0500
Subject: [PATCH 41/42] compiler.cfg.optimizer: disable branch folding for now

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

diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 84eb8a84d1..529f93e9fb 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -37,8 +37,8 @@ SYMBOL: check-optimizer?
         compute-liveness
         alias-analysis
         value-numbering
-        fold-branches
-        compute-predecessors
+        ! fold-branches
+        ! compute-predecessors
         eliminate-dead-code
         eliminate-write-barriers
         eliminate-phis

From 720ad7cfa7aa4e0756e8a25c8165a362ceba9d2e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 23:17:33 -0500
Subject: [PATCH 42/42] compiler.cfg.stack-analysis: fix unit tests for
 useless-blocks renaming and ##no-tco instruction

---
 basis/compiler/cfg/checker/checker.factor                     | 2 +-
 basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index 4f215f1dc8..e7d9dbdd9c 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -19,7 +19,7 @@ ERROR: last-insn-not-a-jump insn ;
         [ ##fixnum-add-tail? ]
         [ ##fixnum-sub-tail? ]
         [ ##fixnum-mul-tail? ]
-        [ ##call? ]
+        [ ##no-tco? ]
     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
 
 ERROR: bad-loop-entry ;
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index 6f4b88e28e..cbc939b1f2 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -3,7 +3,7 @@ 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.rpo
-compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
+compiler.cfg.dce compiler.cfg.registers
 sets namespaces arrays cpu.architecture ;
 IN: compiler.cfg.stack-analysis.tests