From 809b40d4971cc888284a3558c56d737c7e46ad1c Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 7 Jul 2009 16:26:50 -0500
Subject: [PATCH 01/31] preserve sequence type in math.matrices:cross

---
 basis/math/matrices/matrices.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor
index b939162577..3203355bb9 100644
--- a/basis/math/matrices/matrices.factor
+++ b/basis/math/matrices/matrices.factor
@@ -120,7 +120,7 @@ IN: math.matrices
 
 PRIVATE>
 
-: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
+: cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ;
 
 : proj ( v u -- w )
     [ [ v. ] [ norm-sq ] bi / ] keep n*v ;

From 771d4fd4d9071a276d034833e17db39c5b477436 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 7 Jul 2009 16:27:14 -0500
Subject: [PATCH 02/31] byte-length for specialized-vectors

---
 basis/specialized-vectors/functor/functor.factor | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor
index 6635fbeaf2..08c44cd197 100644
--- a/basis/specialized-vectors/functor/functor.factor
+++ b/basis/specialized-vectors/functor/functor.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: functors sequences sequences.private growable
+USING: accessors alien.c-types functors sequences sequences.private growable
 prettyprint.custom kernel words classes math parser ;
 QUALIFIED: vectors.functor
 IN: specialized-vectors.functor
@@ -21,6 +21,8 @@ V A <A> vectors.functor:define-vector
 
 M: V contract 2drop ;
 
+M: V byte-length underlying>> byte-length ;
+
 M: V pprint-delims drop \ V{ \ } ;
 
 M: V >pprint-sequence ;

From 23b8f4826764027d406232d24e2b0ee05ccc0bac Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Fri, 10 Jul 2009 00:52:08 -0500
Subject: [PATCH 03/31] stack-checker.known-words:infer-special uses a word
 property

---
 basis/stack-checker/known-words/authors.txt   |  1 +
 .../known-words/known-words.factor            | 84 ++++++++++++-------
 2 files changed, 53 insertions(+), 32 deletions(-)

diff --git a/basis/stack-checker/known-words/authors.txt b/basis/stack-checker/known-words/authors.txt
index 1901f27a24..a44f8d7f8d 100644
--- a/basis/stack-checker/known-words/authors.txt
+++ b/basis/stack-checker/known-words/authors.txt
@@ -1 +1,2 @@
 Slava Pestov
+Daniel Ehrenberg
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index cf2d08b84f..5bf50dfac1 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors alien alien.accessors arrays byte-arrays classes
 continuations.private effects generic hashtables
@@ -67,12 +67,18 @@ IN: stack-checker.known-words
     [ length ensure-d ] keep zip
     #declare, ;
 
+\ declare [ infer-declare ] "special" set-word-prop
+
 GENERIC: infer-call* ( value known -- )
 
 : (infer-call) ( value -- ) dup known infer-call* ;
 
 : infer-call ( -- ) pop-d (infer-call) ;
 
+\ call [ infer-call ] "special" set-word-prop
+
+\ (call) [ infer-call ] "special" set-word-prop
+
 M: literal infer-call*
     [ 1array #drop, ] [ infer-literal-quot ] bi* ;
 
@@ -103,10 +109,16 @@ M: object infer-call*
 
 : infer-dip ( -- ) \ dip 1 infer-ndip ;
 
+\ dip [ infer-dip ] "special" set-word-prop
+
 : infer-2dip ( -- ) \ 2dip 2 infer-ndip ;
 
+\ 2dip [ infer-2dip ] "special" set-word-prop
+
 : infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
 
+\ 3dip [ infer-3dip ] "special" set-word-prop
+
 : infer-builder ( quot word -- )
     [
         [ 2 consume-d ] dip
@@ -116,8 +128,12 @@ M: object infer-call*
 
 : infer-curry ( -- ) [ <curried> ] \ curry infer-builder ;
 
+\ curry [ infer-curry ] "special" set-word-prop
+
 : infer-compose ( -- ) [ <composed> ] \ compose infer-builder ;
 
+\ compose [ infer-compose ] "special" set-word-prop
+
 : infer-execute ( -- )
     pop-literal nip
     dup word? [
@@ -127,11 +143,17 @@ M: object infer-call*
         "execute must be given a word" time-bomb
     ] if ;
 
+\ execute [ infer-execute ] "special" set-word-prop
+
+\ (execute) [ infer-execute ] "special" set-word-prop
+
 : infer-<tuple-boa> ( -- )
     \ <tuple-boa>
     peek-d literal value>> second 1+ { tuple } <effect>
     apply-word/effect ;
 
+\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
+
 : infer-effect-unsafe ( word -- )
     pop-literal nip
     add-effect-input
@@ -140,17 +162,30 @@ M: object infer-call*
 : infer-execute-effect-unsafe ( -- )
     \ (execute) infer-effect-unsafe ;
 
+\ execute-effect-unsafe [ infer-execute-effect-unsafe ] "special" set-word-prop
+
 : infer-call-effect-unsafe ( -- )
     \ call infer-effect-unsafe ;
 
+\ call-effect-unsafe [ infer-call-effect-unsafe ] "special" set-word-prop
+
 : infer-exit ( -- )
     \ exit (( n -- * )) apply-word/effect ;
 
+\ exit [ infer-exit ] "special" set-word-prop
+
 : infer-load-locals ( -- )
     pop-literal nip
     consume-d dup copy-values dup output-r
     [ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
 
+\ load-locals [ infer-load-locals ] "special" set-word-prop
+
+: infer-load-local ( -- )
+    1 infer->r ;
+
+\ load-local [ infer-load-local ] "special" set-word-prop
+
 : infer-get-local ( -- )
     [let* | n [ pop-literal nip 1 swap - ]
             in-r [ n consume-r ]
@@ -163,36 +198,24 @@ M: object infer-call*
          #shuffle,
     ] ;
 
+\ get-local [ infer-get-local ] "special" set-word-prop
+
 : infer-drop-locals ( -- )
     f f pop-literal nip consume-r f f #shuffle, ;
 
+\ drop-locals [ infer-drop-locals ] "special" set-word-prop
+
+\ do-primitive [ unknown-primitive-error ] "special" set-word-prop
+
+\ if [ infer-if ] "special" set-word-prop
+\ dispatch [ infer-dispatch ] "special" set-word-prop
+
+\ alien-invoke [ infer-alien-invoke ] "special" set-word-prop
+\ alien-indirect [ infer-alien-indirect ] "special" set-word-prop
+\ alien-callback [ infer-alien-callback ] "special" set-word-prop
+
 : infer-special ( word -- )
-    {
-        { \ declare [ infer-declare ] }
-        { \ call [ infer-call ] }
-        { \ (call) [ infer-call ] }
-        { \ dip [ infer-dip ] }
-        { \ 2dip [ infer-2dip ] }
-        { \ 3dip [ infer-3dip ] }
-        { \ curry [ infer-curry ] }
-        { \ compose [ infer-compose ] }
-        { \ execute [ infer-execute ] }
-        { \ (execute) [ infer-execute ] }
-        { \ execute-effect-unsafe [ infer-execute-effect-unsafe ] }
-        { \ call-effect-unsafe [ infer-call-effect-unsafe ] }
-        { \ if [ infer-if ] }
-        { \ dispatch [ infer-dispatch ] }
-        { \ <tuple-boa> [ infer-<tuple-boa> ] }
-        { \ exit [ infer-exit ] }
-        { \ load-local [ 1 infer->r ] }
-        { \ load-locals [ infer-load-locals ] }
-        { \ get-local [ infer-get-local ] }
-        { \ drop-locals [ infer-drop-locals ] }
-        { \ do-primitive [ unknown-primitive-error ] }
-        { \ alien-invoke [ infer-alien-invoke ] }
-        { \ alien-indirect [ infer-alien-indirect ] }
-        { \ alien-callback [ infer-alien-callback ] }
-    } case ;
+    "special" word-prop call( -- ) ;
 
 : infer-local-reader ( word -- )
     (( -- value )) apply-word/effect ;
@@ -209,10 +232,7 @@ M: object infer-call*
     dispatch <tuple-boa> exit load-local load-locals get-local
     drop-locals do-primitive alien-invoke alien-indirect
     alien-callback
-} [
-    [ t "special" set-word-prop ]
-    [ t "no-compile" set-word-prop ] bi
-] each
+} [ t "no-compile" set-word-prop ] each
 
 ! Exceptions to the above
 \ curry f "no-compile" set-word-prop
@@ -662,4 +682,4 @@ M: object infer-call*
 \ reset-inline-cache-stats { } { } define-primitive
 \ inline-cache-stats { } { array } define-primitive
 
-\ optimized? { word } { object } define-primitive
\ No newline at end of file
+\ optimized? { word } { object } define-primitive

From 500c784bd7bf4cb9b5a85b10fa37ffcff804bd38 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Fri, 10 Jul 2009 01:05:03 -0500
Subject: [PATCH 04/31] Minor reorganization of stack-checker.call-effect

---
 .../call-effect/call-effect.factor            | 22 +++++++++----------
 1 file changed, 11 insertions(+), 11 deletions(-)

diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor
index b3b678d93d..12477fdb1d 100644
--- a/basis/stack-checker/call-effect/call-effect.factor
+++ b/basis/stack-checker/call-effect/call-effect.factor
@@ -84,16 +84,16 @@ M: quotation cached-effect
     [ drop call-effect-slow ]
     if ; inline
 
-\ call-effect [
-    inline-cache new '[
-        _
-        3dup nip cache-hit? [
-            drop call-effect-unsafe
-        ] [
-            call-effect-fast
-        ] if
-    ]
-] 0 define-transform
+: call-effect-ic ( quot effect inline-cache -- )
+    3dup nip cache-hit?
+    [ drop call-effect-unsafe ]
+    [ call-effect-fast ]
+    if ; inline
+
+: call-effect>quot ( -- quot )
+    inline-cache new '[ _ call-effect-ic ] ;
+
+\ call-effect [ call-effect>quot ] 0 define-transform
 
 \ call-effect t "no-compile" set-word-prop
 
@@ -120,4 +120,4 @@ M: quotation cached-effect
 
 \ execute-effect [ execute-effect>quot ] 1 define-transform
 
-\ execute-effect t "no-compile" set-word-prop
\ No newline at end of file
+\ execute-effect t "no-compile" set-word-prop

From f4b4195a742575cea794ab854cfbf494fdfb7535 Mon Sep 17 00:00:00 2001
From: Sascha Matzke <sascha.matzke@didolo.org>
Date: Sat, 11 Jul 2009 11:14:17 +0200
Subject: [PATCH 05/31] added unit-tests to bson vocab

---
 extra/bson/bson-tests.factor | 48 ++++++++++++++++++++++++++++++++++++
 1 file changed, 48 insertions(+)
 create mode 100644 extra/bson/bson-tests.factor

diff --git a/extra/bson/bson-tests.factor b/extra/bson/bson-tests.factor
new file mode 100644
index 0000000000..e66b9c6ec2
--- /dev/null
+++ b/extra/bson/bson-tests.factor
@@ -0,0 +1,48 @@
+USING: bson.reader bson.writer byte-arrays io.encodings.binary
+io.streams.byte-array tools.test literals calendar kernel math ;
+
+IN: bson.tests
+
+: turnaround ( value -- value )
+    assoc>bv >byte-array binary [ H{ } stream>assoc ] with-byte-reader ;
+
+M: timestamp equal? ( obj1 obj2 -- ? )
+    [ timestamp>millis ] bi@ = ;
+
+[ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
+
+[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } ]
+[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } turnaround ] unit-test
+
+[ H{ { "a list" { 1 2.234 "hello world" } } } ]
+[ H{ { "a list" { 1 2.234 "hello world" } } } turnaround ] unit-test
+
+[ H{ { "a quotation" [ 1 2 + ] } } ]
+[ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test
+
+[ H{ { "a date" T{ timestamp { year 2009 }
+                   { month 7 }
+                   { day 11 }
+                   { hour 11 }
+                   { minute 8 }
+                   { second 40+15437/200000 }
+                   { gmt-offset T{ duration { hour 2 } } } } } }
+]
+[ H{ { "a date" T{ timestamp { year 2009 }
+                   { month 7 }
+                   { day 11 }
+                   { hour 11 }
+                   { minute 8 }
+                   { second 40+15437/200000 }
+                   { gmt-offset T{ duration { hour 2 } } } } } } turnaround
+] unit-test
+                   
+[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+     { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
+     { "quot" [ 1 2 + ] } }
+]     
+[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+     { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
+     { "quot" [ 1 2 + ] } } turnaround ] unit-test
+     
+     

From 608fb054f26bc006037d8cb4dd2762136b8ab26b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 12 Jul 2009 22:22:46 -0500
Subject: [PATCH 06/31] compiler.cfg: Some code cleanups, update stack-analysis
 and phi-insertion to work on CFGs with critical edges

---
 .../branch-folding-tests.factor               |  5 +-
 .../cfg/branch-folding/branch-folding.factor  |  4 +-
 basis/compiler/cfg/cfg.factor                 | 36 +---------
 .../cfg/optimizer/optimizer-tests.factor      | 11 +++-
 .../phi-elimination-tests.factor              | 10 ++-
 .../phi-elimination/phi-elimination.factor    | 13 ++--
 .../stack-analysis/merge/merge-tests.factor   | 47 ++++++++-----
 .../cfg/stack-analysis/merge/merge.factor     | 66 +++++++++++--------
 .../stack-analysis-tests.factor               | 12 ++--
 .../cfg/stack-analysis/stack-analysis.factor  | 22 ++++++-
 basis/compiler/cfg/tco/tco.factor             |  5 +-
 .../useless-conditionals.factor               |  5 +-
 basis/compiler/cfg/utilities/utilities.factor | 58 ++++++++++++++--
 13 files changed, 185 insertions(+), 109 deletions(-)

diff --git a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor b/basis/compiler/cfg/branch-folding/branch-folding-tests.factor
index 964620d2d3..8ae1f6b75b 100644
--- a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor
+++ b/basis/compiler/cfg/branch-folding/branch-folding-tests.factor
@@ -40,7 +40,10 @@ test-diamond
 [ 1 ] [ 1 get successors>> length ] unit-test
 [ t ] [ 1 get successors>> first 3 get eq? ] unit-test
 
-[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
+[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
+[ 3 get successors>> first instructions>> first ]
+unit-test
+
 [ 2 ] [ 4 get instructions>> length ] unit-test
 
 V{
diff --git a/basis/compiler/cfg/branch-folding/branch-folding.factor b/basis/compiler/cfg/branch-folding/branch-folding.factor
index 627db63c9f..2432849a9a 100644
--- a/basis/compiler/cfg/branch-folding/branch-folding.factor
+++ b/basis/compiler/cfg/branch-folding/branch-folding.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators.short-circuit kernel sequences vectors
-compiler.cfg.instructions compiler.cfg.rpo ;
+compiler.cfg.instructions compiler.cfg.rpo compiler.cfg ;
 IN: compiler.cfg.branch-folding
 
 ! Fold comparisons where both inputs are the same. Predecessors must be
@@ -27,4 +27,4 @@ IN: compiler.cfg.branch-folding
         dup fold-branch?
         [ fold-branch ] [ drop ] if
     ] each-basic-block
-    f >>post-order ;
\ No newline at end of file
+    cfg-changed ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 12a1180d40..f856efac78 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -1,9 +1,6 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays vectors accessors assocs sets
-namespaces math make fry sequences
-combinators.short-circuit
-compiler.cfg.instructions ;
+USING: kernel math vectors arrays accessors namespaces ;
 IN: compiler.cfg
 
 TUPLE: basic-block < identity-tuple
@@ -22,39 +19,12 @@ M: basic-block hashcode* nip id>> ;
         V{ } clone >>predecessors
         \ basic-block counter >>id ;
 
-: empty-block? ( bb -- ? )
-    instructions>> {
-        [ length 1 = ]
-        [ first ##branch? ]
-    } 1&& ;
-
-SYMBOL: visited
-
-: (skip-empty-blocks) ( bb -- bb' )
-    dup visited get key? [
-        dup empty-block? [
-            dup visited get conjoin
-            successors>> first (skip-empty-blocks)
-        ] when
-    ] unless ;
-
-: skip-empty-blocks ( bb -- bb' )
-    H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
-
-: add-instructions ( bb quot -- )
-    [ instructions>> building ] dip '[
-        building get pop
-        _ dip
-        building get push
-    ] with-variable ; inline
-
-: back-edge? ( from to -- ? )
-    [ number>> ] bi@ > ;
-
 TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
 
 : <cfg> ( entry word label -- cfg ) f f cfg boa ;
 
+: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
+
 TUPLE: mr { instructions array } word label ;
 
 : <mr> ( instructions word label -- mr )
diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
index 93adc4c0f9..f585d80d72 100755
--- a/basis/compiler/cfg/optimizer/optimizer-tests.factor
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -1,7 +1,7 @@
 USING: accessors arrays compiler.cfg.checker
 compiler.cfg.debugger compiler.cfg.def-use
 compiler.cfg.instructions fry kernel kernel.private math
-math.private sbufs sequences sequences.private sets
+math.partial-dispatch math.private sbufs sequences sequences.private sets
 slots.private strings tools.test vectors layouts ;
 IN: compiler.cfg.optimizer.tests
 
@@ -31,6 +31,15 @@ IN: compiler.cfg.optimizer.tests
     [ [ 2 fixnum+ ] when 3 ]
     [ [ 2 fixnum- ] when 3 ]
     [ 10000 [ ] times ]
+    [
+        over integer? [
+            over dup 16 <-integer-fixnum
+            [ 0 >=-integer-fixnum ] [ drop f ] if [
+                nip dup
+                [ ] [ ] if
+            ] [ 2drop f ] if
+        ] [ 2drop f ] if
+    ]
 } [
     [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
 ] each
diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor b/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
index 4577e70997..2dd75df693 100644
--- a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
+++ b/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
@@ -35,6 +35,12 @@ test-diamond
 
 [ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
 
-[ T{ ##copy f V int-regs 3 V int-regs 1 } ] [ 2 get instructions>> second ] unit-test
-[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test
+[ T{ ##copy f V int-regs 3 V int-regs 1 } ]
+[ 2 get successors>> first instructions>> first ]
+unit-test
+
+[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
+[ 3 get successors>> first instructions>> first ]
+unit-test
+
 [ 2 ] [ 4 get instructions>> length ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor
index 9c2f0adafd..7e184a9b53 100644
--- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor
+++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel sequences
-compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+USING: accessors assocs fry kernel sequences namespaces
+compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.utilities ;
 IN: compiler.cfg.phi-elimination
 
 : insert-copy ( predecessor input output -- )
@@ -11,7 +12,11 @@ IN: compiler.cfg.phi-elimination
     [ inputs>> ] [ dst>> ] bi '[ _ insert-copy ] assoc-each ;
 
 : eliminate-phi-step ( bb -- )
-    instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ;
+    H{ } clone added-instructions set
+    [ instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ]
+    [ insert-basic-blocks ]
+    bi ;
 
 : eliminate-phis ( cfg -- cfg' )
-    dup [ eliminate-phi-step ] each-basic-block ;
\ No newline at end of file
+    dup [ eliminate-phi-step ] each-basic-block
+    cfg-changed ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
index 14a81958a9..e67f6b5143 100644
--- a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
@@ -2,7 +2,7 @@ IN: compiler.cfg.stack-analysis.merge.tests
 USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
 compiler.cfg.instructions compiler.cfg.stack-analysis.state
 compiler.cfg compiler.cfg.registers compiler.cfg.debugger
-cpu.architecture make assocs
+cpu.architecture make assocs namespaces
 sequences kernel classes ;
 
 [
@@ -11,13 +11,15 @@ sequences kernel classes ;
 ] [
     <state>
 
-    <basic-block> V{ T{ ##branch } } >>instructions
-    <basic-block> V{ T{ ##branch } } >>instructions 2array
+    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
+    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
 
     <state> H{ { D 0 V int-regs 0 } } >>locs>vregs
     <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
 
-    [ merge-locs locs>vregs>> keys ] { } make first inputs>> values
+    H{ } clone added-instructions set
+    V{ } clone added-phis set
+    merge-locs locs>vregs>> keys added-phis get values first
 ] unit-test
 
 [
@@ -26,15 +28,16 @@ sequences kernel classes ;
 ] [
     <state>
 
-    <basic-block> V{ T{ ##branch } } >>instructions
-    <basic-block> V{ T{ ##branch } } >>instructions 2array
+    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
+    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
 
-    [
-        <state>
-        <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+    <state>
+    <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
 
-        [ merge-locs locs>vregs>> keys ] { } make drop
-    ] keep first instructions>> first class
+    H{ } clone added-instructions set
+    V{ } clone added-phis set
+    [ merge-locs locs>vregs>> keys ] { } make drop
+    1 get added-instructions get at first class
 ] unit-test
 
 [
@@ -42,15 +45,17 @@ sequences kernel classes ;
 ] [
     <state>
 
-    <basic-block> V{ T{ ##branch } } >>instructions
-    <basic-block> V{ T{ ##branch } } >>instructions 2array
+    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
+    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
 
-    [
-        <state> -1 >>ds-height
-        <state> 2array
+    H{ } clone added-instructions set
+    V{ } clone added-phis set
 
-        [ merge-ds-heights ds-height>> ] { } make drop
-    ] keep first instructions>> first class
+    <state> -1 >>ds-height
+    <state> 2array
+
+    [ merge-ds-heights ds-height>> ] { } make drop
+    1 get added-instructions get at first class
 ] unit-test
 
 [
@@ -63,6 +68,9 @@ sequences kernel classes ;
     <basic-block> V{ T{ ##branch } } >>instructions
     <basic-block> V{ T{ ##branch } } >>instructions 2array
 
+    H{ } clone added-instructions set
+    V{ } clone added-phis set
+    
     [
         <state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
         <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
@@ -82,6 +90,9 @@ sequences kernel classes ;
     <basic-block> V{ T{ ##branch } } >>instructions
     <basic-block> V{ T{ ##branch } } >>instructions 2array
 
+    H{ } clone added-instructions set
+    V{ } clone added-phis set
+    
     [
         <state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
         <state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor
index b6c443a2d3..cb0ad7d615 100644
--- a/basis/compiler/cfg/stack-analysis/merge/merge.factor
+++ b/basis/compiler/cfg/stack-analysis/merge/merge.factor
@@ -1,12 +1,11 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs sequences accessors fry combinators grouping
-sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.stack-analysis.state ;
+USING: kernel assocs sequences accessors fry combinators grouping sets
+arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.stack-analysis.state
+compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
 IN: compiler.cfg.stack-analysis.merge
 
-! XXX critical edges
-
 : initial-state ( bb states -- state ) 2drop <state> ;
 
 : single-predecessor ( bb states -- state ) nip first clone ;
@@ -27,14 +26,14 @@ IN: compiler.cfg.stack-analysis.merge
     [ nip first >>rs-height ]
     [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
 
-: assoc-map-values ( assoc quot -- assoc' )
+: assoc-map-keys ( assoc quot -- assoc' )
     '[ _ dip ] assoc-map ; inline
 
 : translate-locs ( assoc state -- assoc' )
-    '[ _ translate-loc ] assoc-map-values ;
+    '[ _ translate-loc ] assoc-map-keys ;
 
 : untranslate-locs ( assoc state -- assoc' )
-    '[ _ untranslate-loc ] assoc-map-values ;
+    '[ _ untranslate-loc ] assoc-map-keys ;
 
 : collect-locs ( loc-maps states -- assoc )
     ! assoc maps locs to sequences
@@ -45,12 +44,16 @@ IN: compiler.cfg.stack-analysis.merge
 : insert-peek ( predecessor loc state -- vreg )
     '[ _ _ translate-loc ^^peek ] add-instructions ;
 
+SYMBOL: added-phis
+
+: add-phi-later ( inputs -- vreg )
+    [ int-regs next-vreg dup ] dip 2array added-phis get push ;
+
 : merge-loc ( predecessors vregs loc state -- vreg )
     ! Insert a ##phi in the current block where the input
     ! is the vreg storing loc from each predecessor block
-    [ dup ] 3dip
     '[ [ ] [ _ _ insert-peek ] ?if ] 2map
-    dup all-equal? [ nip first ] [ zip ^^phi ] if ;
+    dup all-equal? [ first ] [ add-phi-later ] if ;
 
 :: merge-locs ( state predecessors states -- state )
     states [ locs>vregs>> ] map states collect-locs
@@ -77,30 +80,35 @@ IN: compiler.cfg.stack-analysis.merge
     over translate-locs
     >>changed-locs ;
 
-ERROR: cannot-merge-poisoned states ;
+:: insert-phis ( bb -- )
+    bb predecessors>> :> predecessors
+    [
+        added-phis get [| dst inputs |
+            dst predecessors inputs zip ##phi
+        ] assoc-each
+    ] V{ } make bb instructions>> over push-all
+    bb (>>instructions) ;
 
-: multiple-predecessors ( bb states -- state )
-    dup [ not ] any? [
-        2drop <state>
+:: multiple-predecessors ( bb states -- state )
+    states [ not ] any? [
+        <state>
     ] [
-        dup [ poisoned?>> ] any? [
-            cannot-merge-poisoned
-        ] [
-            [ state new ] 2dip
-            [ predecessors>> ] dip
-            {
-                [ merge-ds-heights ]
-                [ merge-rs-heights ]
-                [ merge-locs ]
-                [ nip merge-actual-locs ]
-                [ nip merge-changed-locs ]
-            } 2cleave
-        ] if
+        [
+            H{ } clone added-instructions set
+            V{ } clone added-phis set
+            bb predecessors>> :> predecessors
+            state new
+            predecessors states merge-ds-heights
+            predecessors states merge-rs-heights
+            predecessors states merge-locs
+            states merge-actual-locs
+            states merge-changed-locs
+            bb insert-basic-blocks
+            bb insert-phis
+        ] with-scope
     ] if ;
 
 : merge-states ( bb states -- state )
-    ! If any states are poisoned, save all registers
-    ! to the stack in each branch
     dup length {
         { 0 [ initial-state ] }
         { 1 [ single-predecessor ] }
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index cbc939b1f2..23b1098cd6 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -99,7 +99,7 @@ IN: compiler.cfg.stack-analysis.tests
 ! Correct height tracking
 [ t ] [
     [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
-    reverse-post-order 3 swap nth
+    reverse-post-order 4 swap nth
     instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
     2array { D 1 D 0 } set=
 ] unit-test
@@ -126,7 +126,7 @@ IN: compiler.cfg.stack-analysis.tests
     stack-analysis
     drop
 
-    3 get instructions>> second loc>>
+    3 get successors>> first instructions>> first loc>>
 ] unit-test
 
 ! Do inserted ##peeks reference the correct stack location if
@@ -156,7 +156,7 @@ IN: compiler.cfg.stack-analysis.tests
     stack-analysis
     drop
 
-    3 get instructions>> [ ##peek? ] find nip loc>>
+    3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
 ] unit-test
 
 ! Missing ##replace
@@ -170,9 +170,9 @@ IN: compiler.cfg.stack-analysis.tests
 ! Inserted ##peeks reference the wrong stack location
 [ t ] [
     [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
-    eliminate-dead-code reverse-post-order 3 swap nth
+    eliminate-dead-code reverse-post-order 4 swap nth
     instructions>> [ ##peek? ] filter [ loc>> ] map
-    { R 0 D 0 D 1 } set=
+    { D 0 D 1 } set=
 ] unit-test
 
 [ D 0 ] [
@@ -200,5 +200,5 @@ IN: compiler.cfg.stack-analysis.tests
     stack-analysis
     drop
 
-    3 get instructions>> [ ##peek? ] find nip loc>>
+    3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
 ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index ab16bbea44..48a4b79783 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs kernel namespaces math sequences fry grouping
-sets make combinators
+sets make combinators dlists deques
 compiler.cfg
 compiler.cfg.copy-prop
 compiler.cfg.def-use
@@ -10,9 +10,14 @@ compiler.cfg.registers
 compiler.cfg.rpo
 compiler.cfg.hats
 compiler.cfg.stack-analysis.state
-compiler.cfg.stack-analysis.merge ;
+compiler.cfg.stack-analysis.merge
+compiler.cfg.utilities ;
 IN: compiler.cfg.stack-analysis
 
+SYMBOL: work-list
+
+: add-to-work-list ( bb -- ) work-list get push-front ;
+
 : redundant-replace? ( vreg loc -- ? )
     dup state get untranslate-loc n>> 0 <
     [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
@@ -137,10 +142,21 @@ SYMBOLS: state-in state-out ;
         ] 2bi
     ] V{ } make >>instructions drop ;
 
+: visit-successors ( bb -- )
+    dup successors>> [
+        2dup back-edge? [ 2drop ] [ nip add-to-work-list ] if
+    ] with each ;
+
+: process-work-list ( -- )
+    work-list get [ visit-block ] slurp-deque ;
+
 : stack-analysis ( cfg -- cfg' )
     [
+        <hashed-dlist> work-list set
         H{ } clone copies set
         H{ } clone state-in set
         H{ } clone state-out set
-        dup [ visit-block ] each-basic-block
+        dup [ add-to-work-list ] each-basic-block
+        process-work-list
+        cfg-changed
     ] with-scope ;
diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor
index df5d962999..5fa2e1b042 100644
--- a/basis/compiler/cfg/tco/tco.factor
+++ b/basis/compiler/cfg/tco/tco.factor
@@ -5,7 +5,8 @@ namespaces sequences fry combinators
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.hats
-compiler.cfg.instructions ;
+compiler.cfg.instructions
+compiler.cfg.utilities ;
 IN: compiler.cfg.tco
 
 ! Tail call optimization. You must run compute-predecessors after this
@@ -82,4 +83,4 @@ M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn
 : optimize-tail-calls ( cfg -- cfg' )
     dup cfg set
     dup [ optimize-tail-call ] each-basic-block
-    f >>post-order ;
\ No newline at end of file
+    cfg-changed ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
index 6f4a6eea55..cc98d08042 100644
--- a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
+++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences math combinators combinators.short-circuit
-classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.utilities ;
 IN: compiler.cfg.useless-conditionals
 
 : delete-conditional? ( bb -- ? )
@@ -18,4 +19,4 @@ IN: compiler.cfg.useless-conditionals
     dup [
         dup delete-conditional? [ delete-conditional ] [ drop ] if
     ] each-basic-block
-    f >>post-order ;
+    cfg-changed ;
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index 99a138a763..0e08607331 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math layouts make sequences combinators
-cpu.architecture namespaces compiler.cfg
-compiler.cfg.instructions ;
+USING: accessors assocs combinators combinators.short-circuit
+compiler.cfg compiler.cfg.instructions cpu.architecture kernel
+layouts locals make math namespaces sequences sets vectors ;
 IN: compiler.cfg.utilities
 
 : value-info-small-fixnum? ( value-info -- ? )
@@ -33,7 +33,53 @@ IN: compiler.cfg.utilities
     building off
     basic-block off ;
 
-: stop-iterating ( -- next ) end-basic-block f ;
-
 : emit-primitive ( node -- )
     word>> ##call ##branch begin-basic-block ;
+
+: back-edge? ( from to -- ? )
+    [ number>> ] bi@ >= ;
+
+: empty-block? ( bb -- ? )
+    instructions>> {
+        [ length 1 = ]
+        [ first ##branch? ]
+    } 1&& ;
+
+SYMBOL: visited
+
+: (skip-empty-blocks) ( bb -- bb' )
+    dup visited get key? [
+        dup empty-block? [
+            dup visited get conjoin
+            successors>> first (skip-empty-blocks)
+        ] when
+    ] unless ;
+
+: skip-empty-blocks ( bb -- bb' )
+    H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
+
+! assoc mapping predecessors to sequences
+SYMBOL: added-instructions
+
+: add-instructions ( predecessor quot -- )
+    [
+        added-instructions get
+        [ drop V{ } clone ] cache
+        building
+    ] dip with-variable ; inline
+
+:: insert-basic-block ( from to bb -- )
+    bb from 1vector >>predecessors drop
+    bb to 1vector >>successors drop
+    to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
+    from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
+
+:: insert-basic-blocks ( bb -- )
+    added-instructions get
+    [| predecessor instructions |
+        \ ##branch new-insn instructions push
+        predecessor bb
+        <basic-block> instructions >>instructions
+        insert-basic-block
+    ] assoc-each ;
+

From 8ff473e42cdc6b1965703938e21be27ecd51abce Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 12 Jul 2009 23:00:33 -0500
Subject: [PATCH 07/31] compiler.cfg.linear-scan.resolve: get it to work on
 CFGs with critical edges

---
 .../cfg/linear-scan/linear-scan-tests.factor  |  9 +++--
 .../cfg/linear-scan/linear-scan.factor        |  1 +
 .../linear-scan/resolve/resolve-tests.factor  |  7 ----
 .../cfg/linear-scan/resolve/resolve.factor    | 39 +++----------------
 basis/compiler/cfg/utilities/utilities.factor | 18 ++++-----
 5 files changed, 21 insertions(+), 53 deletions(-)
 delete mode 100644 basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor

diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index e8b4b67cf0..20f8570f84 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -1509,6 +1509,7 @@ SYMBOL: linear-scan-result
         compute-liveness
         dup reverse-post-order
         { { int-regs regs } } (linear-scan)
+        cfg-changed
         flatten-cfg 1array mr.
     ] with-scope ;
 
@@ -1803,7 +1804,7 @@ test-diamond
 
 [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
 
-[ _spill ] [ 2 get instructions>> first class ] unit-test
+[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test
 
 [ _spill ] [ 3 get instructions>> second class ] unit-test
 
@@ -1859,7 +1860,7 @@ V{
 
 [ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
 
-[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test
+[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test
 
 [ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
 
@@ -1926,7 +1927,7 @@ V{
 [ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
 
 ! Resolve pass should insert this
-[ _reload ] [ 5 get instructions>> first class ] unit-test
+[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
 
 ! Some random bug
 V{
@@ -2484,7 +2485,7 @@ test-diamond
 
 [ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
 
-[ 1 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
+[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test
 
 [ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
 
diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index 77d66c274d..c17aa23e83 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -40,4 +40,5 @@ IN: compiler.cfg.linear-scan
         init-mapping
         dup reverse-post-order machine-registers (linear-scan)
         spill-counts get >>spill-counts
+        cfg-changed
     ] with-scope ;
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
deleted file mode 100644
index b5e95258bf..0000000000
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ /dev/null
@@ -1,7 +0,0 @@
-USING: arrays compiler.cfg.linear-scan.resolve kernel
-tools.test ;
-IN: compiler.cfg.linear-scan.resolve.tests
-
-[ { 1 2 3 4 5 6 } ] [
-    { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
-] unit-test
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index 7b7f242e4e..f7ed994f18 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -3,6 +3,7 @@
 USING: accessors arrays assocs combinators
 combinators.short-circuit fry kernel locals
 make math sequences
+compiler.cfg.utilities
 compiler.cfg.instructions
 compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
@@ -30,42 +31,14 @@ IN: compiler.cfg.linear-scan.resolve
         [ resolve-value-data-flow ] with with each
     ] { } make ;
 
-: fork? ( from to -- ? )
-    {
-        [ 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 -- ? )
-    {
-        [ drop successors>> length 1 = ]
-        [ nip predecessors>> length 1 >= ]
-    } 2&& ; inline
-
-: insert-position/join ( from to -- before after )
-    drop instructions>> dup pop 1array ;
-
-: insert-position ( bb to -- before after )
-    {
-        { [ 2dup fork? ] [ insert-position/fork ] }
-        { [ 2dup join? ] [ insert-position/join ] }
-    } cond ;
-
-: 3append-here ( seq2 seq1 seq3 -- )
-    #! Mutate seq1
-    swap '[ _ push-all ] bi@ ;
-
-: perform-mappings ( mappings bb to -- )
-    pick empty? [ 3drop ] [
-        [ mapping-instructions ] 2dip
-        insert-position 3append-here
+: perform-mappings ( bb to mappings -- )
+    dup empty? [ 3drop ] [
+        mapping-instructions <simple-block>
+        insert-basic-block
     ] if ;
 
 : resolve-edge-data-flow ( bb to -- )
-    [ compute-mappings ] [ perform-mappings ] 2bi ;
+    2dup compute-mappings perform-mappings ;
 
 : resolve-block-data-flow ( bb -- )
     dup successors>> [ resolve-edge-data-flow ] with each ;
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index 0e08607331..288fa403dd 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators combinators.short-circuit
 compiler.cfg compiler.cfg.instructions cpu.architecture kernel
-layouts locals make math namespaces sequences sets vectors ;
+layouts locals make math namespaces sequences sets vectors fry ;
 IN: compiler.cfg.utilities
 
 : value-info-small-fixnum? ( value-info -- ? )
@@ -74,12 +74,12 @@ SYMBOL: added-instructions
     to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
     from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
 
-:: insert-basic-blocks ( bb -- )
-    added-instructions get
-    [| predecessor instructions |
-        \ ##branch new-insn instructions push
-        predecessor bb
-        <basic-block> instructions >>instructions
-        insert-basic-block
-    ] assoc-each ;
+: <simple-block> ( insns -- bb )
+    <basic-block>
+    swap >vector
+    \ ##branch new-insn over push
+    >>instructions ;
 
+: insert-basic-blocks ( bb -- )
+    [ added-instructions get ] dip
+    '[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;

From d7aeae45be8984bd2dc0c198758d3c9713c98dda Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 13 Jul 2009 10:44:08 -0500
Subject: [PATCH 08/31] compiler.cfg.branch-splitting: split blocks with
 successors

---
 .../branch-splitting-tests.factor             | 85 +++++++++++++++++++
 .../branch-splitting/branch-splitting.factor  | 82 +++++++++++++-----
 .../cfg/optimizer/optimizer-tests.factor      |  6 +-
 basis/compiler/cfg/optimizer/optimizer.factor |  3 +-
 basis/compiler/cfg/renaming/renaming.factor   |  6 ++
 .../stack-analysis/merge/merge-tests.factor   |  6 +-
 6 files changed, 162 insertions(+), 26 deletions(-)
 create mode 100644 basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor

diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor b/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor
new file mode 100644
index 0000000000..fbaaf92203
--- /dev/null
+++ b/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor
@@ -0,0 +1,85 @@
+USING: accessors assocs compiler.cfg
+compiler.cfg.branch-splitting compiler.cfg.debugger
+compiler.cfg.predecessors compiler.cfg.rpo fry kernel
+tools.test namespaces sequences vectors ;
+IN: compiler.cfg.branch-splitting.tests
+
+: get-predecessors ( cfg -- assoc )
+    H{ } clone [ '[ [ predecessors>> ] keep _ set-at ] each-basic-block ] keep ;
+
+: check-predecessors ( cfg -- )
+    [ get-predecessors ]
+    [ compute-predecessors drop ]
+    [ get-predecessors ] tri assert= ;
+
+: check-branch-splitting ( cfg -- )
+    compute-predecessors
+    split-branches
+    check-predecessors ;
+
+: test-branch-splitting ( -- )
+    cfg new 0 get >>entry check-branch-splitting ;
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+V{ } 3 test-bb
+
+V{ } 4 test-bb
+
+test-diamond
+
+[ ] [ test-branch-splitting ] unit-test
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+V{ } 3 test-bb
+
+V{ } 4 test-bb
+
+V{ } 5 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+1 get 3 get 4 get V{ } 2sequence >>successors drop
+
+2 get 3 get 4 get V{ } 2sequence >>successors drop
+
+[ ] [ test-branch-splitting ] unit-test
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+V{ } 3 test-bb
+
+V{ } 4 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+1 get 3 get 4 get V{ } 2sequence >>successors drop
+
+2 get 4 get 1vector >>successors drop
+
+[ ] [ test-branch-splitting ] unit-test
+
+V{ } 0 test-bb
+
+V{ } 1 test-bb
+
+V{ } 2 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+1 get 2 get 1vector >>successors drop
+
+[ ] [ test-branch-splitting ] unit-test
\ 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
index f7e9ea9cbf..0dd963125f 100644
--- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor
+++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
@@ -1,37 +1,79 @@
 ! Copyright (C) 2009 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit kernel math sequences
-compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ;
+USING: accessors combinators.short-circuit kernel math math.order
+sequences assocs namespaces vectors fry arrays splitting
+compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
+compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.branch-splitting
 
-! Predecessors must be recomputed after this
+: clone-renamings ( insns -- assoc )
+    [ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
 
-: split-branch-for ( bb predecessor -- )
-    [
+: clone-instructions ( insns -- insns' )
+    dup clone-renamings renamings [
         [
-            <basic-block>
-                swap
-                [ instructions>> [ clone ] map >>instructions ]
-                [ successors>> clone >>successors ]
-                bi
-        ] keep
-    ] dip
-    [ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors
-    drop ;
+            clone
+            dup rename-insn-defs
+            dup rename-insn-uses
+            dup fresh-insn-temps
+        ] map
+    ] with-variable ;
+
+: clone-basic-block ( bb -- bb' )
+    ! The new block gets the same RPO number as the old one.
+    ! This is just to make 'back-edge?' work.
+    <basic-block>
+        swap
+        [ instructions>> clone-instructions >>instructions ]
+        [ successors>> clone >>successors ]
+        [ number>> >>number ]
+        tri ;
+
+: new-blocks ( bb -- copies )
+    dup predecessors>> [
+        [ clone-basic-block ] dip
+        1vector >>predecessors
+    ] with map ;
+
+: update-predecessor-successor ( pred copy old-bb -- )
+    '[
+        [ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
+    ] change-successors drop ;
+
+: update-predecessor-successors ( copies old-bb -- )
+    [ predecessors>> swap ] keep
+    '[ _ update-predecessor-successor ] 2each ;
+
+: update-successor-predecessor ( copies old-bb succ -- )
+    [
+        swap 1array split swap join V{ } like
+    ] change-predecessors drop ;
+
+: update-successor-predecessors ( copies old-bb -- )
+    dup successors>> [
+        update-successor-predecessor
+    ] with with each ;
 
 : split-branch ( bb -- )
-    dup predecessors>> [ split-branch-for ] with each ;
+    [ new-blocks ] keep
+    [ update-predecessor-successors ]
+    [ update-successor-predecessors ]
+    2bi ;
+
+UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
+
+: split-instructions? ( insns -- ? )
+    [ irrelevant? not ] count 5 <= ;
 
 : split-branches? ( bb -- ? )
     {
-        [ successors>> empty? ]
-        [ predecessors>> length 1 > ]
-        [ instructions>> [ defs-vregs ] any? not ]
-        [ instructions>> [ temp-vregs ] any? not ]
+        [ dup successors>> [ back-edge? ] with any? not ]
+        [ predecessors>> length 1 4 between? ]
+        [ instructions>> split-instructions? ]
     } 1&& ;
 
 : split-branches ( cfg -- cfg' )
     dup [
         dup split-branches? [ split-branch ] [ drop ] if
     ] each-basic-block
-    f >>post-order ;
+    cfg-changed ;
diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
index f585d80d72..1eb1996da4 100755
--- a/basis/compiler/cfg/optimizer/optimizer-tests.factor
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -2,7 +2,7 @@ USING: accessors arrays compiler.cfg.checker
 compiler.cfg.debugger compiler.cfg.def-use
 compiler.cfg.instructions fry kernel kernel.private math
 math.partial-dispatch math.private sbufs sequences sequences.private sets
-slots.private strings tools.test vectors layouts ;
+slots.private strings strings.private tools.test vectors layouts ;
 IN: compiler.cfg.optimizer.tests
 
 ! Miscellaneous tests
@@ -40,6 +40,10 @@ IN: compiler.cfg.optimizer.tests
             ] [ 2drop f ] if
         ] [ 2drop f ] if
     ]
+    [
+        pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
+        set-string-nth-fast
+    ]
 } [
     [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
 ] each
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 84eb8a84d1..5b0892a0ee 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -29,10 +29,9 @@ SYMBOL: check-optimizer?
     ! The passes that need this document it.
     [
         optimize-tail-calls
-        compute-predecessors
         delete-useless-conditionals
-        split-branches
         compute-predecessors
+        split-branches
         stack-analysis
         compute-liveness
         alias-analysis
diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor
index 4a8c6e6a4d..228d72483c 100644
--- a/basis/compiler/cfg/renaming/renaming.factor
+++ b/basis/compiler/cfg/renaming/renaming.factor
@@ -55,6 +55,12 @@ M: ##string-nth rename-insn-uses
     [ rename-value ] change-index
     drop ;
 
+M: ##set-string-nth-fast rename-insn-uses
+    dup call-next-method
+    [ rename-value ] change-obj
+    [ rename-value ] change-index
+    drop ;
+
 M: ##set-slot-imm rename-insn-uses
     dup call-next-method
     [ rename-value ] change-obj
diff --git a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
index e67f6b5143..5883777861 100644
--- a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
@@ -1,8 +1,8 @@
 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 namespaces
+ compiler.cfg.instructions compiler.cfg.stack-analysis.state
+compiler.cfg.utilities compiler.cfg compiler.cfg.registers
+compiler.cfg.debugger cpu.architecture make assocs namespaces
 sequences kernel classes ;
 
 [

From 3b244d5d4149a88516482aa2f6a784468259e655 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 13 Jul 2009 12:33:58 -0500
Subject: [PATCH 09/31] compiler.cfg.value-numbering: fix ##compare and
 ##compare-branch rewrites

---
 .../value-numbering/rewrite/rewrite.factor    | 39 ++++++++++---------
 core/sequences/sequences-tests.factor         |  5 ++-
 2 files changed, 25 insertions(+), 19 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index ca7a959a82..92965e40c5 100755
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -77,13 +77,19 @@ M: ##compare-imm-branch rewrite
     insn cc>> swap? [ swap-cc ] when
     i \ ##compare-imm new-insn ; inline
 
-! M: ##compare rewrite
-!     dup [ src1>> ] [ src2>> ] bi
-!     [ vreg>expr constant-expr? ] bi@ 2array {
-!         { { f t } [ f >compare-imm ] }
-!         { { t f } [ t >compare-imm ] }
-!         [ drop ]
-!     } case ;
+: vreg-small-constant? ( vreg -- ? )
+    vreg>expr {
+        [ constant-expr? ]
+        [ value>> small-enough? ]
+    } 1&& ;
+
+M: ##compare rewrite
+    dup [ src1>> ] [ src2>> ] bi
+    [ vreg-small-constant? ] bi@ 2array {
+        { { f t } [ f >compare-imm ] }
+        { { t f } [ t >compare-imm ] }
+        [ drop ]
+    } case ;
 
 :: >compare-imm-branch ( insn swap? -- insn' )
     insn src1>>
@@ -91,13 +97,13 @@ M: ##compare-imm-branch rewrite
     insn cc>> swap? [ swap-cc ] when
     \ ##compare-imm-branch new-insn ; inline
 
-! M: ##compare-branch rewrite
-!     dup [ src1>> ] [ src2>> ] bi
-!     [ vreg>expr constant-expr? ] bi@ 2array {
-!         { { f t } [ f >compare-imm-branch ] }
-!         { { t f } [ t >compare-imm-branch ] }
-!         [ drop ]
-!     } case ;
+M: ##compare-branch rewrite
+    dup [ src1>> ] [ src2>> ] bi
+    [ vreg-small-constant? ] bi@ 2array {
+        { { f t } [ f >compare-imm-branch ] }
+        { { t f } [ t >compare-imm-branch ] }
+        [ drop ]
+    } case ;
 
 : rewrite-redundant-comparison? ( insn -- ? )
     {
@@ -198,10 +204,7 @@ M: ##or-imm rewrite [ bitor ] \ ##or-imm combine-imm ;
 M: ##xor-imm rewrite [ bitxor ] \ ##xor-imm combine-imm ;
 
 : rewrite-add? ( insn -- ? )
-    src2>> {
-        [ vreg>expr constant-expr? ]
-        [ vreg>constant small-enough? ]
-    } 1&& ;
+    src2>> vreg-small-constant? ;
 
 M: ##add rewrite
     dup rewrite-add? [
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index 5e0d5597ca..2aa95b23ab 100644
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -290,4 +290,7 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ;
 USE: make
 
 [ { "a" 1 "b" 1 "c" } ]
-[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
\ No newline at end of file
+[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
+
+[ t ] [ 0 array-capacity? ] unit-test
+[ f ] [ -1 array-capacity? ] unit-test
\ No newline at end of file

From 768e2a51486d32c5d866b174adfeae088721f1e6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 13 Jul 2009 14:42:52 -0500
Subject: [PATCH 10/31] compiler.cfg: split off condition codes into a
 comparisons sub-vocabulary

---
 .../cfg/branch-folding/branch-folding.factor  |  5 ++-
 basis/compiler/cfg/builder/builder.factor     |  1 +
 .../cfg/comparisons/comparisons.factor        | 36 ++++++++++++++++++
 .../cfg/instructions/instructions.factor      | 38 -------------------
 .../cfg/intrinsics/fixnum/fixnum.factor       |  3 +-
 .../compiler/cfg/intrinsics/intrinsics.factor |  3 +-
 .../cfg/linearization/linearization.factor    |  1 +
 .../value-numbering/rewrite/rewrite.factor    |  5 ++-
 basis/cpu/x86/x86.factor                      | 11 ++++--
 9 files changed, 58 insertions(+), 45 deletions(-)
 create mode 100644 basis/compiler/cfg/comparisons/comparisons.factor

diff --git a/basis/compiler/cfg/branch-folding/branch-folding.factor b/basis/compiler/cfg/branch-folding/branch-folding.factor
index 2432849a9a..04842552b7 100644
--- a/basis/compiler/cfg/branch-folding/branch-folding.factor
+++ b/basis/compiler/cfg/branch-folding/branch-folding.factor
@@ -1,7 +1,10 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators.short-circuit kernel sequences vectors
-compiler.cfg.instructions compiler.cfg.rpo compiler.cfg ;
+compiler.cfg.instructions
+compiler.cfg.comparisons
+compiler.cfg.rpo
+compiler.cfg ;
 IN: compiler.cfg.branch-folding
 
 ! Fold comparisons where both inputs are the same. Predecessors must be
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 8cf141f3f4..991fd2e20d 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -14,6 +14,7 @@ compiler.cfg.stacks
 compiler.cfg.utilities
 compiler.cfg.registers
 compiler.cfg.intrinsics
+compiler.cfg.comparisons
 compiler.cfg.stack-frame
 compiler.cfg.instructions
 compiler.alien ;
diff --git a/basis/compiler/cfg/comparisons/comparisons.factor b/basis/compiler/cfg/comparisons/comparisons.factor
new file mode 100644
index 0000000000..576d541230
--- /dev/null
+++ b/basis/compiler/cfg/comparisons/comparisons.factor
@@ -0,0 +1,36 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs math.order sequences ;
+IN: compiler.cfg.comparisons
+
+SYMBOLS: cc< cc<= cc= cc> cc>= cc/= ;
+
+: negate-cc ( cc -- cc' )
+    H{
+        { cc< cc>= }
+        { cc<= cc> }
+        { cc> cc<= }
+        { cc>= cc< }
+        { cc= cc/= }
+        { cc/= cc= }
+    } at ;
+
+: swap-cc ( cc -- cc' )
+    H{
+        { cc< cc> }
+        { cc<= cc>= }
+        { cc> cc< }
+        { cc>= cc<= }
+        { cc= cc= }
+        { cc/= cc/= }
+    } at ;
+
+: evaluate-cc ( result cc -- ? )
+    H{
+        { cc<  { +lt+           } }
+        { cc<= { +lt+ +eq+      } }
+        { cc=  {      +eq+      } }
+        { cc>= {      +eq+ +gt+ } }
+        { cc>  {           +gt+ } }
+        { cc/= { +lt+      +gt+ } }
+    } at memq? ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index abbb86cb16..910cb1992b 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -181,44 +181,6 @@ INSN: ##loop-entry ;
 
 INSN: ##phi < ##pure inputs ;
 
-! Condition codes
-SYMBOL: cc<
-SYMBOL: cc<=
-SYMBOL: cc=
-SYMBOL: cc>
-SYMBOL: cc>=
-SYMBOL: cc/=
-
-: negate-cc ( cc -- cc' )
-    H{
-        { cc< cc>= }
-        { cc<= cc> }
-        { cc> cc<= }
-        { cc>= cc< }
-        { cc= cc/= }
-        { cc/= cc= }
-    } at ;
-
-: swap-cc ( cc -- cc' )
-    H{
-        { cc< cc> }
-        { cc<= cc>= }
-        { cc> cc< }
-        { cc>= cc<= }
-        { cc= cc= }
-        { cc/= cc/= }
-    } at ;
-
-: evaluate-cc ( result cc -- ? )
-    H{
-        { cc<  { +lt+           } }
-        { cc<= { +lt+ +eq+      } }
-        { cc=  {      +eq+      } }
-        { cc>= {      +eq+ +gt+ } }
-        { cc>  {           +gt+ } }
-        { cc/= { +lt+      +gt+ } }
-    } at memq? ;
-
 TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
 
 INSN: ##compare-branch < ##conditional-branch ;
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index 9efac9e81a..b360eed80b 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -7,7 +7,8 @@ compiler.cfg.hats
 compiler.cfg.stacks
 compiler.cfg.instructions
 compiler.cfg.utilities
-compiler.cfg.registers ;
+compiler.cfg.registers
+compiler.cfg.comparisons ;
 IN: compiler.cfg.intrinsics.fixnum
 
 : emit-both-fixnums? ( -- )
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index df01bba89b..5283581bdd 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -8,7 +8,8 @@ compiler.cfg.intrinsics.allot
 compiler.cfg.intrinsics.fixnum
 compiler.cfg.intrinsics.float
 compiler.cfg.intrinsics.slots
-compiler.cfg.intrinsics.misc ;
+compiler.cfg.intrinsics.misc
+compiler.cfg.comparisons ;
 QUALIFIED: kernel
 QUALIFIED: arrays
 QUALIFIED: byte-arrays
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 15e7cef553..a75ac064d9 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -5,6 +5,7 @@ combinators assocs arrays locals cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.liveness
+compiler.cfg.comparisons
 compiler.cfg.stack-frame
 compiler.cfg.instructions ;
 IN: compiler.cfg.linearization
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 92965e40c5..0dea35409d 100755
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -2,7 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors locals combinators combinators.short-circuit arrays
 fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise compiler.cfg.hats compiler.cfg.instructions
+math.bitwise
+compiler.cfg.hats
+compiler.cfg.comparisons
+compiler.cfg.instructions
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.simplify ;
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 15c54aa7d8..bb2ee620e3 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -4,9 +4,14 @@ USING: accessors assocs alien alien.c-types arrays strings
 cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
 kernel kernel.private math memory namespaces make sequences
 words system layouts combinators math.order fry locals
-compiler.constants compiler.cfg.registers
-compiler.cfg.instructions compiler.cfg.intrinsics
-compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
+compiler.constants
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.intrinsics
+compiler.cfg.comparisons
+compiler.cfg.stack-frame
+compiler.codegen
+compiler.codegen.fixup ;
 IN: cpu.x86
 
 << enable-fixnum-log2 >>

From ccae9b59a4e69b17b2a011313a5050d524920d8e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 13 Jul 2009 19:02:05 -0500
Subject: [PATCH 11/31] clean up value numbering conversion of ##add/sub to
 ##add/sub-imm

---
 .../value-numbering/rewrite/rewrite.factor    | 28 ++++++++++++-------
 1 file changed, 18 insertions(+), 10 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 92965e40c5..988df366eb 100755
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -49,9 +49,12 @@ M: insn rewrite ;
         [ src2>> tag-mask get bitand 0 = ]
     } 1&& ; inline
 
+: tagged>constant ( n -- n' )
+    tag-bits get neg shift ; inline
+
 : (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
     [ src1>> vreg>expr in1>> vn>vreg ]
-    [ src2>> tag-bits get neg shift ]
+    [ src2>> tagged>constant ]
     [ cc>> ]
     tri ; inline
 
@@ -203,15 +206,20 @@ M: ##or-imm rewrite [ bitor ] \ ##or-imm combine-imm ;
 
 M: ##xor-imm rewrite [ bitxor ] \ ##xor-imm combine-imm ;
 
-: rewrite-add? ( insn -- ? )
-    src2>> vreg-small-constant? ;
-
-M: ##add rewrite
-    dup rewrite-add? [
+: new-arithmetic ( obj op -- )
+    [
         [ dst>> ]
         [ src1>> ]
-        [ src2>> vreg>constant ] tri \ ##add-imm new-insn
-        dup number-values
-    ] when ;
+        [ src2>> vreg>constant ] tri
+    ] dip new-insn dup number-values ; inline
 
-M: ##sub rewrite constant-fold ;
+: rewrite-arithmetic ( insn op -- ? )
+    over src2>> vreg-small-constant? [
+        new-arithmetic constant-fold
+    ] [
+        drop
+    ] if ; inline
+
+M: ##add rewrite \ ##add-imm rewrite-arithmetic ;
+
+M: ##sub rewrite \ ##sub-imm rewrite-arithmetic ;

From a06948298bf705649c04bc77d141a14687683522 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 13 Jul 2009 22:35:36 -0500
Subject: [PATCH 12/31] ensure resize-world never happens before begin-world

---
 basis/ui/gadgets/worlds/worlds.factor | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index ed21c85b19..0c59af95d6 100755
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -163,9 +163,11 @@ M: world resize-world
 M: world (>>dim)
     [ call-next-method ]
     [
-        dup handle>>
-        [ [ set-gl-context ] [ resize-world ] bi ]
-        [ drop ] if
+        dup active?>> [
+            dup handle>>
+            [ [ set-gl-context ] [ resize-world ] bi ]
+            [ drop ] if
+        ] [ drop ] if
     ] bi ;
 
 GENERIC: draw-world* ( world -- )

From 05343e88ba9af38b7a86815a6f59cc173323c4f6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 13 Jul 2009 22:59:51 -0500
Subject: [PATCH 13/31] bson: fix broken unit test

---
 extra/bson/bson-tests.factor | 8 ++------
 1 file changed, 2 insertions(+), 6 deletions(-)

diff --git a/extra/bson/bson-tests.factor b/extra/bson/bson-tests.factor
index e66b9c6ec2..9db3451f26 100644
--- a/extra/bson/bson-tests.factor
+++ b/extra/bson/bson-tests.factor
@@ -6,9 +6,6 @@ IN: bson.tests
 : turnaround ( value -- value )
     assoc>bv >byte-array binary [ H{ } stream>assoc ] with-byte-reader ;
 
-M: timestamp equal? ( obj1 obj2 -- ? )
-    [ timestamp>millis ] bi@ = ;
-
 [ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
 
 [ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } ]
@@ -23,10 +20,9 @@ M: timestamp equal? ( obj1 obj2 -- ? )
 [ H{ { "a date" T{ timestamp { year 2009 }
                    { month 7 }
                    { day 11 }
-                   { hour 11 }
+                   { hour 9 }
                    { minute 8 }
-                   { second 40+15437/200000 }
-                   { gmt-offset T{ duration { hour 2 } } } } } }
+                   { second 40+77/1000 } } } }
 ]
 [ H{ { "a date" T{ timestamp { year 2009 }
                    { month 7 }

From afdd53768194272b267591e5a3a2d97075d1bd34 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 13 Jul 2009 23:35:21 -0500
Subject: [PATCH 14/31] tools.annotations: add (annotate) word which doesn't
 create a compilation unit for use in loops

---
 basis/tools/annotations/annotations.factor | 23 +++++++++++-----------
 1 file changed, 12 insertions(+), 11 deletions(-)

diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
index e7e5837ee8..f02476d4da 100644
--- a/basis/tools/annotations/annotations.factor
+++ b/basis/tools/annotations/annotations.factor
@@ -31,19 +31,20 @@ M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;
         cannot-annotate-twice
     ] when ;
 
+GENERIC# (annotate) 1 ( word quot -- )
+
+M: generic (annotate)
+    [ "methods" word-prop values ] dip '[ _ (annotate) ] each ;
+
+M: word (annotate)
+    [ check-annotate-twice ] dip
+    [ dup def>> 2dup "unannotated-def" set-word-prop ] dip
+    call( old -- new ) define ;
+
 PRIVATE>
 
-GENERIC# annotate 1 ( word quot -- )
-
-M: generic annotate
-    [ "methods" word-prop values ] dip '[ _ annotate ] each ;
-
-M: word annotate
-    [ check-annotate-twice ] dip
-    [
-        [ dup def>> 2dup "unannotated-def" set-word-prop ] dip
-        call( old -- new ) define
-    ] with-compilation-unit ;
+: annotate ( word quot -- )
+    [ (annotate) ] with-compilation-unit ;
 
 <PRIVATE
 

From 47500fad061c35a2666a8e8a793c24aed6f3ed6b Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Tue, 14 Jul 2009 01:12:45 -0500
Subject: [PATCH 15/31] call( and execute( inline known quotations/words in the
 propagation pass

---
 .../tree/propagation/call-effect/authors.txt  |  2 +
 .../call-effect/call-effect-tests.factor      | 51 +++++++++++
 .../call-effect/call-effect.factor            | 85 ++++++++++++++++---
 .../known-words/known-words.factor            |  3 +-
 basis/stack-checker/call-effect/authors.txt   |  1 -
 .../call-effect/call-effect-tests.factor      | 16 ----
 .../known-words/known-words.factor            | 10 +++
 basis/stack-checker/stack-checker.factor      |  2 -
 8 files changed, 138 insertions(+), 32 deletions(-)
 create mode 100644 basis/compiler/tree/propagation/call-effect/authors.txt
 create mode 100644 basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
 rename basis/{stack-checker => compiler/tree/propagation}/call-effect/call-effect.factor (59%)
 delete mode 100644 basis/stack-checker/call-effect/authors.txt
 delete mode 100644 basis/stack-checker/call-effect/call-effect-tests.factor

diff --git a/basis/compiler/tree/propagation/call-effect/authors.txt b/basis/compiler/tree/propagation/call-effect/authors.txt
new file mode 100644
index 0000000000..a44f8d7f8d
--- /dev/null
+++ b/basis/compiler/tree/propagation/call-effect/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+Daniel Ehrenberg
diff --git a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
new file mode 100644
index 0000000000..5964bcee35
--- /dev/null
+++ b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
@@ -0,0 +1,51 @@
+! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel
+compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ;
+IN: compiler.tree.propagation.call-effect.tests
+
+[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
+[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
+[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
+[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
+
+[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test
+[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test
+[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test
+[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test
+[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test
+[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test
+[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test
+[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test
+
+: optimized-quot ( quot -- quot' )
+    build-tree optimize-tree nodes>quot ;
+
+: compiled-call2 ( a quot: ( a -- b ) -- b )
+    call( a -- b ) ;
+
+: compiled-execute2 ( a b word: ( a b -- c ) -- c )
+    execute( a b -- c ) ;
+
+[ [ 3 ] ] [ [ 1 2 \ + execute( a b -- c ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 [ + ] call( a b -- c ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 '[ _ + ] call( a -- b ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] optimized-quot ] unit-test
+
+[ 1 2 { [ + ] } first compiled-call2 ] must-fail
+[ 3 ] [ 1 2 { + } first compiled-execute2 ] unit-test
+[ 3 ] [ 1 2 '[ _ + ] compiled-call2 ] unit-test
+[ 3 ] [ 1 2 '[ _ ] [ + ] compose compiled-call2 ] unit-test
+[ 3 ] [ 1 2 \ + compiled-execute2 ] unit-test
+
+[ 3 ] [ 1 2 { [ + ] } first call( a b -- c ) ] unit-test
+[ 3 ] [ 1 2 { + } first execute( a b -- c ) ] unit-test
+[ 3 ] [ 1 2 '[ _ + ] call( a -- b ) ] unit-test
+[ 3 ] [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] unit-test
+
+[ t ] [ [ 2 '[ _ ] [ + ] compose ] final-info first infer-value (( object -- object )) effect= ] unit-test
+[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
+[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
+[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
+[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
+[ f ] [ [ dup drop ] final-info first infer-value ] unit-test
diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor
similarity index 59%
rename from basis/stack-checker/call-effect/call-effect.factor
rename to basis/compiler/tree/propagation/call-effect/call-effect.factor
index 12477fdb1d..bc18aa6ec1 100644
--- a/basis/stack-checker/call-effect/call-effect.factor
+++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor
@@ -1,9 +1,10 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.private effects fry
 kernel kernel.private make sequences continuations quotations
-stack-checker stack-checker.transforms words math ;
-IN: stack-checker.call-effect
+words math stack-checker stack-checker.transforms
+compiler.tree.propagation.info slots.private ;
+IN: compiler.tree.propagation.call-effect
 
 ! call( and execute( have complex expansions.
 
@@ -90,12 +91,8 @@ M: quotation cached-effect
     [ call-effect-fast ]
     if ; inline
 
-: call-effect>quot ( -- quot )
-    inline-cache new '[ _ call-effect-ic ] ;
-
-\ call-effect [ call-effect>quot ] 0 define-transform
-
-\ call-effect t "no-compile" set-word-prop
+: call-effect>quot ( effect -- quot )
+    inline-cache new '[ drop _ _ call-effect-ic ] ;
 
 : execute-effect-slow ( word effect -- )
     [ '[ _ execute ] ] dip call-effect-slow ; inline
@@ -116,8 +113,72 @@ M: quotation cached-effect
     if ; inline
 
 : execute-effect>quot ( effect -- quot )
-    inline-cache new '[ _ _ execute-effect-ic ] ;
+    inline-cache new '[ drop _ _ execute-effect-ic ] ;
 
-\ execute-effect [ execute-effect>quot ] 1 define-transform
+: last2 ( seq -- penultimate ultimate )
+    2 tail* first2 ;
 
-\ execute-effect t "no-compile" set-word-prop
+: top-two ( #call -- effect value )
+    in-d>> last2 [ value-info ] bi@
+    literal>> swap ;
+
+ERROR: uninferable ;
+
+: remove-effect-input ( effect -- effect' )
+    (( -- object )) swap compose-effects ;
+
+: (infer-value) ( value-info -- effect )
+    dup class>> {
+        { \ quotation [
+            literal>> [ uninferable ] unless* cached-effect
+            dup +unknown+ = [ uninferable ] when
+        ] }
+        { \ curry [
+            slots>> third (infer-value)
+            remove-effect-input
+        ] }
+        { \ compose [
+            slots>> last2 [ (infer-value) ] bi@
+            compose-effects
+        ] }
+        [ uninferable ]
+    } case ;
+
+: infer-value ( value-info -- effect/f )
+    [ (infer-value) ]
+    [ dup uninferable? [ 2drop f ] [ rethrow ] if ]
+    recover ;
+
+: (value>quot) ( value-info -- quot )
+    dup class>> {
+        { \ quotation [ literal>> '[ drop @ ] ] }
+        { \ curry [
+            slots>> third (value>quot)
+            '[ [ obj>> ] [ quot>> @ ] bi ]
+        ] }
+        { \ compose [
+            slots>> last2 [ (value>quot) ] bi@
+            '[ [ first>> @ ] [ second>> @ ] bi ]
+        ] }
+    } case ;
+
+: value>quot ( value-info -- quot: ( code effect -- ) )
+    (value>quot) '[ drop @ ] ;
+
+: call-inlining ( #call -- quot/f )
+    top-two dup infer-value [
+        pick effect<=
+        [ nip value>quot ]
+        [ drop call-effect>quot ] if
+    ] [ drop call-effect>quot ] if* ;
+
+\ call-effect [ call-inlining ] "custom-inlining" set-word-prop
+
+: execute-inlining ( #call -- quot/f )
+    top-two >literal< [
+        2dup swap execute-effect-unsafe?
+        [ nip '[ 2drop _ execute ] ]
+        [ drop execute-effect>quot ] if
+    ] [ drop execute-effect>quot ] if ;
+
+\ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 2f5c166ac5..b3c8026bc4 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -13,7 +13,8 @@ compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.slots
 compiler.tree.propagation.simple
-compiler.tree.propagation.constraints ;
+compiler.tree.propagation.constraints
+compiler.tree.propagation.call-effect ;
 IN: compiler.tree.propagation.known-words
 
 \ fixnum
diff --git a/basis/stack-checker/call-effect/authors.txt b/basis/stack-checker/call-effect/authors.txt
deleted file mode 100644
index d4f5d6b3ae..0000000000
--- a/basis/stack-checker/call-effect/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
\ No newline at end of file
diff --git a/basis/stack-checker/call-effect/call-effect-tests.factor b/basis/stack-checker/call-effect/call-effect-tests.factor
deleted file mode 100644
index 0ad64cace3..0000000000
--- a/basis/stack-checker/call-effect/call-effect-tests.factor
+++ /dev/null
@@ -1,16 +0,0 @@
-USING: stack-checker.call-effect tools.test kernel math effects ;
-IN: stack-checker.call-effect.tests
-
-[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
-[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
-[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
-[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
-
-[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test
-[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test
-[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test
-[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test
-[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test
-[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test
-[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test
-[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test
\ No newline at end of file
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 5bf50dfac1..6959e32452 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -205,6 +205,16 @@ M: object infer-call*
 
 \ drop-locals [ infer-drop-locals ] "special" set-word-prop
 
+: infer-call-effect ( word -- )
+    1 ensure-d first literal value>>
+    add-effect-input add-effect-input
+    apply-word/effect ;
+
+{ call-effect execute-effect } [
+    dup t "no-compile" set-word-prop
+    dup '[ _ infer-call-effect ] "special" set-word-prop
+] each
+
 \ do-primitive [ unknown-primitive-error ] "special" set-word-prop
 
 \ if [ infer-if ] "special" set-word-prop
diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor
index 759988a61f..fe52357f9e 100644
--- a/basis/stack-checker/stack-checker.factor
+++ b/basis/stack-checker/stack-checker.factor
@@ -15,5 +15,3 @@ M: callable infer ( quot -- effect )
 : infer. ( quot -- )
     #! Safe to call from inference transforms.
     infer effect>string print ;
-
-"stack-checker.call-effect" require
\ No newline at end of file

From 4aa3e2135aeee3b0aa0e67bec4edacbee8091d4c Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Tue, 14 Jul 2009 01:23:21 -0500
Subject: [PATCH 16/31] Unit tests for inference behavior of call( and execute(

---
 basis/stack-checker/stack-checker-tests.factor | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index b84f561861..8fee8df538 100644
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -375,4 +375,10 @@ DEFER: eee'
 
 ! Found during code review
 [ [ [ drop [ ] ] when call ] infer ] must-fail
-[ swap [ [ drop [ ] ] when call ] infer ] must-fail
\ No newline at end of file
+[ swap [ [ drop [ ] ] when call ] infer ] must-fail
+
+{ 3 1 } [ call( a b -- c ) ] must-infer-as
+{ 3 1 } [ execute( a b -- c ) ] must-infer-as
+
+[ [ call-effect ] infer ] must-fail
+[ [ execute-effect ] infer ] must-fail

From c0e99e738e141cfdddf37a72d6eedef7dcbdf72c Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 14 Jul 2009 11:43:11 -0500
Subject: [PATCH 17/31] fix inaccuracy in tools.annotations docs

---
 basis/tools/annotations/annotations-docs.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/tools/annotations/annotations-docs.factor b/basis/tools/annotations/annotations-docs.factor
index 8d73d85fb5..07ad79f867 100644
--- a/basis/tools/annotations/annotations-docs.factor
+++ b/basis/tools/annotations/annotations-docs.factor
@@ -21,7 +21,7 @@ $nl
 ABOUT: "tools.annotations"
 
 HELP: annotate
-{ $values { "word" "a word" } { "quot" { $quotation "( word def -- def )" } } }
+{ $values { "word" "a word" } { "quot" { $quotation "( old-def -- new-def )" } } }
 { $description "Changes a word definition to the result of applying a quotation to the old definition." }
 { $notes "This word is used to implement " { $link watch } "." } ;
 

From 4b8132d7770e5db675640ef9255d27eb2c11e2ca Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 14 Jul 2009 11:43:32 -0500
Subject: [PATCH 18/31] factor compilation unit from tools.annotations:reset

---
 basis/tools/annotations/annotations.factor | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
index f02476d4da..2fb246786c 100644
--- a/basis/tools/annotations/annotations.factor
+++ b/basis/tools/annotations/annotations.factor
@@ -7,19 +7,24 @@ tools.time generic inspector fry tools.continuations
 locals generalizations macros ;
 IN: tools.annotations
 
-GENERIC: reset ( word -- )
+<PRIVATE
 
-M: generic reset
-    subwords [ reset ] each ;
+GENERIC: (reset) ( word -- )
 
-M: word reset
+M: generic (reset)
+    subwords [ (reset) ] each ;
+
+M: word (reset)
     dup "unannotated-def" word-prop [
-        [
-            dup dup "unannotated-def" word-prop define
-        ] with-compilation-unit
+        dup dup "unannotated-def" word-prop define
         f "unannotated-def" set-word-prop
     ] [ drop ] if ;
 
+PRIVATE>
+
+: reset ( word -- )
+    [ (reset) ] with-compilation-unit ;
+
 ERROR: cannot-annotate-twice word ;
 
 M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;

From 8bf1fd5f2ac65d3f742bb8a068a28501e1993ccd Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 14 Jul 2009 12:00:37 -0500
Subject: [PATCH 19/31] throw-gl-errors, log-gl-errors annotations for all
 OpenGL functions

---
 basis/opengl/opengl-docs.factor | 38 ++++++++++++++++++++--
 basis/opengl/opengl.factor      | 56 ++++++++++++++++++++++++++++-----
 2 files changed, 85 insertions(+), 9 deletions(-)

diff --git a/basis/opengl/opengl-docs.factor b/basis/opengl/opengl-docs.factor
index 1e4112d5d4..79038a0fd9 100644
--- a/basis/opengl/opengl-docs.factor
+++ b/basis/opengl/opengl-docs.factor
@@ -1,5 +1,5 @@
 USING: alien help.markup help.syntax io kernel math quotations
-opengl.gl assocs vocabs.loader sequences accessors colors ;
+opengl.gl assocs vocabs.loader sequences accessors colors words ;
 IN: opengl
 
 HELP: gl-color
@@ -8,7 +8,35 @@ HELP: gl-color
 { $notes "See " { $link "colors" } "." } ;
 
 HELP: gl-error
-{ $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ;
+{ $description "If the most recent OpenGL call resulted in an error, throw a " { $snippet "gl-error" } " instance reporting the error." } ;
+
+HELP: log-gl-error
+{ $values { "function" word } }
+{ $description "If the most recent OpenGL call resulted in an error, append it to the " { $link gl-error-log } "." }
+{ $notes "Don't call this function directly. Call " { $link log-gl-errors } " to annotate every OpenGL function to automatically log errors." } ;
+
+HELP: gl-error-log
+{ $var-description "A vector of OpenGL errors logged by " { $link log-gl-errors } ". Each log entry has the following tuple slots:" }
+{ $list
+    { { $snippet "function" } " is the OpenGL function that raised the error." }
+    { { $snippet "error" } " is the OpenGL error code." }
+    { { $snippet "timestamp" } " is the time the error was logged." }
+}
+{ "The error log is emptied using the " { $link clear-gl-error-log } " word." } ;
+
+HELP: clear-gl-error-log
+{ $description "Empties the OpenGL error log populated by " { $link log-gl-errors } "." } ;
+
+HELP: throw-gl-errors
+{ $description "Annotate every OpenGL function to throw a " { $link gl-error } " if the function results in an error. Use " { $link reset-gl-functions } " to reverse this operation." } ;
+
+HELP: log-gl-errors
+{ $description "Annotate every OpenGL function to log using " { $link log-gl-error } " if the function results in an error. Use " { $link reset-gl-functions } " to reverse this operation." } ;
+
+HELP: reset-gl-functions
+{ $description "Removes any annotations from all OpenGL functions, such as those applied by " { $link throw-gl-errors } " or " { $link log-gl-errors } "." } ;
+
+{ throw-gl-errors gl-error log-gl-errors log-gl-error clear-gl-error-log reset-gl-functions } related-words
 
 HELP: do-enabled
 { $values { "what" integer } { "quot" quotation } }
@@ -73,6 +101,12 @@ ARTICLE: "gl-utilities" "OpenGL utility words"
 $nl
 "The " { $vocab-link "opengl.gl" } " and " { $vocab-link "opengl.glu" } " vocabularies have the actual OpenGL bindings."
 { $subsection "opengl-low-level" }
+"Error reporting:"
+{ $subsection gl-error }
+{ $subsection throw-gl-errors }
+{ $subsection log-gl-errors }
+{ $subsection clear-gl-error-log }
+{ $subsection reset-gl-functions }
 "Wrappers:"
 { $subsection gl-color }
 { $subsection gl-translate }
diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index bb5847e734..7884890ebf 100644
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -2,11 +2,13 @@
 ! Portions copyright (C) 2007 Eduardo Cavazos.
 ! Portions copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types continuations kernel libc math macros
-namespaces math.vectors math.parser opengl.gl combinators
-combinators.smart arrays sequences splitting words byte-arrays assocs
+USING: alien alien.c-types ascii calendar combinators.short-circuit
+continuations kernel libc math macros namespaces math.vectors
+math.parser opengl.gl combinators combinators.smart arrays
+sequences splitting words byte-arrays assocs vocabs
 colors colors.constants accessors generalizations locals fry
-specialized-arrays.float specialized-arrays.uint ;
+specialized-arrays.float specialized-arrays.uint
+tools.annotations tools.annotations.private compiler.units ;
 IN: opengl
 
 : gl-color ( color -- ) >rgba-components glColor4d ; inline
@@ -30,10 +32,50 @@ IN: opengl
 
 TUPLE: gl-error code string ;
 
+TUPLE: gl-error-log
+    { function word initial: t }
+    { error gl-error }
+    { timestamp timestamp } ;
+
+gl-error-log [ V{ } clone ] initialize
+
+: <gl-error> ( code -- gl-error )
+    dup error>string \ gl-error boa ; inline
+
+: <gl-error-log> ( function code -- gl-error-log )
+    <gl-error> now gl-error-log boa ;
+
+: gl-error-code ( -- code/f )
+    glGetError dup 0 = [ drop f ] when ; inline
+
 : gl-error ( -- )
-    glGetError dup 0 = [ drop ] [
-        dup error>string \ gl-error boa throw
-    ] if ;
+    gl-error-code [ <gl-error> throw ] [ ] if* ;
+
+: log-gl-error ( function -- )
+    gl-error-code [ <gl-error-log> gl-error-log get push ] [ drop ] if* ;
+
+: gl-function? ( word -- ? )
+    name>> { [ "glGetError" = not ] [ "gl" head? ] [ third LETTER? ] } 1&& ;
+
+: gl-functions ( -- words )
+    "opengl.gl" vocab words [ gl-function? ] filter ;
+
+: annotate-gl-functions ( quot -- )
+    [
+        [ gl-functions ] dip [ [ dup ] dip curry (annotate) ] curry each
+    ] with-compilation-unit ;
+
+: reset-gl-functions ( -- )
+    [ gl-functions [ (reset) ] each ] with-compilation-unit ;
+
+: clear-gl-error-log ( -- )
+    V{ } clone gl-error-log set ;
+
+: throw-gl-errors ( -- )
+    [ drop '[ @ gl-error ] ] annotate-gl-functions ;
+
+: log-gl-errors ( -- )
+    [ '[ @ _ log-gl-error ] ] annotate-gl-functions ;
 
 : do-enabled ( what quot -- )
     over glEnable dip glDisable ; inline

From c860a3b1e6b2ad02a8f01fe29aa89fe9c93d1551 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 14 Jul 2009 12:06:55 -0500
Subject: [PATCH 20/31] compiler.cfg: update unit tests for
 compiler.cfg.comparisons

---
 .../compiler/cfg/branch-folding/branch-folding-tests.factor | 5 +++--
 basis/compiler/cfg/linear-scan/linear-scan-tests.factor     | 1 +
 .../cfg/phi-elimination/phi-elimination-tests.factor        | 5 +++--
 .../cfg/value-numbering/value-numbering-tests.factor        | 6 +++---
 4 files changed, 10 insertions(+), 7 deletions(-)

diff --git a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor b/basis/compiler/cfg/branch-folding/branch-folding-tests.factor
index 8ae1f6b75b..1d43ea0af3 100644
--- a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor
+++ b/basis/compiler/cfg/branch-folding/branch-folding-tests.factor
@@ -2,8 +2,9 @@ IN: compiler.cfg.branch-folding.tests
 USING: compiler.cfg.branch-folding compiler.cfg.instructions
 compiler.cfg compiler.cfg.registers compiler.cfg.debugger
 arrays compiler.cfg.phi-elimination compiler.cfg.dce
-compiler.cfg.predecessors kernel accessors assocs
-sequences classes namespaces tools.test cpu.architecture ;
+compiler.cfg.predecessors compiler.cfg.comparisons
+kernel accessors assocs sequences classes namespaces
+tools.test cpu.architecture ;
 
 V{ T{ ##branch } } 0 test-bb
 
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 20f8570f84..fd95a3e09c 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -12,6 +12,7 @@ compiler.cfg.predecessors
 compiler.cfg.rpo
 compiler.cfg.linearization
 compiler.cfg.debugger
+compiler.cfg.comparisons
 compiler.cfg.linear-scan
 compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.live-intervals
diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor b/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
index 2dd75df693..27458185a5 100644
--- a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
+++ b/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
@@ -1,7 +1,8 @@
 IN: compiler.cfg.phi-elimination.tests
 USING: compiler.cfg.instructions compiler.cfg compiler.cfg.registers
-compiler.cfg.debugger compiler.cfg.phi-elimination kernel accessors
-sequences classes namespaces tools.test cpu.architecture arrays ;
+compiler.cfg.comparisons compiler.cfg.debugger
+compiler.cfg.phi-elimination kernel accessors sequences classes
+namespaces tools.test cpu.architecture arrays ;
 
 V{ T{ ##branch } } 0 test-bb
 
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 5063273bf4..b4f8fa1c58 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -1,8 +1,8 @@
 IN: compiler.cfg.value-numbering.tests
 USING: compiler.cfg.value-numbering compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-tools.test kernel math combinators.short-circuit accessors
-sequences compiler.cfg vectors arrays ;
+compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
+cpu.architecture tools.test kernel math combinators.short-circuit
+accessors sequences compiler.cfg vectors arrays ;
 
 : trim-temps ( insns -- insns )
     [

From bf54aebcc10f34fea063eedd15a8a515f9073284 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 14 Jul 2009 12:07:08 -0500
Subject: [PATCH 21/31] Fix QUALIFIED: docs. Reported by ex_rzr in
 #concatenative

---
 core/syntax/syntax-docs.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index d408da4bc7..70905ceda9 100644
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -447,7 +447,7 @@ HELP: USING:
 HELP: QUALIFIED:
 { $syntax "QUALIFIED: vocab" }
 { $description "Adds the vocabulary's words, prefixed with the vocabulary name, to the search path." }
-{ $notes "If adding the vocabulary introduces ambiguity, the vocabulary will take precedence when resolving any ambiguous names. This is a rare case; for example, suppose a vocabulary " { $snippet "fish" } " defines a word named " { $snippet "go:fishing" } ", and a vocabulary named " { $snippet "go" } " defines a word named " { $snippet "finishing" } ". Then, the following will call the latter word:"
+{ $notes "If adding the vocabulary introduces ambiguity, the vocabulary will take precedence when resolving any ambiguous names. This is a rare case; for example, suppose a vocabulary " { $snippet "fish" } " defines a word named " { $snippet "go:fishing" } ", and a vocabulary named " { $snippet "go" } " defines a word named " { $snippet "fishing" } ". Then, the following will call the latter word:"
   { $code
   "USE: fish"
   "QUALIFIED: go"

From d1eea090b6d0b665b443636298bc3ae9b1e4215a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 14 Jul 2009 13:25:07 -0500
Subject: [PATCH 22/31] compiler.cfg.value-numbering: add some unit tests

---
 .../value-numbering-tests.factor              | 582 ++++++++++++++++--
 1 file changed, 524 insertions(+), 58 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index b4f8fa1c58..0166f8f834 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -17,6 +17,7 @@ accessors sequences compiler.cfg vectors arrays ;
     { } init-value-numbering
     value-numbering-step ;
 
+! Copy propagation
 [
     {
         T{ ##peek f V int-regs 45 D 1 }
@@ -31,58 +32,7 @@ accessors sequences compiler.cfg vectors arrays ;
     } test-value-numbering
 ] unit-test
 
-[
-    {
-        T{ ##load-immediate f V int-regs 2 8 }
-        T{ ##peek f V int-regs 3 D 0 }
-        T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
-        T{ ##replace f V int-regs 4 D 0 }
-    }
-] [
-    {
-        T{ ##load-immediate f V int-regs 2 8 }
-        T{ ##peek f V int-regs 3 D 0 }
-        T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
-        T{ ##replace f V int-regs 4 D 0 }
-    } test-value-numbering
-] unit-test
-
-[ t ] [
-    {
-        T{ ##peek f V int-regs 1 D 0 }
-        T{ ##dispatch f V int-regs 1 V int-regs 2 }
-    } dup test-value-numbering =
-] unit-test
-
-[ t ] [
-    {
-        T{ ##peek f V int-regs 16 D 0 }
-        T{ ##peek f V int-regs 17 D -1 }
-        T{ ##sar-imm f V int-regs 18 V int-regs 17 3 }
-        T{ ##add-imm f V int-regs 19 V int-regs 16 13 }
-        T{ ##add f V int-regs 21 V int-regs 18 V int-regs 19 }
-        T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
-        T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
-        T{ ##replace f V int-regs 23 D 0 }
-    } dup test-value-numbering =
-] unit-test
-
-[
-    {
-        T{ ##peek f V int-regs 1 D 0 }
-        T{ ##shl-imm f V int-regs 2 V int-regs 1 3 }
-        T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
-        T{ ##replace f V int-regs 1 D 0 }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 0 }
-        T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
-        T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
-        T{ ##replace f V int-regs 3 D 0 }
-    } test-value-numbering
-] unit-test
-
+! Compare propagation
 [
     {
         T{ ##load-reference f V int-regs 1 + }
@@ -157,15 +107,531 @@ accessors sequences compiler.cfg vectors arrays ;
     } test-value-numbering trim-temps
 ] unit-test
 
+! Immediate operand conversion
 [
     {
-        T{ ##copy f V int-regs 48 V int-regs 45 }
-        T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
     }
 ] [
-    { V int-regs 45 } init-value-numbering
     {
-        T{ ##copy f V int-regs 48 V int-regs 45 }
-        T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
-    } value-numbering-step
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
+    } test-value-numbering
 ] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##sub-imm f V int-regs 2 V int-regs 0 100 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 0 }
+        T{ ##shl-imm f V int-regs 2 V int-regs 1 3 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 0 }
+        T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc<= }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##compare f V int-regs 2 V int-regs 0 V int-regs 1 cc<= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc>= }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##compare f V int-regs 2 V int-regs 1 V int-regs 0 cc<= }
+    } test-value-numbering trim-temps
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##compare-imm-branch f V int-regs 0 100 cc<= }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 1 cc<= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##compare-imm-branch f V int-regs 0 100 cc>= }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##compare-branch f V int-regs 1 V int-regs 0 cc<= }
+    } test-value-numbering trim-temps
+] unit-test
+
+! Reassociation
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##add-imm f V int-regs 4 V int-regs 0 150 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##add f V int-regs 4 V int-regs 2 V int-regs 3 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##add-imm f V int-regs 4 V int-regs 0 150 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##add-imm f V int-regs 4 V int-regs 0 50 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##sub-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##sub-imm f V int-regs 4 V int-regs 0 150 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##mul f V int-regs 4 V int-regs 2 V int-regs 3 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##mul f V int-regs 4 V int-regs 3 V int-regs 2 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##and-imm f V int-regs 4 V int-regs 0 32 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##and f V int-regs 4 V int-regs 2 V int-regs 3 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##and-imm f V int-regs 4 V int-regs 0 32 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##and f V int-regs 4 V int-regs 3 V int-regs 2 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##or-imm f V int-regs 4 V int-regs 0 118 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##or f V int-regs 4 V int-regs 2 V int-regs 3 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##or-imm f V int-regs 4 V int-regs 0 118 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##or f V int-regs 4 V int-regs 3 V int-regs 2 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##xor-imm f V int-regs 4 V int-regs 0 86 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##xor f V int-regs 4 V int-regs 2 V int-regs 3 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##xor-imm f V int-regs 4 V int-regs 0 86 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 100 }
+        T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
+        T{ ##load-immediate f V int-regs 3 50 }
+        T{ ##xor f V int-regs 4 V int-regs 3 V int-regs 2 }
+    } test-value-numbering
+] unit-test
+
+! Simplification
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+        T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##replace f V int-regs 0 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+        T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##replace f V int-regs 3 D 0 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+        T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##replace f V int-regs 0 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+        T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##replace f V int-regs 3 D 0 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+        T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##replace f V int-regs 0 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+        T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##replace f V int-regs 3 D 0 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+        T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##replace f V int-regs 0 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+        T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##replace f V int-regs 3 D 0 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
+        T{ ##replace f V int-regs 0 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
+        T{ ##replace f V int-regs 2 D 0 }
+    } test-value-numbering
+] unit-test
\ No newline at end of file

From bb06facb0188b9f335b852a705d2ea6424561b0e Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Tue, 14 Jul 2009 14:16:39 -0500
Subject: [PATCH 23/31] new is inlined in the propagation pass when the class
 is known

---
 .../propagation/known-words/known-words.factor     | 14 +++++++++++++-
 .../tree/propagation/propagation-tests.factor      | 13 +++++++++++++
 basis/stack-checker/transforms/transforms.factor   |  9 ---------
 3 files changed, 26 insertions(+), 10 deletions(-)

diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index b3c8026bc4..aec61608f1 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -6,7 +6,7 @@ math.parser math.order layouts words sequences sequences.private
 arrays assocs classes classes.algebra combinators generic.math
 splitting fry locals classes.tuple alien.accessors
 classes.tuple.private slots.private definitions strings.private
-vectors hashtables generic
+vectors hashtables generic quotations
 stack-checker.state
 compiler.tree.comparisons
 compiler.tree.propagation.info
@@ -360,3 +360,15 @@ generic-comparison-ops [
         [ swap equal? ] f ?
     ] [ drop f ] if
 ] "custom-inlining" set-word-prop
+
+: inline-new ( class -- quot/f )
+    dup tuple-class? [
+        dup inlined-dependency depends-on
+        [ all-slots [ initial>> literalize ] map ]
+        [ tuple-layout '[ _ <tuple-boa> ] ]
+        bi append [ drop ] prepend >quotation
+    ] [ drop f ] if ;
+
+\ new [
+    in-d>> first value-info literal>> inline-new
+] "custom-inlining" set-word-prop
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 32c9f4ed0b..108afad296 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -704,3 +704,16 @@ TUPLE: circle me ;
 
 ! Joe found an oversight
 [ V{ integer } ] [ [ >integer ] final-classes ] unit-test
+
+TUPLE: foo bar ;
+
+[ t ] [ [ foo new ] { new } inlined? ] unit-test
+
+GENERIC: whatever ( x -- y )
+M: number whatever drop foo ;
+
+[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test
+
+: that-thing ( -- class ) foo ;
+
+[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index 017594a4eb..9d1ab1332a 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -108,15 +108,6 @@ IN: stack-checker.transforms
 
 \ boa t "no-compile" set-word-prop
 
-\ new [
-    dup tuple-class? [
-        dup inlined-dependency depends-on
-        [ all-slots [ initial>> literalize ] map ]
-        [ tuple-layout '[ _ <tuple-boa> ] ]
-        bi append
-    ] [ drop f ] if
-] 1 define-transform
-
 ! Fast at for integer maps
 CONSTANT: lookup-table-at-max 256
 

From 2ace87370e9e37948526be7476b6a2499fc1de33 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 14 Jul 2009 16:05:25 -0500
Subject: [PATCH 24/31] compiler.cfg.value-numbering: more optimizations

---
 .../value-numbering/rewrite/rewrite.factor    | 236 +++++++++++-------
 .../value-numbering/simplify/simplify.factor  |  61 ++++-
 .../value-numbering-tests.factor              | 201 +++++++++++++--
 .../value-numbering/value-numbering.factor    |   3 +-
 basis/compiler/tests/codegen.factor           |   4 +-
 5 files changed, 393 insertions(+), 112 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index bc8fc50547..a0e8dd6146 100755
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors locals combinators combinators.short-circuit arrays
 fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise
+math.bitwise classes
 compiler.cfg.hats
 compiler.cfg.comparisons
 compiler.cfg.instructions
@@ -11,9 +11,15 @@ compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.simplify ;
 IN: compiler.cfg.value-numbering.rewrite
 
-GENERIC: rewrite ( insn -- insn' )
+! Outputs f to mean no change
 
-M: insn rewrite ;
+GENERIC: rewrite* ( insn -- insn/f )
+
+: rewrite ( insn -- insn' )
+    dup [ number-values ] [ rewrite* ] bi
+    [ rewrite ] [ ] ?if ;
+
+M: insn rewrite* drop f ;
 
 : ##branch-t? ( insn -- ? )
     dup ##compare-imm-branch? [
@@ -61,7 +67,7 @@ M: insn rewrite ;
     [ cc>> ]
     tri ; inline
 
-GENERIC: rewrite-tagged-comparison ( insn -- insn' )
+GENERIC: rewrite-tagged-comparison ( insn -- insn/f )
 
 M: ##compare-imm-branch rewrite-tagged-comparison
     (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
@@ -70,11 +76,12 @@ M: ##compare-imm rewrite-tagged-comparison
     [ dst>> ] [ (rewrite-tagged-comparison) ] bi
     i \ ##compare-imm new-insn ;
 
-M: ##compare-imm-branch rewrite
-    dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
-    dup ##compare-imm-branch? [
-        dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
-    ] when ;
+M: ##compare-imm-branch rewrite*
+    {
+        { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
+        { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
+        [ drop f ]
+    } cond ;
 
 :: >compare-imm ( insn swap? -- insn' )
     insn dst>>
@@ -89,12 +96,12 @@ M: ##compare-imm-branch rewrite
         [ value>> small-enough? ]
     } 1&& ;
 
-M: ##compare rewrite
+M: ##compare rewrite*
     dup [ src1>> ] [ src2>> ] bi
     [ vreg-small-constant? ] bi@ 2array {
         { { f t } [ f >compare-imm ] }
         { { t f } [ t >compare-imm ] }
-        [ drop ]
+        [ 2drop f ]
     } case ;
 
 :: >compare-imm-branch ( insn swap? -- insn' )
@@ -103,12 +110,12 @@ M: ##compare rewrite
     insn cc>> swap? [ swap-cc ] when
     \ ##compare-imm-branch new-insn ; inline
 
-M: ##compare-branch rewrite
+M: ##compare-branch rewrite*
     dup [ src1>> ] [ src2>> ] bi
     [ vreg-small-constant? ] bi@ 2array {
         { { f t } [ f >compare-imm-branch ] }
         { { t f } [ t >compare-imm-branch ] }
-        [ drop ]
+        [ 2drop f ]
     } case ;
 
 : rewrite-redundant-comparison? ( insn -- ? )
@@ -126,103 +133,158 @@ M: ##compare-branch rewrite
     } case
     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 
-M: ##compare-imm rewrite
-    dup rewrite-redundant-comparison? [
-        rewrite-redundant-comparison
-        dup number-values rewrite
-    ] when
-    dup ##compare-imm? [
-        dup rewrite-tagged-comparison? [
-            rewrite-tagged-comparison
-            dup number-values rewrite
-        ] when
-    ] when ;
+M: ##compare-imm rewrite*
+    {
+        { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
+        { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
+        [ drop f ]
+    } cond ;
+
+: constant-fold? ( insn -- ? )
+    src1>> vreg>expr constant-expr? ; inline
+
+GENERIC: constant-fold* ( x y insn -- z )
+
+M: ##add-imm constant-fold* drop + ;
+M: ##sub-imm constant-fold* drop - ;
+M: ##mul-imm constant-fold* drop * ;
+M: ##and-imm constant-fold* drop bitand ;
+M: ##or-imm constant-fold* drop bitor ;
+M: ##xor-imm constant-fold* drop bitxor ;
+M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
+M: ##sar-imm constant-fold* drop neg shift ;
+M: ##shl-imm constant-fold* drop shift ;
 
 : constant-fold ( insn -- insn' )
-    dup dst>> vreg>expr dup constant-expr? [
-        [ dst>> ] [ value>> ] bi* \ ##load-immediate new-insn
-        dup number-values
-    ] [
-        drop
-    ] if ;
+    [ dst>> ]
+    [ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
+    \ ##load-immediate new-insn ; inline
 
-: (new-imm-insn) ( insn dst src1 n op -- new-insn/insn )
-    [ cell-bits bits ] dip over small-enough? [
-        new-insn dup number-values nip
-    ] [
-        2drop 2drop
-    ] if constant-fold ; inline
+:: new-imm-insn ( insn dst src1 src2 op -- new-insn/insn )
+    src2 small-enough? [ dst src1 src2 op new-insn ] [ insn ] if ; inline
 
-: new-imm-insn ( insn dst src n op -- n' op' )
-    2dup [ sgn ] dip 2array
-    {
-        { { -1 ##add-imm } [ drop neg \ ##sub-imm (new-imm-insn) ] }
-        { { -1 ##sub-imm } [ drop neg \ ##add-imm (new-imm-insn) ] }
-        [ drop (new-imm-insn) ]
-    } case ; inline
+: reassociate? ( insn -- ? )
+    [ src1>> vreg>expr op>> ] [ class ] bi = ; inline
 
-: combine-imm? ( insn op -- ? )
-    [ src1>> vreg>expr op>> ] dip = ;
-
-: (combine-imm) ( insn quot op -- insn )
+: reassociate ( insn op -- insn )
     [
         {
             [ ]
             [ dst>> ]
             [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
             [ src2>> ]
-        } cleave
-    ] [ call ] [ ] tri* new-imm-insn ; inline
+            [ ]
+        } cleave constant-fold*
+    ] dip new-imm-insn ; inline
 
-:: combine-imm ( insn quot op -- insn )
-    insn op combine-imm? [
-        insn quot op (combine-imm)
-    ] [
-        insn
-    ] if ; inline
-
-M: ##add-imm rewrite
+M: ##add-imm rewrite*
     {
-        { [ dup \ ##add-imm combine-imm? ] [ [ + ] \ ##add-imm (combine-imm) ] }
-        { [ dup \ ##sub-imm combine-imm? ] [ [ - ] \ ##sub-imm (combine-imm) ] }
-        [ ]
+        { [ dup constant-fold? ] [ constant-fold ] }
+        { [ dup reassociate? ] [ \ ##add-imm reassociate ] }
+        [ drop f ]
     } cond ;
 
-M: ##sub-imm rewrite
+: sub-imm>add-imm ( insn -- insn' )
+    dup [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
+    [ \ ##add-imm new-insn nip ] [ 2drop 2drop f ] if ;
+
+M: ##sub-imm rewrite*
     {
-        { [ dup \ ##add-imm combine-imm? ] [ [ - ] \ ##add-imm (combine-imm) ] }
-        { [ dup \ ##sub-imm combine-imm? ] [ [ + ] \ ##sub-imm (combine-imm) ] }
-        [ ]
+        { [ dup constant-fold? ] [ constant-fold ] }
+        [ sub-imm>add-imm ]
     } cond ;
 
-M: ##mul-imm rewrite
-    dup src2>> dup power-of-2? [
-        [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
-        dup number-values
-    ] [
-        drop [ * ] \ ##mul-imm combine-imm
-    ] if ;
+: strength-reduce-mul ( insn -- insn' )
+    [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
 
-M: ##and-imm rewrite [ bitand ] \ ##and-imm combine-imm ;
+: strength-reduce-mul? ( insn -- ? )
+    src2>> power-of-2? ;
 
-M: ##or-imm rewrite [ bitor ] \ ##or-imm combine-imm ;
+M: ##mul-imm rewrite*
+    {
+        { [ dup constant-fold? ] [ constant-fold ] }
+        { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
+        { [ dup reassociate? ] [ \ ##mul-imm reassociate ] }
+        [ drop f ]
+    } cond ;
 
-M: ##xor-imm rewrite [ bitxor ] \ ##xor-imm combine-imm ;
+M: ##and-imm rewrite*
+    {
+        { [ dup constant-fold? ] [ constant-fold ] }
+        { [ dup reassociate? ] [ \ ##and-imm reassociate ] }
+        [ drop f ]
+    } cond ;
 
-: new-arithmetic ( obj op -- )
-    [
-        [ dst>> ]
-        [ src1>> ]
-        [ src2>> vreg>constant ] tri
-    ] dip new-insn dup number-values ; inline
+M: ##or-imm rewrite*
+    {
+        { [ dup constant-fold? ] [ constant-fold ] }
+        { [ dup reassociate? ] [ \ ##or-imm reassociate ] }
+        [ drop f ]
+    } cond ;
+
+M: ##xor-imm rewrite*
+    {
+        { [ dup constant-fold? ] [ constant-fold ] }
+        { [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
+        [ drop f ]
+    } cond ;
+
+M: ##shl-imm rewrite*
+    {
+        { [ dup constant-fold? ] [ constant-fold ] }
+        [ drop f ]
+    } cond ;
+
+M: ##shr-imm rewrite*
+    {
+        { [ dup constant-fold? ] [ constant-fold ] }
+        [ drop f ]
+    } cond ;
+
+M: ##sar-imm rewrite*
+    {
+        { [ dup constant-fold? ] [ constant-fold ] }
+        [ drop f ]
+    } cond ;
+
+:: insn>imm-insn ( insn op swap? -- )
+    insn
+    insn dst>>
+    insn src1>>
+    insn src2>> swap? [ swap ] when vreg>constant
+    op new-imm-insn ; inline
 
 : rewrite-arithmetic ( insn op -- ? )
-    over src2>> vreg-small-constant? [
-        new-arithmetic constant-fold
-    ] [
-        drop
-    ] if ; inline
+    {
+        { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
+        [ 2drop f ]
+    } cond ; inline
 
-M: ##add rewrite \ ##add-imm rewrite-arithmetic ;
+: rewrite-arithmetic-commutative ( insn op -- ? )
+    {
+        { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
+        { [ over src1>> vreg-small-constant? ] [ t insn>imm-insn ] }
+        [ 2drop f ]
+    } cond ; inline
 
-M: ##sub rewrite \ ##sub-imm rewrite-arithmetic ;
+M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
+
+: subtraction-identity? ( insn -- ? )
+    [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq?  ;
+
+: rewrite-subtraction-identity ( insn -- insn' )
+    dst>> 0 \ ##load-immediate new-insn ;
+
+M: ##sub rewrite*
+    {
+        { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
+        [ \ ##sub-imm rewrite-arithmetic ]
+    } cond ;
+
+M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ;
+
+M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ;
+
+M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ;
+
+M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ;
diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
index b7526528e4..a956498af4 100644
--- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor
+++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
@@ -32,6 +32,8 @@ M: unary-expr simplify*
 
 : expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
 
+: expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline
+
 : >binary-expr< ( expr -- in1 in2 )
     [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
 
@@ -44,18 +46,54 @@ M: unary-expr simplify*
 
 : simplify-sub ( expr -- vn/expr/f )
     >binary-expr< {
-        { [ 2dup eq? ] [ 2drop T{ constant-expr f f 0 } ] }
         { [ dup expr-zero? ] [ drop ] }
         [ 2drop f ]
     } cond ; inline
 
-: useless-shift? ( in1 in2 -- ? )
+: simplify-mul ( expr -- vn/expr/f )
+    >binary-expr< {
+        { [ over expr-one? ] [ drop ] }
+        { [ dup expr-one? ] [ drop ] }
+        [ 2drop f ]
+    } cond ; inline
+
+: simplify-and ( expr -- vn/expr/f )
+    >binary-expr< {
+        { [ 2dup eq? ] [ drop ] }
+        [ 2drop f ]
+    } cond ; inline
+
+: simplify-or ( expr -- vn/expr/f )
+    >binary-expr< {
+        { [ 2dup eq? ] [ drop ] }
+        { [ over expr-zero? ] [ nip ] }
+        { [ dup expr-zero? ] [ drop ] }
+        [ 2drop f ]
+    } cond ; inline
+
+: simplify-xor ( expr -- vn/expr/f )
+    >binary-expr< {
+        { [ over expr-zero? ] [ nip ] }
+        { [ dup expr-zero? ] [ drop ] }
+        [ 2drop f ]
+    } cond ; inline
+
+: useless-shr? ( in1 in2 -- ? )
     over op>> \ ##shl-imm eq?
     [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
 
-: simplify-shift ( expr -- vn/expr/f )
-    >binary-expr<
-    2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline
+: simplify-shr ( expr -- vn/expr/f )
+    >binary-expr< {
+        { [ 2dup useless-shr? ] [ drop in1>> ] }
+        { [ dup expr-zero? ] [ drop ] }
+        [ 2drop f ]
+    } cond ; inline
+
+: simplify-shl ( expr -- vn/expr/f )
+    >binary-expr< {
+        { [ dup expr-zero? ] [ drop ] }
+        [ 2drop f ]
+    } cond ; inline
 
 M: binary-expr simplify*
     dup op>> {
@@ -63,8 +101,17 @@ M: binary-expr simplify*
         { \ ##add-imm [ simplify-add ] }
         { \ ##sub [ simplify-sub ] }
         { \ ##sub-imm [ simplify-sub ] }
-        { \ ##shr-imm [ simplify-shift ] }
-        { \ ##sar-imm [ simplify-shift ] }
+        { \ ##mul [ simplify-mul ] }
+        { \ ##mul-imm [ simplify-mul ] }
+        { \ ##and [ simplify-and ] }
+        { \ ##and-imm [ simplify-and ] }
+        { \ ##or [ simplify-or ] }
+        { \ ##or-imm [ simplify-or ] }
+        { \ ##xor [ simplify-xor ] }
+        { \ ##xor-imm [ simplify-xor ] }
+        { \ ##shr-imm [ simplify-shr ] }
+        { \ ##sar-imm [ simplify-shr ] }
+        { \ ##shl-imm [ simplify-shl ] }
         [ 2drop f ]
     } case ;
 
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 0166f8f834..6ed0a74da5 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -2,7 +2,7 @@ IN: compiler.cfg.value-numbering.tests
 USING: compiler.cfg.value-numbering compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
 cpu.architecture tools.test kernel math combinators.short-circuit
-accessors sequences compiler.cfg vectors arrays ;
+accessors sequences compiler.cfg vectors arrays layouts ;
 
 : trim-temps ( insns -- insns )
     [
@@ -140,7 +140,7 @@ accessors sequences compiler.cfg vectors arrays ;
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
-        T{ ##sub-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##add-imm f V int-regs 2 V int-regs 0 -100 }
     }
 ] [
     {
@@ -150,6 +150,18 @@ accessors sequences compiler.cfg vectors arrays ;
     } test-value-numbering
 ] unit-test
 
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##sub f V int-regs 1 V int-regs 0 V int-regs 0 }
+    } test-value-numbering
+] unit-test
+
 [
     {
         T{ ##peek f V int-regs 0 D 0 }
@@ -285,7 +297,7 @@ accessors sequences compiler.cfg vectors arrays ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##compare f V int-regs 2 V int-regs 0 V int-regs 1 cc<= }
-    } test-value-numbering
+    } test-value-numbering trim-temps
 ] unit-test
 
 [
@@ -389,9 +401,9 @@ accessors sequences compiler.cfg vectors arrays ;
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
-        T{ ##sub-imm f V int-regs 2 V int-regs 0 100 }
+        T{ ##add-imm f V int-regs 2 V int-regs 0 -100 }
         T{ ##load-immediate f V int-regs 3 50 }
-        T{ ##sub-imm f V int-regs 4 V int-regs 0 150 }
+        T{ ##add-imm f V int-regs 4 V int-regs 0 -150 }
     }
 ] [
     {
@@ -552,8 +564,8 @@ accessors sequences compiler.cfg vectors arrays ;
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
-        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
-        T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##load-immediate f V int-regs 2 0 }
+        T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
         T{ ##replace f V int-regs 0 D 0 }
     }
 ] [
@@ -570,8 +582,8 @@ accessors sequences compiler.cfg vectors arrays ;
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
-        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
-        T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##load-immediate f V int-regs 2 0 }
+        T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
         T{ ##replace f V int-regs 0 D 0 }
     }
 ] [
@@ -588,8 +600,8 @@ accessors sequences compiler.cfg vectors arrays ;
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
-        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
-        T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##load-immediate f V int-regs 2 0 }
+        T{ ##or-imm f V int-regs 3 V int-regs 0 0 }
         T{ ##replace f V int-regs 0 D 0 }
     }
 ] [
@@ -606,8 +618,8 @@ accessors sequences compiler.cfg vectors arrays ;
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
-        T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
-        T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 }
+        T{ ##load-immediate f V int-regs 2 0 }
+        T{ ##xor-imm f V int-regs 3 V int-regs 0 0 }
         T{ ##replace f V int-regs 0 D 0 }
     }
 ] [
@@ -624,7 +636,7 @@ accessors sequences compiler.cfg vectors arrays ;
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 1 }
-        T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
+        T{ ##shl-imm f V int-regs 2 V int-regs 0 0 }
         T{ ##replace f V int-regs 0 D 0 }
     }
 ] [
@@ -634,4 +646,163 @@ accessors sequences compiler.cfg vectors arrays ;
         T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##replace f V int-regs 2 D 0 }
     } test-value-numbering
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Constant folding
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 3 }
+        T{ ##load-immediate f V int-regs 3 4 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 3 }
+        T{ ##add f V int-regs 3 V int-regs 1 V int-regs 2 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 3 }
+        T{ ##load-immediate f V int-regs 3 -2 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 3 }
+        T{ ##sub f V int-regs 3 V int-regs 1 V int-regs 2 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 2 }
+        T{ ##load-immediate f V int-regs 2 3 }
+        T{ ##load-immediate f V int-regs 3 6 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 2 }
+        T{ ##load-immediate f V int-regs 2 3 }
+        T{ ##mul f V int-regs 3 V int-regs 1 V int-regs 2 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 2 }
+        T{ ##load-immediate f V int-regs 2 1 }
+        T{ ##load-immediate f V int-regs 3 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 2 }
+        T{ ##load-immediate f V int-regs 2 1 }
+        T{ ##and f V int-regs 3 V int-regs 1 V int-regs 2 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 2 }
+        T{ ##load-immediate f V int-regs 2 1 }
+        T{ ##load-immediate f V int-regs 3 3 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 2 }
+        T{ ##load-immediate f V int-regs 2 1 }
+        T{ ##or f V int-regs 3 V int-regs 1 V int-regs 2 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 2 }
+        T{ ##load-immediate f V int-regs 2 3 }
+        T{ ##load-immediate f V int-regs 3 1 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 2 }
+        T{ ##load-immediate f V int-regs 2 3 }
+        T{ ##xor f V int-regs 3 V int-regs 1 V int-regs 2 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 3 8 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##shl-imm f V int-regs 3 V int-regs 1 3 }
+    } test-value-numbering
+] unit-test
+
+cell 8 = [
+    [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 1 -1 }
+            T{ ##load-immediate f V int-regs 3 HEX: ffffffffffff }
+        }
+    ] [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 1 -1 }
+            T{ ##shr-imm f V int-regs 3 V int-regs 1 16 }
+        } test-value-numbering
+    ] unit-test
+] when
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 -8 }
+        T{ ##load-immediate f V int-regs 3 -4 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 -8 }
+        T{ ##sar-imm f V int-regs 3 V int-regs 1 1 }
+    } test-value-numbering
+] unit-test
+
+cell 8 = [
+    [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 1 65536 }
+            T{ ##load-immediate f V int-regs 2 140737488355328 }
+            T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+        }
+    ] [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 1 65536 }
+            T{ ##shl-imm f V int-regs 2 V int-regs 1 31 }
+            T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+        } test-value-numbering
+    ] unit-test
+] when
\ No newline at end of file
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index f0efa5dcca..9e6e058b52 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -29,8 +29,7 @@ IN: compiler.cfg.value-numbering
     ] with-variable ;
 
 : value-numbering-step ( insns -- insns' )
-    [ [ number-values ] [ rewrite ] bi ] map
-    dup rename-uses ;
+    [ rewrite ] map dup rename-uses ;
 
 : value-numbering ( cfg -- cfg' )
     [ init-value-numbering ] [ value-numbering-step ] local-optimization ;
diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor
index 82da31b5fe..1463dbadb5 100644
--- a/basis/compiler/tests/codegen.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -314,4 +314,6 @@ M: cucumber equal? "The cucumber has no equal" throw ;
 
 ! Regression from Doug's value numbering changes
 [ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test
-[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
\ No newline at end of file
+[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
+
+[ 0 ] [ 101 [ dup fixnum-fast 1 fixnum+fast 20 fixnum-shift-fast 20 fixnum-shift-fast ] compile-call ] unit-test
\ No newline at end of file

From 03cd550b93fa0dea53fbdfb542ea07a68670d517 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 14 Jul 2009 16:11:14 -0500
Subject: [PATCH 25/31] Fix codegen test

---
 basis/compiler/tests/codegen.factor | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor
index 1463dbadb5..8f7bc077b4 100644
--- a/basis/compiler/tests/codegen.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -316,4 +316,6 @@ M: cucumber equal? "The cucumber has no equal" throw ;
 [ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test
 [ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
 
-[ 0 ] [ 101 [ dup fixnum-fast 1 fixnum+fast 20 fixnum-shift-fast 20 fixnum-shift-fast ] compile-call ] unit-test
\ No newline at end of file
+cell 4 = [
+    [ 0 ] [ 101 [ dup fixnum-fast 1 fixnum+fast 20 fixnum-shift-fast 20 fixnum-shift-fast ] compile-call ] unit-test
+] when
\ No newline at end of file

From 73a22225417d6ae7f8bef438f92ffb57e335e66e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 14 Jul 2009 19:17:12 -0500
Subject: [PATCH 26/31] compiler.cfg.value-numbering: branch folding

---
 basis/compiler/cfg/local/local.factor         |  14 +-
 .../expressions/expressions.factor            |  27 ++-
 .../value-numbering/rewrite/rewrite.factor    | 145 +++++++-----
 .../value-numbering-tests.factor              | 206 +++++++++++++++++-
 4 files changed, 323 insertions(+), 69 deletions(-)

diff --git a/basis/compiler/cfg/local/local.factor b/basis/compiler/cfg/local/local.factor
index 5d78397998..2f5f5b18e3 100644
--- a/basis/compiler/cfg/local/local.factor
+++ b/basis/compiler/cfg/local/local.factor
@@ -1,10 +1,14 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ;
+USING: locals accessors kernel assocs namespaces
+compiler.cfg compiler.cfg.liveness compiler.cfg.rpo ;
 IN: compiler.cfg.local
 
-: optimize-basic-block ( bb init-quot insn-quot -- )
-    [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
+:: optimize-basic-block ( bb init-quot insn-quot -- )
+    bb basic-block set
+    bb live-in keys init-quot call
+    bb insn-quot change-instructions drop ; inline
 
-: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
-    [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline
\ No newline at end of file
+:: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
+    cfg [ init-quot insn-quot optimize-basic-block ] each-basic-block
+    cfg ; inline
\ No newline at end of file
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index bf750231c7..76ad3d892f 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes kernel math namespaces combinators
-compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
+combinators.short-circuit compiler.cfg.instructions
+compiler.cfg.value-numbering.graph ;
 IN: compiler.cfg.value-numbering.expressions
 
 ! Referentially-transparent expressions
@@ -11,15 +12,29 @@ TUPLE: binary-expr < expr in1 in2 ;
 TUPLE: commutative-expr < binary-expr ;
 TUPLE: compare-expr < binary-expr cc ;
 TUPLE: constant-expr < expr value ;
+TUPLE: reference-expr < expr value ;
 
 : <constant> ( constant -- expr )
     f swap constant-expr boa ; inline
 
 M: constant-expr equal?
     over constant-expr? [
-        [ [ value>> ] bi@ = ]
-        [ [ value>> class ] bi@ = ] 2bi
-        and
+        {
+            [ [ value>> class ] bi@ = ]
+            [ [ value>> ] bi@ = ]
+        } 2&&
+    ] [ 2drop f ] if ;
+
+: <reference> ( constant -- expr )
+    f swap reference-expr boa ; inline
+
+M: reference-expr equal?
+    over reference-expr? [
+        [ value>> ] bi@ {
+            { [ 2dup eq? ] [ 2drop t ] }
+            { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
+            [ 2drop f ]
+        } cond
     ] [ 2drop f ] if ;
 
 ! Expressions whose values are inputs to the basic block. We
@@ -39,6 +54,8 @@ GENERIC: >expr ( insn -- expr )
 
 M: ##load-immediate >expr val>> <constant> ;
 
+M: ##load-reference >expr obj>> <reference> ;
+
 M: ##unary >expr
     [ class ] [ src>> vreg>vn ] bi unary-expr boa ;
 
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index a0e8dd6146..5dd8884a89 100755
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors locals combinators combinators.short-circuit arrays
+USING: accessors combinators combinators.short-circuit arrays
 fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise classes
+math.bitwise math.order classes vectors
+compiler.cfg
 compiler.cfg.hats
 compiler.cfg.comparisons
 compiler.cfg.instructions
@@ -11,6 +12,12 @@ compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.simplify ;
 IN: compiler.cfg.value-numbering.rewrite
 
+: vreg-small-constant? ( vreg -- ? )
+    vreg>expr {
+        [ constant-expr? ]
+        [ value>> small-enough? ]
+    } 1&& ;
+
 ! Outputs f to mean no change
 
 GENERIC: rewrite* ( insn -- insn/f )
@@ -76,48 +83,6 @@ M: ##compare-imm rewrite-tagged-comparison
     [ dst>> ] [ (rewrite-tagged-comparison) ] bi
     i \ ##compare-imm new-insn ;
 
-M: ##compare-imm-branch rewrite*
-    {
-        { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
-        { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
-        [ drop f ]
-    } cond ;
-
-:: >compare-imm ( insn swap? -- insn' )
-    insn dst>>
-    insn src1>>
-    insn src2>> swap? [ swap ] when vreg>constant
-    insn cc>> swap? [ swap-cc ] when
-    i \ ##compare-imm new-insn ; inline
-
-: vreg-small-constant? ( vreg -- ? )
-    vreg>expr {
-        [ constant-expr? ]
-        [ value>> small-enough? ]
-    } 1&& ;
-
-M: ##compare rewrite*
-    dup [ src1>> ] [ src2>> ] bi
-    [ vreg-small-constant? ] bi@ 2array {
-        { { f t } [ f >compare-imm ] }
-        { { t f } [ t >compare-imm ] }
-        [ 2drop f ]
-    } case ;
-
-:: >compare-imm-branch ( insn swap? -- insn' )
-    insn src1>>
-    insn src2>> swap? [ swap ] when vreg>constant
-    insn cc>> swap? [ swap-cc ] when
-    \ ##compare-imm-branch new-insn ; inline
-
-M: ##compare-branch rewrite*
-    dup [ src1>> ] [ src2>> ] bi
-    [ vreg-small-constant? ] bi@ 2array {
-        { { f t } [ f >compare-imm-branch ] }
-        { { t f } [ t >compare-imm-branch ] }
-        [ 2drop f ]
-    } case ;
-
 : rewrite-redundant-comparison? ( insn -- ? )
     {
         [ src1>> vreg>expr compare-expr? ]
@@ -133,10 +98,80 @@ M: ##compare-branch rewrite*
     } case
     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 
+: (fold-compare-imm) ( insn -- ? )
+    [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi
+    pick integer? [ [ <=> ] dip evaluate-cc ] [ 3drop f ] if ;
+
+: fold-compare-imm? ( insn -- ? )
+    src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
+
+: fold-compare-imm-branch ( insn -- insn/f )
+    (fold-compare-imm) 0 1 ?
+    basic-block get [ nth 1vector ] change-successors drop
+    \ ##branch new-insn ;
+
+M: ##compare-imm-branch rewrite*
+    {
+        { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
+        { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
+        { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
+        [ drop f ]
+    } cond ;
+
+: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
+    [ [ swap ] dip swap-cc ] when ; inline
+
+: >compare-imm-branch ( insn swap? -- insn' )
+    [
+        [ src1>> ]
+        [ src2>> ]
+        [ cc>> ]
+        tri
+    ] dip
+    swap-compare
+    [ vreg>constant ] dip
+    \ ##compare-imm-branch new-insn ; inline
+
+M: ##compare-branch rewrite*
+    {
+        { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
+        { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
+        [ drop f ]
+    } cond ;
+
+: >compare-imm ( insn swap? -- insn' )
+    [
+        {
+            [ dst>> ]
+            [ src1>> ]
+            [ src2>> ]
+            [ cc>> ]
+        } cleave
+    ] dip
+    swap-compare
+    [ vreg>constant ] dip
+    i \ ##compare-imm new-insn ; inline
+
+M: ##compare rewrite*
+    {
+        { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
+        { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
+        [ drop f ]
+    } cond ;
+
+: fold-compare-imm ( insn -- )
+    [ dst>> ]
+    [ (fold-compare-imm) ] bi
+    {
+        { t [ t \ ##load-reference new-insn ] }
+        { f [ \ f tag-number \ ##load-immediate new-insn ] }
+    } case ;
+
 M: ##compare-imm rewrite*
     {
         { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
         { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
+        { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
         [ drop f ]
     } cond ;
 
@@ -160,22 +195,19 @@ M: ##shl-imm constant-fold* drop shift ;
     [ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
     \ ##load-immediate new-insn ; inline
 
-:: new-imm-insn ( insn dst src1 src2 op -- new-insn/insn )
-    src2 small-enough? [ dst src1 src2 op new-insn ] [ insn ] if ; inline
-
 : reassociate? ( insn -- ? )
     [ src1>> vreg>expr op>> ] [ class ] bi = ; inline
 
 : reassociate ( insn op -- insn )
     [
         {
-            [ ]
             [ dst>> ]
             [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
             [ src2>> ]
             [ ]
         } cleave constant-fold*
-    ] dip new-imm-insn ; inline
+    ] dip
+    over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
 
 M: ##add-imm rewrite*
     {
@@ -185,8 +217,8 @@ M: ##add-imm rewrite*
     } cond ;
 
 : sub-imm>add-imm ( insn -- insn' )
-    dup [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
-    [ \ ##add-imm new-insn nip ] [ 2drop 2drop f ] if ;
+    [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
+    [ \ ##add-imm new-insn ] [ 3drop f ] if ;
 
 M: ##sub-imm rewrite*
     {
@@ -247,12 +279,11 @@ M: ##sar-imm rewrite*
         [ drop f ]
     } cond ;
 
-:: insn>imm-insn ( insn op swap? -- )
-    insn
-    insn dst>>
-    insn src1>>
-    insn src2>> swap? [ swap ] when vreg>constant
-    op new-imm-insn ; inline
+: insn>imm-insn ( insn op swap? -- )
+    swap [
+        [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
+        [ swap ] when vreg>constant
+    ] dip new-insn ; inline
 
 : rewrite-arithmetic ( insn op -- ? )
     {
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 6ed0a74da5..e808220716 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -2,7 +2,7 @@ IN: compiler.cfg.value-numbering.tests
 USING: compiler.cfg.value-numbering compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
 cpu.architecture tools.test kernel math combinators.short-circuit
-accessors sequences compiler.cfg vectors arrays layouts ;
+accessors sequences compiler.cfg vectors arrays layouts namespaces ;
 
 : trim-temps ( insns -- insns )
     [
@@ -17,6 +17,55 @@ accessors sequences compiler.cfg vectors arrays layouts ;
     { } init-value-numbering
     value-numbering-step ;
 
+! Folding constants together
+[
+    {
+        T{ ##load-reference f V int-regs 0 0.0 }
+        T{ ##load-reference f V int-regs 1 -0.0 }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 1 D 1 }
+    }
+] [
+    {
+        T{ ##load-reference f V int-regs 0 0.0 }
+        T{ ##load-reference f V int-regs 1 -0.0 }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 1 D 1 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-reference f V int-regs 0 0.0 }
+        T{ ##load-reference f V int-regs 1 0.0 }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 0 D 1 }
+    }
+] [
+    {
+        T{ ##load-reference f V int-regs 0 0.0 }
+        T{ ##load-reference f V int-regs 1 0.0 }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 1 D 1 }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-reference f V int-regs 0 t }
+        T{ ##load-reference f V int-regs 1 t }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 0 D 1 }
+    }
+] [
+    {
+        T{ ##load-reference f V int-regs 0 t }
+        T{ ##load-reference f V int-regs 1 t }
+        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##replace f V int-regs 1 D 1 }
+    } test-value-numbering
+] unit-test
+
 ! Copy propagation
 [
     {
@@ -805,4 +854,157 @@ cell 8 = [
             T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
         } test-value-numbering
     ] unit-test
-] when
\ No newline at end of file
+
+    [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 2 140737488355328 }
+            T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+        }
+    ] [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 2 140737488355328 }
+            T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+        } test-value-numbering
+    ] unit-test
+
+    [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 2 2147483647 }
+            T{ ##add-imm f V int-regs 3 V int-regs 0 2147483647 }
+            T{ ##add-imm f V int-regs 4 V int-regs 3 2147483647 }
+        }
+    ] [
+        {
+            T{ ##peek f V int-regs 0 D 0 }
+            T{ ##load-immediate f V int-regs 2 2147483647 }
+            T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+            T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
+        } test-value-numbering
+    ] unit-test
+] when
+
+! Branch folding
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##load-immediate f V int-regs 3 5 }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##load-reference f V int-regs 3 t }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc/= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##load-reference f V int-regs 3 t }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc< }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##load-immediate f V int-regs 3 5 }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare f V int-regs 3 V int-regs 2 V int-regs 1 cc< }
+    } test-value-numbering
+] unit-test
+
+: test-branch-folding ( insns -- insns' )
+    <basic-block>
+    [ V{ 0 1 } clone >>successors basic-block set test-value-numbering ] keep
+    successors>> first ;
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##branch }
+    }
+    1
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare-branch f V int-regs 1 V int-regs 2 cc= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare-branch f V int-regs 1 V int-regs 2 cc/= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare-branch f V int-regs 1 V int-regs 2 cc< }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##branch }
+    }
+    1
+] [
+    {
+        T{ ##load-immediate f V int-regs 1 1 }
+        T{ ##load-immediate f V int-regs 2 2 }
+        T{ ##compare-branch f V int-regs 2 V int-regs 1 cc< }
+    } test-branch-folding
+] unit-test
+

From a75d558b300391e391dd40c94446e870b8c803fd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 14 Jul 2009 19:18:57 -0500
Subject: [PATCH 27/31] compiler.cfg.intrinsics.fixnum: don't generate -imm
 forms anymore since value numbering does it

---
 .../cfg/intrinsics/fixnum/fixnum.factor       | 61 +++----------------
 .../compiler/cfg/intrinsics/intrinsics.factor | 22 +++----
 2 files changed, 18 insertions(+), 65 deletions(-)

diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index b360eed80b..2a82139e13 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -1,7 +1,7 @@
 ! 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
+combinators fry
 compiler.tree.propagation.info
 compiler.cfg.hats
 compiler.cfg.stacks
@@ -21,32 +21,8 @@ IN: compiler.cfg.intrinsics.fixnum
 : 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
-
-:: 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-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) ]
-        } cond
-        ds-push
-    ] ; inline
+: emit-fixnum-op ( insn -- dst )
+    [ 2inputs ] dip call ds-push ; inline
 
 : emit-fixnum-shift-fast ( node -- )
     dup node-input-infos dup second value-info-small-fixnum? [
@@ -66,34 +42,11 @@ IN: compiler.cfg.intrinsics.fixnum
 : emit-fixnum-log2 ( -- )
     ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
 
-: (emit-fixnum*fast) ( -- dst )
-    2inputs ^^untag-fixnum ^^mul ;
+: emit-fixnum*fast ( -- )
+    2inputs ^^untag-fixnum ^^mul ds-push ;
 
-: (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 first value-info-small-fixnum? drop f
-    [
-        (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 )
-    [ ^^compare ] [ ^^compare-imm ] bi-curry ; inline
-
-: emit-eq ( node -- )
-    cc= (emit-fixnum-comparison) emit-commutative-fixnum-op ;
-
-: emit-fixnum-comparison ( node cc -- )
-    (emit-fixnum-comparison) emit-fixnum-op ;
+: emit-fixnum-comparison ( cc -- )
+    '[ _ ^^compare ] 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 5283581bdd..ed94ec36d9 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -103,20 +103,20 @@ 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-commutative-fixnum-op ] }
-        { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-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+fast [ drop [ ^^add ] emit-fixnum-op ] }
+        { \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitxor [ drop [ ^^xor ] 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? [ emit-eq ] }
+        { \ math.private:fixnum*fast [ drop emit-fixnum*fast ] }
+        { \ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
+        { \ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
+        { \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
+        { \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
+        { \ kernel:eq? [ drop 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 ] }

From 11731f8d485675b6eff6cf18c060256f9cb06a78 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 14 Jul 2009 20:05:01 -0500
Subject: [PATCH 28/31] compiler.cfg.value-numbering: merge in
 compiler.cfg.branch-folding

---
 .../branch-folding-tests.factor               |  89 ------
 .../cfg/branch-folding/branch-folding.factor  |  33 ---
 basis/compiler/cfg/optimizer/optimizer.factor |   2 -
 .../value-numbering/rewrite/rewrite.factor    |  55 +++-
 .../value-numbering-tests.factor              | 263 +++++++++++++++++-
 .../value-numbering/value-numbering.factor    |   2 +
 basis/compiler/tests/codegen.factor           |   5 +-
 7 files changed, 309 insertions(+), 140 deletions(-)
 delete mode 100644 basis/compiler/cfg/branch-folding/branch-folding-tests.factor
 delete mode 100644 basis/compiler/cfg/branch-folding/branch-folding.factor

diff --git a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor b/basis/compiler/cfg/branch-folding/branch-folding-tests.factor
deleted file mode 100644
index 1d43ea0af3..0000000000
--- a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor
+++ /dev/null
@@ -1,89 +0,0 @@
-IN: compiler.cfg.branch-folding.tests
-USING: compiler.cfg.branch-folding compiler.cfg.instructions
-compiler.cfg compiler.cfg.registers compiler.cfg.debugger
-arrays compiler.cfg.phi-elimination compiler.cfg.dce
-compiler.cfg.predecessors compiler.cfg.comparisons
-kernel accessors assocs sequences classes namespaces
-tools.test cpu.architecture ;
-
-V{ T{ ##branch } } 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
-} 1 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 1 1 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 2 2 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##phi f V int-regs 3 { } }
-    T{ ##replace f V int-regs 3 D 0 }
-    T{ ##return }
-} 4 test-bb
-
-4 get instructions>> first
-2 get V int-regs 1 2array
-3 get V int-regs 2 2array 2array
->>inputs drop
-
-test-diamond
-
-[ ] [ cfg new 0 get >>entry fold-branches compute-predecessors eliminate-phis drop ] unit-test
-
-[ 1 ] [ 1 get successors>> length ] unit-test
-[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
-
-[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
-[ 3 get successors>> first instructions>> first ]
-unit-test
-
-[ 2 ] [ 4 get instructions>> length ] unit-test
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 1 D 1 }
-    T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
-} 1 test-bb
-
-V{
-    T{ ##copy f V int-regs 2 V int-regs 0 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##phi f V int-regs 3 V{ } }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##replace f V int-regs 3 D 0 }
-    T{ ##return }
-} 4 test-bb
-
-1 get V int-regs 1 2array
-2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
-
-test-diamond
-
-[ ] [
-    cfg new 0 get >>entry
-    compute-predecessors
-    fold-branches
-    compute-predecessors
-    eliminate-dead-code
-    drop
-] unit-test
-
-[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/branch-folding/branch-folding.factor b/basis/compiler/cfg/branch-folding/branch-folding.factor
deleted file mode 100644
index 04842552b7..0000000000
--- a/basis/compiler/cfg/branch-folding/branch-folding.factor
+++ /dev/null
@@ -1,33 +0,0 @@
-! 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.comparisons
-compiler.cfg.rpo
-compiler.cfg ;
-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
-    cfg-changed ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 5b0892a0ee..e16fb734e1 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -9,7 +9,6 @@ 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
@@ -36,7 +35,6 @@ SYMBOL: check-optimizer?
         compute-liveness
         alias-analysis
         value-numbering
-        fold-branches
         compute-predecessors
         eliminate-dead-code
         eliminate-write-barriers
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 5dd8884a89..3f7173c355 100755
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -98,18 +98,31 @@ M: ##compare-imm rewrite-tagged-comparison
     } case
     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 
+ERROR: bad-comparison ;
+
 : (fold-compare-imm) ( insn -- ? )
     [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi
-    pick integer? [ [ <=> ] dip evaluate-cc ] [ 3drop f ] if ;
+    pick integer?
+    [ [ <=> ] dip evaluate-cc ]
+    [
+        2nip {
+            { cc= [ f ] }
+            { cc/= [ t ] }
+            [ bad-comparison ]
+        } case
+    ] if ;
 
 : fold-compare-imm? ( insn -- ? )
     src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
 
-: fold-compare-imm-branch ( insn -- insn/f )
-    (fold-compare-imm) 0 1 ?
+: fold-branch ( ? -- insn )
+    0 1 ?
     basic-block get [ nth 1vector ] change-successors drop
     \ ##branch new-insn ;
 
+: fold-compare-imm-branch ( insn -- insn/f )
+    (fold-compare-imm) fold-branch ;
+
 M: ##compare-imm-branch rewrite*
     {
         { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
@@ -132,10 +145,20 @@ M: ##compare-imm-branch rewrite*
     [ vreg>constant ] dip
     \ ##compare-imm-branch new-insn ; inline
 
+: self-compare? ( insn -- ? )
+    [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
+
+: (rewrite-self-compare) ( insn -- ? )
+    cc>> { cc= cc<= cc>= } memq? ;
+
+: rewrite-self-compare-branch ( insn -- insn' )
+    (rewrite-self-compare) fold-branch ;
+
 M: ##compare-branch rewrite*
     {
         { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
         { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
+        { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
         [ drop f ]
     } cond ;
 
@@ -152,21 +175,27 @@ M: ##compare-branch rewrite*
     [ vreg>constant ] dip
     i \ ##compare-imm new-insn ; inline
 
-M: ##compare rewrite*
-    {
-        { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
-        { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
-        [ drop f ]
-    } cond ;
-
-: fold-compare-imm ( insn -- )
-    [ dst>> ]
-    [ (fold-compare-imm) ] bi
+: >boolean-insn ( insn ? -- insn' )
+    [ dst>> ] dip
     {
         { t [ t \ ##load-reference new-insn ] }
         { f [ \ f tag-number \ ##load-immediate new-insn ] }
     } case ;
 
+: rewrite-self-compare ( insn -- insn' )
+    dup (rewrite-self-compare) >boolean-insn ;
+
+M: ##compare rewrite*
+    {
+        { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
+        { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
+        { [ dup self-compare? ] [ rewrite-self-compare ] }
+        [ drop f ]
+    } cond ;
+
+: fold-compare-imm ( insn -- insn' )
+    dup (fold-compare-imm) >boolean-insn ;
+
 M: ##compare-imm rewrite*
     {
         { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index e808220716..60d23cefb7 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -2,7 +2,9 @@ IN: compiler.cfg.value-numbering.tests
 USING: compiler.cfg.value-numbering compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
 cpu.architecture tools.test kernel math combinators.short-circuit
-accessors sequences compiler.cfg vectors arrays layouts namespaces ;
+accessors sequences compiler.cfg.predecessors
+compiler.cfg.phi-elimination compiler.cfg.dce compiler.cfg.liveness
+compiler.cfg assocs vectors arrays layouts namespaces ;
 
 : trim-temps ( insns -- insns )
     [
@@ -943,7 +945,79 @@ cell 8 = [
     } test-value-numbering
 ] unit-test
 
-: test-branch-folding ( insns -- insns' )
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 5 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc< }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-reference f V int-regs 1 t }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 5 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc> }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-reference f V int-regs 1 t }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc>= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-immediate f V int-regs 1 5 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc/= }
+    } test-value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-reference f V int-regs 1 t }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc= }
+    } test-value-numbering
+] unit-test
+
+: test-branch-folding ( insns -- insns' n )
     <basic-block>
     [ V{ 0 1 } clone >>successors basic-block set test-value-numbering ] keep
     successors>> first ;
@@ -1008,3 +1082,188 @@ cell 8 = [
     } test-branch-folding
 ] unit-test
 
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    1
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc<= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    1
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc> }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc>= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##branch }
+    }
+    1
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare-branch f V int-regs 0 V int-regs 0 cc/= }
+    } test-branch-folding
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##load-reference f V int-regs 1 t }
+        T{ ##branch }
+    }
+    0
+] [
+    {
+        T{ ##peek f V int-regs 0 D 0 }
+        T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
+        T{ ##compare-imm-branch f V int-regs 1 5 cc/= }
+    } test-branch-folding
+] unit-test
+
+! More branch folding tests
+V{ T{ ##branch } } 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+} 1 test-bb
+
+V{
+    T{ ##load-immediate f V int-regs 1 1 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##load-immediate f V int-regs 2 2 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##phi f V int-regs 3 { } }
+    T{ ##replace f V int-regs 3 D 0 }
+    T{ ##return }
+} 4 test-bb
+
+4 get instructions>> first
+2 get V int-regs 1 2array
+3 get V int-regs 2 2array 2array
+>>inputs drop
+
+test-diamond
+
+[ ] [
+    cfg new 0 get >>entry
+    compute-liveness
+    value-numbering
+    compute-predecessors
+    eliminate-phis drop
+] unit-test
+
+[ 1 ] [ 1 get successors>> length ] unit-test
+
+[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
+
+[ T{ ##copy f V int-regs 3 V int-regs 2 } ]
+[ 3 get successors>> first instructions>> first ]
+unit-test
+
+[ 2 ] [ 4 get instructions>> length ] unit-test
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
+} 1 test-bb
+
+V{
+    T{ ##copy f V int-regs 2 V int-regs 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f V int-regs 3 V{ } }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f V int-regs 3 D 0 }
+    T{ ##return }
+} 4 test-bb
+
+1 get V int-regs 1 2array
+2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
+
+test-diamond
+
+[ ] [
+    cfg new 0 get >>entry
+    compute-predecessors
+    compute-liveness
+    value-numbering
+    compute-predecessors
+    eliminate-dead-code
+    drop
+] unit-test
+
+[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
+
+[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index 9e6e058b52..202b3d1e9b 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -11,6 +11,8 @@ compiler.cfg.value-numbering.simplify
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering
 
+! Local value numbering. Predecessors must be recomputed after this
+
 : number-input-values ( live-in -- )
     [ [ f next-input-expr simplify ] dip set-vn ] each ;
 
diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor
index 8f7bc077b4..9f573019c2 100644
--- a/basis/compiler/tests/codegen.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -318,4 +318,7 @@ M: cucumber equal? "The cucumber has no equal" throw ;
 
 cell 4 = [
     [ 0 ] [ 101 [ dup fixnum-fast 1 fixnum+fast 20 fixnum-shift-fast 20 fixnum-shift-fast ] compile-call ] unit-test
-] when
\ No newline at end of file
+] when
+
+! Regression from Slava's value numbering changes
+[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
\ No newline at end of file

From 4ac74e93041d8f4d5340da3e178472267131a0aa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 14 Jul 2009 20:42:50 -0500
Subject: [PATCH 29/31] compiler.cfg.branch-splitting: don't split if there's
 one predecessor

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

diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
index 0dd963125f..9d6e59e4da 100644
--- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor
+++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
@@ -65,15 +65,15 @@ UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
 : split-instructions? ( insns -- ? )
     [ irrelevant? not ] count 5 <= ;
 
-: split-branches? ( bb -- ? )
+: split-branch? ( bb -- ? )
     {
         [ dup successors>> [ back-edge? ] with any? not ]
-        [ predecessors>> length 1 4 between? ]
+        [ predecessors>> length 2 4 between? ]
         [ instructions>> split-instructions? ]
     } 1&& ;
 
 : split-branches ( cfg -- cfg' )
     dup [
-        dup split-branches? [ split-branch ] [ drop ] if
+        dup split-branch? [ split-branch ] [ drop ] if
     ] each-basic-block
     cfg-changed ;

From ebcd0dc2520f99409573ecd36bd9ca3ee6b9684e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 14 Jul 2009 20:43:06 -0500
Subject: [PATCH 30/31] compiler.cfg: Fix regressions from recent changes

---
 .../stack-analysis-tests.factor               |  4 +-
 .../value-numbering-tests.factor              | 67 ++++++++++++++++++-
 .../value-numbering/value-numbering.factor    |  4 +-
 3 files changed, 71 insertions(+), 4 deletions(-)

diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index 23b1098cd6..9fbf7acf78 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -91,9 +91,9 @@ IN: compiler.cfg.stack-analysis.tests
 ! Sync before a back-edge, not after
 ! ##peeks should be inserted before a ##loop-entry
 ! Don't optimize out the constants
-[ 1 t ] [
+[ t ] [
     [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
-    [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
+    [ ##load-immediate? ] any?
 ] unit-test
 
 ! Correct height tracking
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 60d23cefb7..4c431b8a5c 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -1266,4 +1266,69 @@ test-diamond
 
 [ t ] [ 1 get successors>> first 3 get eq? ] unit-test
 
-[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test
\ No newline at end of file
+[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test
+
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+
+V{
+    T{ ##peek { dst V int-regs 15 } { loc D 0 } }
+    T{ ##copy { dst V int-regs 16 } { src V int-regs 15 } }
+    T{ ##copy { dst V int-regs 17 } { src V int-regs 15 } }
+    T{ ##copy { dst V int-regs 18 } { src V int-regs 15 } }
+    T{ ##copy { dst V int-regs 19 } { src V int-regs 15 } }
+    T{ ##compare
+        { dst V int-regs 20 }
+        { src1 V int-regs 18 }
+        { src2 V int-regs 19 }
+        { cc cc= }
+        { temp V int-regs 22 }
+    }
+    T{ ##copy { dst V int-regs 21 } { src V int-regs 20 } }
+    T{ ##compare-imm-branch
+        { src1 V int-regs 21 }
+        { src2 5 }
+        { cc cc/= }
+    }
+} 1 test-bb
+
+V{
+    T{ ##copy { dst V int-regs 23 } { src V int-regs 15 } }
+    T{ ##copy { dst V int-regs 24 } { src V int-regs 15 } }
+    T{ ##load-reference { dst V int-regs 25 } { obj t } }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##replace { src V int-regs 25 } { loc D 0 } }
+    T{ ##epilogue }
+    T{ ##return }
+} 3 test-bb
+
+V{
+    T{ ##copy { dst V int-regs 26 } { src V int-regs 15 } }
+    T{ ##copy { dst V int-regs 27 } { src V int-regs 15 } }
+    T{ ##add
+        { dst V int-regs 28 }
+        { src1 V int-regs 26 }
+        { src2 V int-regs 27 }
+    }
+    T{ ##branch }
+} 4 test-bb
+
+V{
+    T{ ##replace { src V int-regs 28 } { loc D 0 } }
+    T{ ##epilogue }
+    T{ ##return }
+} 5 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 4 get V{ } 2sequence >>successors drop
+2 get 3 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+
+[ ] [
+    cfg new 0 get >>entry
+    compute-liveness value-numbering eliminate-dead-code drop
+] unit-test
+
+[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index 202b3d1e9b..e49555e06e 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs biassocs classes kernel math accessors
 sorting sets sequences fry
+compiler.cfg
 compiler.cfg.local
 compiler.cfg.liveness
 compiler.cfg.renaming
@@ -34,4 +35,5 @@ IN: compiler.cfg.value-numbering
     [ rewrite ] map dup rename-uses ;
 
 : value-numbering ( cfg -- cfg' )
-    [ init-value-numbering ] [ value-numbering-step ] local-optimization ;
+    [ init-value-numbering ] [ value-numbering-step ] local-optimization
+    cfg-changed ;

From b7dd3d5d35573513ab28cd00c4d6b3557b57fd14 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 15 Jul 2009 13:53:57 -0500
Subject: [PATCH 31/31] report opengl function name in gl-errors

---
 basis/opengl/opengl.factor | 13 ++++++++-----
 1 file changed, 8 insertions(+), 5 deletions(-)
 mode change 100644 => 100755 basis/opengl/opengl.factor

diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
old mode 100644
new mode 100755
index 7884890ebf..196293adc9
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -30,7 +30,7 @@ IN: opengl
         { HEX: 0506 "Invalid framebuffer operation" }
     } at "Unknown error" or ;
 
-TUPLE: gl-error code string ;
+TUPLE: gl-error function code string ;
 
 TUPLE: gl-error-log
     { function word initial: t }
@@ -39,17 +39,20 @@ TUPLE: gl-error-log
 
 gl-error-log [ V{ } clone ] initialize
 
-: <gl-error> ( code -- gl-error )
+: <gl-error> ( function code -- gl-error )
     dup error>string \ gl-error boa ; inline
 
 : <gl-error-log> ( function code -- gl-error-log )
-    <gl-error> now gl-error-log boa ;
+    [ dup ] dip <gl-error> now gl-error-log boa ;
 
 : gl-error-code ( -- code/f )
     glGetError dup 0 = [ drop f ] when ; inline
 
+: (gl-error) ( function -- )
+    gl-error-code [ <gl-error> throw ] [ drop ] if* ;
+
 : gl-error ( -- )
-    gl-error-code [ <gl-error> throw ] [ ] if* ;
+    f (gl-error) ; inline
 
 : log-gl-error ( function -- )
     gl-error-code [ <gl-error-log> gl-error-log get push ] [ drop ] if* ;
@@ -72,7 +75,7 @@ gl-error-log [ V{ } clone ] initialize
     V{ } clone gl-error-log set ;
 
 : throw-gl-errors ( -- )
-    [ drop '[ @ gl-error ] ] annotate-gl-functions ;
+    [ '[ @ _ (gl-error) ] ] annotate-gl-functions ;
 
 : log-gl-errors ( -- )
     [ '[ @ _ log-gl-error ] ] annotate-gl-functions ;