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/30] 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/30] 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 8281c2fb55c3a7652051f8f0361a8dc4fa375203 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Fri, 10 Jul 2009 12:45:27 +1200
Subject: [PATCH 03/30] alien.inline.compile: write library files to
 resource:alien-inline-libs

---
 basis/alien/inline/compiler/compiler.factor | 15 ++++++++++-----
 basis/alien/inline/inline.factor            |  2 +-
 2 files changed, 11 insertions(+), 6 deletions(-)

diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor
index b1ccc2baab..d049668eec 100644
--- a/basis/alien/inline/compiler/compiler.factor
+++ b/basis/alien/inline/compiler/compiler.factor
@@ -2,12 +2,19 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators fry generalizations
 io.encodings.ascii io.files io.files.temp io.launcher kernel
-locals make sequences system vocabs.parser words ;
+locals make sequences system vocabs.parser words io.directories
+io.pathnames ;
 IN: alien.inline.compiler
 
 SYMBOL: C
 SYMBOL: C++
 
+: inline-libs-directory ( -- path )
+    "alien-inline-libs" resource-path dup make-directories ;
+
+: inline-library-file ( name -- path )
+    inline-libs-directory prepend-path ;
+
 : library-suffix ( -- str )
     os {
         { [ dup macosx? ]  [ drop ".dylib" ] }
@@ -16,10 +23,8 @@ SYMBOL: C++
     } cond ;
 
 : library-path ( str -- str' )
-    '[
-        "lib-" % current-vocab name>> %
-        "-" % _ % library-suffix %
-    ] "" make temp-file ;
+    '[ "lib" % "-" % _ % library-suffix % ]
+    "" make inline-library-file ;
 
 : src-suffix ( lang -- str )
     {
diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor
index 88cc5e3519..8ec0952c5a 100644
--- a/basis/alien/inline/inline.factor
+++ b/basis/alien/inline/inline.factor
@@ -58,7 +58,7 @@ SYMBOL: c-strings
 PRIVATE>
 
 : define-c-library ( name -- )
-    c-library set
+    [ current-vocab name>> % "_" % % ] "" make c-library set
     V{ } clone c-strings set
     V{ } clone compiler-args set ;
 

From 59f0dbb5167a66aa95bbb164438ef4ed6ff690f6 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Fri, 10 Jul 2009 13:14:43 +1200
Subject: [PATCH 04/30] alien.inline: fix library name and us remove-library

---
 basis/alien/inline/compiler/compiler.factor | 3 +--
 basis/alien/inline/inline.factor            | 8 ++++++--
 2 files changed, 7 insertions(+), 4 deletions(-)

diff --git a/basis/alien/inline/compiler/compiler.factor b/basis/alien/inline/compiler/compiler.factor
index d049668eec..d7d2d6fc43 100644
--- a/basis/alien/inline/compiler/compiler.factor
+++ b/basis/alien/inline/compiler/compiler.factor
@@ -23,8 +23,7 @@ SYMBOL: C++
     } cond ;
 
 : library-path ( str -- str' )
-    '[ "lib" % "-" % _ % library-suffix % ]
-    "" make inline-library-file ;
+    '[ "lib" % _ % library-suffix % ] "" make temp-file ;
 
 : src-suffix ( lang -- str )
     {
diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor
index 8ec0952c5a..20ccd43e5c 100644
--- a/basis/alien/inline/inline.factor
+++ b/basis/alien/inline/inline.factor
@@ -55,10 +55,13 @@ SYMBOL: c-strings
     compiler-args get
     c-strings get "\n" join
     c-library get compile-to-library ;
+
+: c-library-name ( name -- name' )
+    [ current-vocab name>> % "_" % % ] "" make ;
 PRIVATE>
 
 : define-c-library ( name -- )
-    [ current-vocab name>> % "_" % % ] "" make c-library set
+    c-library-name c-library set
     V{ } clone c-strings set
     V{ } clone compiler-args set ;
 
@@ -104,7 +107,8 @@ PRIVATE>
     ] 3bi ;
 
 : delete-inline-library ( str -- )
-    library-path dup exists? [ delete-file ] [ drop ] if ;
+    c-library-name [ remove-library ]
+    [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
 
 SYNTAX: C-LIBRARY: scan define-c-library ;
 

From d02854b04ebc74a06f3b7381cd2b4676d36e36d8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 9 Jul 2009 23:12:49 -0500
Subject: [PATCH 05/30] compiler.cfg.linear-scan: two live intervals which are
 coalesced will use the same spill slot

---
 .../allocation/spilling/spilling.factor            |  4 ++--
 .../cfg/linear-scan/allocation/state/state.factor  | 14 ++++++++++++--
 .../cfg/linear-scan/assignment/assignment.factor   |  2 +-
 3 files changed, 15 insertions(+), 5 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
index b89c1f4de2..8c91ca7f60 100644
--- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
@@ -38,10 +38,10 @@ ERROR: bad-live-ranges interval ;
     } 2cleave ;
 
 : assign-spill ( live-interval -- )
-    dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ;
+    dup assign-spill-slot >>spill-to f >>split-next drop ;
 
 : assign-reload ( live-interval -- )
-    dup vreg>> assign-spill-slot >>reload-from drop ;
+    dup assign-spill-slot >>reload-from drop ;
 
 : split-and-spill ( live-interval n -- before after )
     split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
index 3e646b40f0..1e670ad6a6 100644
--- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
@@ -126,8 +126,18 @@ SYMBOL: spill-counts
 ! Mapping from vregs to spill slots
 SYMBOL: spill-slots
 
-: assign-spill-slot ( vreg -- n )
-    spill-slots get [ reg-class>> next-spill-slot ] cache ;
+DEFER: assign-spill-slot
+
+: compute-spill-slot ( live-interval -- n )
+    dup copy-from>>
+    [ assign-spill-slot ]
+    [ vreg>> reg-class>> next-spill-slot ] ?if ;
+
+: assign-spill-slot ( live-interval -- n )
+    dup vreg>> spill-slots get at [ ] [
+        [ compute-spill-slot dup ] keep
+        vreg>> spill-slots get set-at
+    ] ?if ;
 
 : init-allocator ( registers -- )
     registers set
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 143e84aaf4..9275c6d687 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -107,7 +107,7 @@ SYMBOL: check-assignment?
 ERROR: overlapping-registers intervals ;
 
 : check-assignment ( intervals -- )
-    dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
+    dup [ copy-from>> ] map sift [ vreg>> ] map '[ vreg>> _ member? not ] filter
     dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
 
 : active-intervals ( n -- intervals )

From 6810b922eeea59f05893925e7cccc5c7433037a9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 9 Jul 2009 23:13:30 -0500
Subject: [PATCH 06/30] compiler.cfg: move back-edge? word from stack-analysis
 to top-level vocab

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

diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 68d7e15a5d..12a1180d40 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -48,6 +48,9 @@ SYMBOL: visited
         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 ;
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index fb71fe332d..ab16bbea44 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -60,9 +60,6 @@ UNION: sync-if-back-edge
     ##dispatch
     ##loop-entry ;
 
-: back-edge? ( from to -- ? )
-    [ number>> ] bi@ > ;
-
 : sync-state? ( -- ? )
     basic-block get successors>>
     [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;

From 789d82745c2dccb065aa6123843a7f507133ce3c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 9 Jul 2009 23:14:26 -0500
Subject: [PATCH 07/30] compiler.cfg.value-numbering: factor out value renaming
 into a separate compiler.cfg.renaming vocabulary

---
 basis/compiler/cfg/renaming/renaming.factor   | 151 ++++++++++++++++++
 .../propagate/propagate.factor                |  69 --------
 .../cfg/value-numbering/propagate/summary.txt |   1 -
 .../value-numbering/value-numbering.factor    |  18 ++-
 4 files changed, 165 insertions(+), 74 deletions(-)
 create mode 100644 basis/compiler/cfg/renaming/renaming.factor
 delete mode 100644 basis/compiler/cfg/value-numbering/propagate/propagate.factor
 delete mode 100644 basis/compiler/cfg/value-numbering/propagate/summary.txt

diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor
new file mode 100644
index 0000000000..4a8c6e6a4d
--- /dev/null
+++ b/basis/compiler/cfg/renaming/renaming.factor
@@ -0,0 +1,151 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel namespaces sequences
+compiler.cfg.instructions compiler.cfg.registers ;
+IN: compiler.cfg.renaming
+
+SYMBOL: renamings
+
+: rename-value ( vreg -- vreg' ) renamings get at ;
+
+GENERIC: rename-insn-defs ( insn -- )
+
+M: ##flushable rename-insn-defs
+    [ rename-value ] change-dst
+    drop ;
+
+M: insn rename-insn-defs drop ;
+
+GENERIC: rename-insn-uses ( insn -- )
+
+M: ##effect rename-insn-uses
+    [ rename-value ] change-src
+    drop ;
+
+M: ##unary rename-insn-uses
+    [ rename-value ] change-src
+    drop ;
+
+M: ##binary rename-insn-uses
+    [ rename-value ] change-src1
+    [ rename-value ] change-src2
+    drop ;
+
+M: ##binary-imm rename-insn-uses
+    [ rename-value ] change-src1
+    drop ;
+
+M: ##slot rename-insn-uses
+    [ rename-value ] change-obj
+    [ rename-value ] change-slot
+    drop ;
+
+M: ##slot-imm rename-insn-uses
+    [ rename-value ] change-obj
+    drop ;
+
+M: ##set-slot rename-insn-uses
+    dup call-next-method
+    [ rename-value ] change-obj
+    [ rename-value ] change-slot
+    drop ;
+
+M: ##string-nth rename-insn-uses
+    [ rename-value ] change-obj
+    [ rename-value ] change-index
+    drop ;
+
+M: ##set-slot-imm rename-insn-uses
+    dup call-next-method
+    [ rename-value ] change-obj
+    drop ;
+
+M: ##alien-getter rename-insn-uses
+    dup call-next-method
+    [ rename-value ] change-src
+    drop ;
+
+M: ##alien-setter rename-insn-uses
+    dup call-next-method
+    [ rename-value ] change-value
+    drop ;
+
+M: ##conditional-branch rename-insn-uses
+    [ rename-value ] change-src1
+    [ rename-value ] change-src2
+    drop ;
+
+M: ##compare-imm-branch rename-insn-uses
+    [ rename-value ] change-src1
+    drop ;
+
+M: ##dispatch rename-insn-uses
+    [ rename-value ] change-src
+    drop ;
+
+M: ##fixnum-overflow rename-insn-uses
+    [ rename-value ] change-src1
+    [ rename-value ] change-src2
+    drop ;
+
+M: insn rename-insn-uses drop ;
+
+: fresh-vreg ( vreg -- vreg' )
+    reg-class>> next-vreg ;
+
+GENERIC: fresh-insn-temps ( insn -- )
+
+M: ##write-barrier fresh-insn-temps
+    [ fresh-vreg ] change-card#
+    [ fresh-vreg ] change-table
+    drop ;
+
+M: ##unary/temp fresh-insn-temps
+    [ fresh-vreg ] change-temp drop ;
+
+M: ##allot fresh-insn-temps
+    [ fresh-vreg ] change-temp drop ;
+
+M: ##dispatch fresh-insn-temps
+    [ fresh-vreg ] change-temp drop ;
+
+M: ##slot fresh-insn-temps
+    [ fresh-vreg ] change-temp drop ;
+
+M: ##set-slot fresh-insn-temps
+    [ fresh-vreg ] change-temp drop ;
+
+M: ##string-nth fresh-insn-temps
+    [ fresh-vreg ] change-temp drop ;
+
+M: ##set-string-nth-fast fresh-insn-temps
+    [ fresh-vreg ] change-temp drop ;
+
+M: ##compare fresh-insn-temps
+    [ fresh-vreg ] change-temp drop ;
+
+M: ##compare-imm fresh-insn-temps
+    [ fresh-vreg ] change-temp drop ;
+
+M: ##compare-float fresh-insn-temps
+    [ fresh-vreg ] change-temp drop ;
+
+M: ##fixnum-mul fresh-insn-temps
+    [ fresh-vreg ] change-temp1
+    [ fresh-vreg ] change-temp2
+    drop ;
+
+M: ##fixnum-mul-tail fresh-insn-temps
+    [ fresh-vreg ] change-temp1
+    [ fresh-vreg ] change-temp2
+    drop ;
+
+M: ##gc fresh-insn-temps
+    [ fresh-vreg ] change-temp1
+    [ fresh-vreg ] change-temp2
+    drop ;
+
+M: _dispatch fresh-insn-temps
+    [ fresh-vreg ] change-temp drop ;
+
+M: insn fresh-insn-temps drop ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
deleted file mode 100644
index d5c9830c0b..0000000000
--- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor
+++ /dev/null
@@ -1,69 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs sequences kernel accessors
-compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
-IN: compiler.cfg.value-numbering.propagate
-
-! If two vregs compute the same value, replace references to
-! the latter with the former.
-
-: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline
-
-GENERIC: propagate ( insn -- insn )
-
-M: ##effect propagate
-    [ resolve ] change-src ;
-
-M: ##unary propagate
-    [ resolve ] change-src ;
-
-M: ##binary propagate
-    [ resolve ] change-src1
-    [ resolve ] change-src2 ;
-
-M: ##binary-imm propagate
-    [ resolve ] change-src1 ;
-
-M: ##slot propagate
-    [ resolve ] change-obj
-    [ resolve ] change-slot ;
-
-M: ##slot-imm propagate
-    [ resolve ] change-obj ;
-
-M: ##set-slot propagate
-    call-next-method
-    [ resolve ] change-obj
-    [ resolve ] change-slot ;
-
-M: ##string-nth propagate
-    [ resolve ] change-obj
-    [ resolve ] change-index ;
-
-M: ##set-slot-imm propagate
-    call-next-method
-    [ resolve ] change-obj ;
-
-M: ##alien-getter propagate
-    call-next-method
-    [ resolve ] change-src ;
-
-M: ##alien-setter propagate
-    call-next-method
-    [ resolve ] change-value ;
-
-M: ##conditional-branch propagate
-    [ resolve ] change-src1
-    [ resolve ] change-src2 ;
-
-M: ##compare-imm-branch propagate
-    [ resolve ] change-src1 ;
-
-M: ##dispatch propagate
-    [ resolve ] change-src ;
-
-M: ##fixnum-overflow propagate
-    [ resolve ] change-src1
-    [ resolve ] change-src2 ;
-
-M: insn propagate ;
diff --git a/basis/compiler/cfg/value-numbering/propagate/summary.txt b/basis/compiler/cfg/value-numbering/propagate/summary.txt
deleted file mode 100644
index fd56a8e099..0000000000
--- a/basis/compiler/cfg/value-numbering/propagate/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Propagation pass to update code after value numbering
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index 9f5473c62f..f0efa5dcca 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -1,12 +1,12 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs biassocs classes kernel math accessors
-sorting sets sequences
+sorting sets sequences fry
 compiler.cfg.local
 compiler.cfg.liveness
+compiler.cfg.renaming
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions
-compiler.cfg.value-numbering.propagate
 compiler.cfg.value-numbering.simplify
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering
@@ -19,8 +19,18 @@ IN: compiler.cfg.value-numbering
     init-expressions
     number-input-values ;
 
+: vreg>vreg-mapping ( -- assoc )
+    vregs>vns get [ keys ] keep
+    '[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ;
+
+: rename-uses ( insns -- )
+    vreg>vreg-mapping renamings [
+        [ rename-insn-uses ] each
+    ] with-variable ;
+
 : value-numbering-step ( insns -- insns' )
-    [ [ number-values ] [ rewrite propagate ] bi ] map ;
+    [ [ number-values ] [ rewrite ] bi ] map
+    dup rename-uses ;
 
 : value-numbering ( cfg -- cfg' )
     [ init-value-numbering ] [ value-numbering-step ] local-optimization ;

From dea872c7e3526b9df0bf9995d6084cdc9461de14 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Jul 2009 00:25:46 -0500
Subject: [PATCH 08/30] compiler.cfg.linear-scan.allocation: fix broken spill
 slot reuse logic

---
 .../allocation/coalescing/coalescing.factor       | 15 +++++++++++----
 .../allocation/spilling/spilling.factor           |  4 ++--
 .../cfg/linear-scan/allocation/state/state.factor | 14 ++------------
 3 files changed, 15 insertions(+), 18 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
index e99c2ba710..ef8a9c56f8 100644
--- a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences
+USING: accessors kernel sequences namespaces assocs fry
 combinators.short-circuit
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation.state ;
@@ -20,9 +20,16 @@ IN: compiler.cfg.linear-scan.allocation.coalescing
         [ avoids-inactive-intervals? ]
     } 1&& ;
 
+: reuse-spill-slot ( old new -- )
+    [ vreg>> spill-slots get at ] dip '[ _ vreg>> spill-slots get set-at ] when* ;
+
+: reuse-register ( old new -- )
+    reg>> >>reg drop ;
+
+: (coalesce) ( old new -- )
+    [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ;
+
 : coalesce ( live-interval -- )
     dup copy-from>> active-interval
-    [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
-    [ reg>> >>reg drop ]
-    2bi ;
+    [ reuse-spill-slot ] [ reuse-register ] [ (coalesce) ] 2tri ;
  
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
index 8c91ca7f60..b89c1f4de2 100644
--- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
@@ -38,10 +38,10 @@ ERROR: bad-live-ranges interval ;
     } 2cleave ;
 
 : assign-spill ( live-interval -- )
-    dup assign-spill-slot >>spill-to f >>split-next drop ;
+    dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ;
 
 : assign-reload ( live-interval -- )
-    dup assign-spill-slot >>reload-from drop ;
+    dup vreg>> assign-spill-slot >>reload-from drop ;
 
 : split-and-spill ( live-interval n -- before after )
     split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
index 1e670ad6a6..3e646b40f0 100644
--- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
@@ -126,18 +126,8 @@ SYMBOL: spill-counts
 ! Mapping from vregs to spill slots
 SYMBOL: spill-slots
 
-DEFER: assign-spill-slot
-
-: compute-spill-slot ( live-interval -- n )
-    dup copy-from>>
-    [ assign-spill-slot ]
-    [ vreg>> reg-class>> next-spill-slot ] ?if ;
-
-: assign-spill-slot ( live-interval -- n )
-    dup vreg>> spill-slots get at [ ] [
-        [ compute-spill-slot dup ] keep
-        vreg>> spill-slots get set-at
-    ] ?if ;
+: assign-spill-slot ( vreg -- n )
+    spill-slots get [ reg-class>> next-spill-slot ] cache ;
 
 : init-allocator ( registers -- )
     registers set

From 11347e784c1d2dc4c6c4a34de593ef3520683bad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Jul 2009 03:05:45 -0500
Subject: [PATCH 09/30] insn. doesn't print numbers

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

diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 60805124cd..e355ee2ac1 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -26,7 +26,7 @@ M: word test-cfg
     ] map ;
 
 : insn. ( insn -- )
-    tuple>array [ pprint bl ] each nl ;
+    tuple>array but-last [ pprint bl ] each nl ;
 
 : mr. ( mrs -- )
     [

From ae67de6f905ab393af3542b9821047683fe12063 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Jul 2009 03:58:51 -0500
Subject: [PATCH 10/30] compiler.cfg.linear-scan: fix fencepost error in spill
 insertion

---
 .../allocation/spilling/spilling.factor       |   2 +-
 .../linear-scan/assignment/assignment.factor  |   4 +-
 .../cfg/linear-scan/linear-scan-tests.factor  | 203 ++++++++++++++----
 3 files changed, 167 insertions(+), 42 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
index b89c1f4de2..14046a91f1 100644
--- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
@@ -17,7 +17,7 @@ ERROR: bad-live-ranges interval ;
     ] [ drop ] if ;
 
 : trim-before-ranges ( live-interval -- )
-    [ ranges>> ] [ uses>> last ] bi
+    [ ranges>> ] [ uses>> last 1 + ] bi
     [ '[ from>> _ <= ] filter-here ]
     [ swap last (>>to) ]
     2bi ;
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 9275c6d687..c0f90e5932 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -107,7 +107,7 @@ SYMBOL: check-assignment?
 ERROR: overlapping-registers intervals ;
 
 : check-assignment ( intervals -- )
-    dup [ copy-from>> ] map sift [ vreg>> ] map '[ vreg>> _ member? not ] filter
+    dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
     dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
 
 : active-intervals ( n -- intervals )
@@ -150,7 +150,7 @@ ERROR: bad-live-values live-values ;
 
 : begin-block ( bb -- )
     dup basic-block set
-    dup block-from prepare-insn
+    dup block-from activate-new-intervals
     [ [ live-in ] [ block-from ] bi compute-live-values ] keep
     register-live-ins get set-at ;
 
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 06817071d4..bc3061128c 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -82,9 +82,9 @@ check-numbering? on
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
        { start 0 }
-       { end 1 }
+       { end 2 }
        { uses V{ 0 1 } }
-       { ranges V{ T{ live-range f 0 1 } } }
+       { ranges V{ T{ live-range f 0 2 } } }
     }
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@@ -107,9 +107,9 @@ check-numbering? on
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
        { start 0 }
-       { end 0 }
+       { end 1 }
        { uses V{ 0 } }
-       { ranges V{ T{ live-range f 0 0 } } }
+       { ranges V{ T{ live-range f 0 1 } } }
     }
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@@ -132,9 +132,9 @@ check-numbering? on
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
        { start 0 }
-       { end 0 }
+       { end 1 }
        { uses V{ 0 } }
-       { ranges V{ T{ live-range f 0 0 } } }
+       { ranges V{ T{ live-range f 0 1 } } }
     }
     T{ live-interval
        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
@@ -1317,38 +1317,6 @@ USING: math.private ;
     allocate-registers drop
 ] unit-test
 
-! Spill slot liveness was computed incorrectly, leading to a FEP
-! early in bootstrap on x86-32
-[ t ] [
-    [
-        H{ } clone live-ins set
-        H{ } clone live-outs set
-        H{ } clone phi-live-ins set
-        T{ basic-block
-           { id 12345 }
-           { instructions
-             V{
-                 T{ ##gc f V int-regs 6 V int-regs 7 }
-                 T{ ##peek f V int-regs 0 D 0 }
-                 T{ ##peek f V int-regs 1 D 1 }
-                 T{ ##peek f V int-regs 2 D 2 }
-                 T{ ##peek f V int-regs 3 D 3 }
-                 T{ ##peek f V int-regs 4 D 4 }
-                 T{ ##peek f V int-regs 5 D 5 }
-                 T{ ##replace f V int-regs 0 D 1 }
-                 T{ ##replace f V int-regs 1 D 2 }
-                 T{ ##replace f V int-regs 2 D 3 }
-                 T{ ##replace f V int-regs 3 D 4 }
-                 T{ ##replace f V int-regs 4 D 5 }
-                 T{ ##replace f V int-regs 5 D 0 }
-             }
-           }
-        } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
-        instructions>> first
-        live-values>> assoc-empty?
-    ] with-scope
-] unit-test
-
 [ f ] [
     T{ live-range f 0 10 }
     T{ live-range f 20 30 }
@@ -2482,4 +2450,161 @@ V{
 7 get 9 get 1vector >>successors drop
 8 get 9 get 1vector >>successors drop
 
-[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
\ No newline at end of file
+[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
+
+! Fencepost error in assignment pass
+V{ T{ ##branch } } 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+} 1 test-bb
+
+V{ T{ ##branch } } 2 test-bb
+
+V{
+    T{ ##peek f V int-regs 1 D 0 }
+    T{ ##peek f V int-regs 2 D 0 }
+    T{ ##replace f V int-regs 1 D 0 }
+    T{ ##replace f V int-regs 2 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
+
+! Another test case for fencepost error in assignment pass
+V{ T{ ##branch } } 0 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+} 1 test-bb
+
+V{
+    T{ ##peek f V int-regs 1 D 0 }
+    T{ ##peek f V int-regs 2 D 0 }
+    T{ ##replace f V int-regs 1 D 0 }
+    T{ ##replace f V int-regs 2 D 0 }
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 2 get instructions>> [ _reload? ] count ] unit-test
+
+[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
+
+[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
+
+! GC check tests
+
+! Spill slot liveness was computed incorrectly, leading to a FEP
+! early in bootstrap on x86-32
+[ t ] [
+    [
+        H{ } clone live-ins set
+        H{ } clone live-outs set
+        H{ } clone phi-live-ins set
+        T{ basic-block
+           { id 12345 }
+           { instructions
+             V{
+                 T{ ##gc f V int-regs 6 V int-regs 7 }
+                 T{ ##peek f V int-regs 0 D 0 }
+                 T{ ##peek f V int-regs 1 D 1 }
+                 T{ ##peek f V int-regs 2 D 2 }
+                 T{ ##peek f V int-regs 3 D 3 }
+                 T{ ##peek f V int-regs 4 D 4 }
+                 T{ ##peek f V int-regs 5 D 5 }
+                 T{ ##replace f V int-regs 0 D 1 }
+                 T{ ##replace f V int-regs 1 D 2 }
+                 T{ ##replace f V int-regs 2 D 3 }
+                 T{ ##replace f V int-regs 3 D 4 }
+                 T{ ##replace f V int-regs 4 D 5 }
+                 T{ ##replace f V int-regs 5 D 0 }
+             }
+           }
+        } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
+        instructions>> first
+        live-values>> assoc-empty?
+    ] with-scope
+] unit-test
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##replace f V int-regs 1 D 1 }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##gc f V int-regs 2 V int-regs 3 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 2 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
+
+[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
+
+
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##peek f V int-regs 1 D 1 }
+    T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+} 0 test-bb
+
+V{
+    T{ ##gc f V int-regs 2 V int-regs 3 }
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##return }
+} 1 test-bb
+
+V{
+    T{ ##return }
+} 2 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
+
+[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test

From 2e7f337b3dd6d750f139b40d1dec871aa0220031 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Fri, 10 Jul 2009 23:53:50 +1200
Subject: [PATCH 11/30] alien.inline: made define-c-function and
 define-c-function' standalone

---
 basis/alien/inline/inline.factor | 24 ++++++++++++++----------
 1 file changed, 14 insertions(+), 10 deletions(-)

diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor
index 20ccd43e5c..2c0825f8b4 100644
--- a/basis/alien/inline/inline.factor
+++ b/basis/alien/inline/inline.factor
@@ -39,8 +39,8 @@ SYMBOL: c-strings
 : prototype-string' ( function types return -- str )
     [ dup arg-list ] <effect> prototype-string ;
 
-: append-function-body ( prototype-str -- str )
-    " {\n" append parse-here append "\n}\n" append ;
+: append-function-body ( prototype-str body -- str )
+    [ swap % " {\n" % % "\n}\n" % ] "" make ;
 
 : compile-library? ( -- ? )
     c-library get library-path dup exists? [
@@ -69,14 +69,18 @@ PRIVATE>
     compile-library? [ compile-library ] when
     c-library get dup library-path "cdecl" add-library ;
 
-: define-c-function ( function types effect -- )
-    [ factor-function define-declared ] 3keep prototype-string
-    append-function-body c-strings get push ;
+: define-c-function ( function types effect body -- )
+    [
+        [ factor-function define-declared ]
+        [ prototype-string ] 3bi
+    ] dip append-function-body c-strings get push ;
 
-: define-c-function' ( function effect -- )
-    [ in>> ] keep [ factor-function define-declared ] 3keep
-    out>> prototype-string'
-    append-function-body c-strings get push ;
+: define-c-function' ( function effect body -- )
+    [
+        [ in>> ] keep
+        [ factor-function define-declared ]
+        [ out>> prototype-string' ] 3bi
+    ] dip append-function-body c-strings get push ;
 
 : define-c-link ( str -- )
     "-l" prepend compiler-args get push ;
@@ -123,7 +127,7 @@ SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ;
 SYNTAX: C-INCLUDE: scan define-c-include ;
 
 SYNTAX: C-FUNCTION:
-    function-types-effect define-c-function ;
+    function-types-effect parse-here define-c-function ;
 
 SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
 

From 0851823ba92428e7ac57c8ecc6c12ba20d87aac1 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Fri, 10 Jul 2009 23:54:40 +1200
Subject: [PATCH 12/30] alien.inline: remove vocab argument from
 define-c-struct

---
 basis/alien/inline/inline.factor | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor
index 2c0825f8b4..7f530bc64b 100644
--- a/basis/alien/inline/inline.factor
+++ b/basis/alien/inline/inline.factor
@@ -100,15 +100,15 @@ PRIVATE>
         "" make c-strings get push
     ] 2bi ;
 
-: define-c-struct ( name vocab fields -- )
-    [ define-struct ] [
-        nip over
+: define-c-struct ( name fields -- )
+    [ current-vocab swap define-struct ] [
+        over
         [
             "typedef struct " % "_" % % " {\n" %
             [ first2 swap % " " % % ";\n" % ] each
             "} " % % ";\n" %
         ] "" make c-strings get push
-    ] 3bi ;
+    ] 2bi ;
 
 : delete-inline-library ( str -- )
     c-library-name [ remove-library ]
@@ -132,7 +132,7 @@ SYNTAX: C-FUNCTION:
 SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
 
 SYNTAX: C-STRUCTURE:
-    scan current-vocab parse-definition define-c-struct ;
+    scan parse-definition define-c-struct ;
 
 SYNTAX: ;C-LIBRARY compile-c-library ;
 

From 864a6e75080785aca83be7bd0fb93e72d6795a67 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Fri, 10 Jul 2009 23:55:05 +1200
Subject: [PATCH 13/30] alien.inline: better names

---
 basis/alien/inline/inline.factor | 20 ++++++++++----------
 1 file changed, 10 insertions(+), 10 deletions(-)

diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor
index 7f530bc64b..37e01b5209 100644
--- a/basis/alien/inline/inline.factor
+++ b/basis/alien/inline/inline.factor
@@ -82,16 +82,16 @@ PRIVATE>
         [ out>> prototype-string' ] 3bi
     ] dip append-function-body c-strings get push ;
 
-: define-c-link ( str -- )
+: c-link-to ( str -- )
     "-l" prepend compiler-args get push ;
 
-: define-c-framework ( str -- )
+: c-use-framework ( str -- )
     "-framework" swap compiler-args get '[ _ push ] bi@ ;
 
-: define-c-link/framework ( str -- )
-    os macosx? [ define-c-framework ] [ define-c-link ] if ;
+: c-link-to/use-framework ( str -- )
+    os macosx? [ c-use-framework ] [ c-link-to ] if ;
 
-: define-c-include ( str -- )
+: c-include ( str -- )
     "#include " prepend c-strings get push ;
 
 : define-c-typedef ( old new -- )
@@ -110,7 +110,7 @@ PRIVATE>
         ] "" make c-strings get push
     ] 2bi ;
 
-: delete-inline-library ( str -- )
+: delete-inline-library ( name -- )
     c-library-name [ remove-library ]
     [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
 
@@ -118,13 +118,13 @@ SYNTAX: C-LIBRARY: scan define-c-library ;
 
 SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
 
-SYNTAX: C-LINK: scan define-c-link ;
+SYNTAX: C-LINK: scan c-link-to ;
 
-SYNTAX: C-FRAMEWORK: scan define-c-framework ;
+SYNTAX: C-FRAMEWORK: scan c-use-framework ;
 
-SYNTAX: C-LINK/FRAMEWORK: scan define-c-link/framework ;
+SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
 
-SYNTAX: C-INCLUDE: scan define-c-include ;
+SYNTAX: C-INCLUDE: scan c-include ;
 
 SYNTAX: C-FUNCTION:
     function-types-effect parse-here define-c-function ;

From dc80d8575f0f3ac124876c870afd59e31d5d4a42 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Fri, 10 Jul 2009 23:55:32 +1200
Subject: [PATCH 14/30] alien.inline: added documentation

---
 basis/alien/inline/inline-docs.factor | 205 ++++++++++++++++++++++++++
 1 file changed, 205 insertions(+)
 create mode 100644 basis/alien/inline/inline-docs.factor

diff --git a/basis/alien/inline/inline-docs.factor b/basis/alien/inline/inline-docs.factor
new file mode 100644
index 0000000000..bce3f2530c
--- /dev/null
+++ b/basis/alien/inline/inline-docs.factor
@@ -0,0 +1,205 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings effects ;
+IN: alien.inline
+
+: $binding-note ( x -- )
+    drop
+    { "This word requires that certain variables are correctly bound. "
+        "Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
+
+HELP: ;C-LIBRARY
+{ $syntax ";C-LIBRARY" }
+{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
+{ $see-also POSTPONE: compile-c-library } ;
+
+HELP: C-FRAMEWORK:
+{ $syntax "C-FRAMEWORK: name" }
+{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
+{ $see-also POSTPONE: c-use-framework } ;
+
+HELP: C-FUNCTION:
+{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
+{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
+{ $examples
+  { $example
+    "USING: alien.inline prettyprint ;"
+    "IN: cmath.ffi"
+    ""
+    "C-LIBRARY: cmathlib"
+    ""
+    "C-FUNCTION: int add ( int a, int b )"
+    "    return a + b;"
+    ";"
+    ""
+    ";C-LIBRARY"
+    ""
+    "1 2 add ."
+    "3" }
+}
+{ $see-also POSTPONE: define-c-function } ;
+
+HELP: C-INCLUDE:
+{ $syntax "C-INCLUDE: name" }
+{ $description "Appends an include line to the C library in scope." }
+{ $see-also POSTPONE: c-include } ;
+
+HELP: C-LIBRARY:
+{ $syntax "C-LIBRARY: name" }
+{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
+{ $examples
+  { $example
+    "USING: alien.inline ;"
+    "IN: rectangle.ffi"
+    ""
+    "C-LIBRARY: rectlib"
+    ""
+    "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
+    ""
+    "C-FUNCTION: int area ( rectangle c )"
+    "    return c.width * c.height;"
+    ";"
+    ""
+    ";C-LIBRARY"
+    "" }
+}
+{ $see-also POSTPONE: define-c-library } ;
+
+HELP: C-LINK/FRAMEWORK:
+{ $syntax "C-LINK/FRAMEWORK: name" }
+{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
+{ $see-also POSTPONE: c-link-to/use-framework } ;
+
+HELP: C-LINK:
+{ $syntax "C-LINK: name" }
+{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
+{ $see-also POSTPONE: c-link-to } ;
+
+HELP: C-STRUCTURE:
+{ $syntax "C-STRUCTURE: name pairs ... ;" }
+{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
+{ $see-also POSTPONE: define-c-struct } ;
+
+HELP: C-TYPEDEF:
+{ $syntax "C-TYPEDEF: old new" }
+{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
+{ $see-also POSTPONE: define-c-typedef } ;
+
+HELP: COMPILE-AS-C++
+{ $syntax "COMPILE-AS-C++" }
+{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
+
+HELP: DELETE-C-LIBRARY:
+{ $syntax "DELETE-C-LIBRARY: name" }
+{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
+{ $notes
+  { $list
+    { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
+    "This word is mainly useful for unit tests."
+  }
+}
+{ $see-also POSTPONE: delete-inline-library } ;
+
+HELP: RAW-C:
+{ $syntax "RAW-C:" "body" ";" }
+{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
+
+CONSTANT: foo "abc"
+
+HELP: compile-c-library
+{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
+  "Also calls " { $snippet "add-library" } ". "
+  "This word does nothing if the shared library is younger than the factor source file." }
+{ $notes $binding-note } ;
+
+HELP: c-use-framework
+{ $values
+    { "str" string }
+}
+{ $description "OS X only. Adds " { $snippet "-framework name" } " to linker command." }
+{ $notes $binding-note }
+{ $see-also c-link-to c-link-to/use-framework } ;
+
+HELP: define-c-function
+{ $values
+    { "function" "function name" } { "types" "a sequence of C types" } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it." }
+{ $notes
+  { $list
+    { "The number of " { $snippet "types" } " must match the " { $snippet "in" } " count of the " { $snippet "effect" } "." }
+    { "There must be only one " { $snippet "out" } " element. It must be a legal C return type with dashes (-) instead of spaces." }
+    $binding-note
+  }
+}
+{ $see-also POSTPONE: define-c-function' } ;
+
+HELP: define-c-function'
+{ $values
+    { "function" "function name" } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it. See " { $link define-c-function } " for more information." }
+{ $notes
+  { $list
+    { "Each effect element must be a legal C type with dashes (-) instead of spaces. "
+      "C argument names will be generated alphabetically, starting with " { $snippet "a" } "." }
+    $binding-note
+  }
+}
+{ $see-also define-c-function } ;
+
+HELP: c-include
+{ $values
+    { "str" string }
+}
+{ $description "Appends an include line to the C library in scope." }
+{ $notes $binding-note } ;
+
+HELP: define-c-library
+{ $values
+    { "name" string }
+}
+{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " words can be used after this one." } ;
+
+HELP: c-link-to
+{ $values
+    { "str" string }
+}
+{ $description "Adds " { $snippet "-lname" } " to linker command." }
+{ $notes $binding-note }
+{ $see-also c-use-framework c-link-to/use-framework } ;
+
+HELP: c-link-to/use-framework
+{ $values
+    { "str" string }
+}
+{ $description "Equivalent to " { $link c-use-framework } " on OS X and " { $link c-link-to } " everywhere else." }
+{ $notes $binding-note }
+{ $see-also c-link-to c-use-framework } ;
+
+HELP: define-c-struct
+{ $values
+    { "name" string } { "fields" "type/name pairs" }
+}
+{ $description "Defines a C struct and factor words which operate on it." }
+{ $notes $binding-note } ;
+
+HELP: define-c-typedef
+{ $values
+    { "old" "C type" } { "new" "C type" }
+}
+{ $description "Define C and factor typedefs." }
+{ $notes $binding-note } ;
+
+HELP: delete-inline-library
+{ $values
+    { "name" string }
+}
+{ $description "Delete the shared library file corresponding to " { $snippet "name" } "." }
+{ $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ;
+
+ARTICLE: "alien.inline" "Inline C"
+{ $vocab-link "alien.inline" }
+;
+
+ABOUT: "alien.inline"

From e0fa51512f6e1ac8342155f788a02a9ee4947a6c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Fri, 10 Jul 2009 07:07:54 -0500
Subject: [PATCH 15/30] llvm: new add-llvm-library word to make things a bit
 more portable

---
 extra/llvm/core/core.factor     | 19 +++++++++++-------
 extra/llvm/engine/engine.factor | 35 +++++++++++----------------------
 2 files changed, 24 insertions(+), 30 deletions(-)

diff --git a/extra/llvm/core/core.factor b/extra/llvm/core/core.factor
index 00a395d3b2..cb62821390 100644
--- a/extra/llvm/core/core.factor
+++ b/extra/llvm/core/core.factor
@@ -1,18 +1,23 @@
 ! Copyright (C) 2009 Matthew Willis.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.libraries alien.syntax ;
+USING: alien.libraries alien.syntax system sequences combinators ;
 
 IN: llvm.core
 
 <<
 
-"LLVMSystem" "/usr/local/lib/libLLVMSystem.dylib" "cdecl" add-library
+: add-llvm-library ( name -- )
+    dup
+    {
+        { [ os macosx? ] [ "/usr/local/lib/lib" ".dylib" surround ] }
+        { [ os windows? ] [ ".dll" append ] }
+        { [ os unix? ] [ ".so" append ] }
+    } cond add-library ;
 
-"LLVMSupport" "/usr/local/lib/libLLVMSupport.dylib" "cdecl" add-library
-
-"LLVMCore" "/usr/local/lib/libLLVMCore.dylib" "cdecl" add-library
-
-"LLVMBitReader" "/usr/local/lib/libLLVMBitReader.dylib" "cdecl" add-library
+"LLVMSystem" add-llvm-library
+"LLVMSupport" add-llvm-library
+"LLVMCore" add-llvm-library
+"LLVMBitReader" add-llvm-library
 
 >>
 
diff --git a/extra/llvm/engine/engine.factor b/extra/llvm/engine/engine.factor
index 1fa7ef01d6..d259c740e6 100644
--- a/extra/llvm/engine/engine.factor
+++ b/extra/llvm/engine/engine.factor
@@ -5,29 +5,18 @@ IN: llvm.engine
 
 <<
 
-"LLVMExecutionEngine" "/usr/local/lib/libLLVMExecutionEngine.dylib" "cdecl" add-library
-
-"LLVMTarget" "/usr/local/lib/libLLVMTarget.dylib" "cdecl" add-library
-
-"LLVMAnalysis" "/usr/local/lib/libLLVMAnalysis.dylib" "cdecl" add-library
-
-"LLVMipa" "/usr/local/lib/libLLVMipa.dylib" "cdecl" add-library
-
-"LLVMTransformUtils" "/usr/local/lib/libLLVMTransformUtils.dylib" "cdecl" add-library
-
-"LLVMScalarOpts" "/usr/local/lib/libLLVMScalarOpts.dylib" "cdecl" add-library
-
-"LLVMCodeGen" "/usr/local/lib/libLLVMCodeGen.dylib" "cdecl" add-library
-
-"LLVMAsmPrinter" "/usr/local/lib/libLLVMAsmPrinter.dylib" "cdecl" add-library
-
-"LLVMSelectionDAG" "/usr/local/lib/libLLVMSelectionDAG.dylib" "cdecl" add-library
-
-"LLVMX86CodeGen" "/usr/local/lib/libLLVMX86CodeGen.dylib" "cdecl" add-library
-
-"LLVMJIT" "/usr/local/lib/libLLVMJIT.dylib" "cdecl" add-library
-
-"LLVMInterpreter.dylib" "/usr/local/lib/libLLVMInterpreter.dylib" "cdecl" add-library
+"LLVMExecutionEngine" add-llvm-library
+"LLVMTarget" add-llvm-library
+"LLVMAnalysis" add-llvm-library
+"LLVMipa" add-llvm-library
+"LLVMTransformUtils" add-llvm-library
+"LLVMScalarOpts" add-llvm-library
+"LLVMCodeGen" add-llvm-library
+"LLVMAsmPrinter" add-llvm-library
+"LLVMSelectionDAG" add-llvm-library
+"LLVMX86CodeGen" add-llvm-library
+"LLVMJIT" add-llvm-library
+"LLVMInterpreter" add-llvm-library
 
 >>
 

From 4a5cb3aac3f2b85818a74fbc3bf18acd6f2ba4a4 Mon Sep 17 00:00:00 2001
From: Jeremy Hughes <jedahu@gmail.com>
Date: Sat, 11 Jul 2009 00:08:40 +1200
Subject: [PATCH 16/30] alien.inline: added with-c-library word

---
 basis/alien/inline/inline-docs.factor |  8 +++++++-
 basis/alien/inline/inline.factor      | 10 +++++++++-
 2 files changed, 16 insertions(+), 2 deletions(-)

diff --git a/basis/alien/inline/inline-docs.factor b/basis/alien/inline/inline-docs.factor
index bce3f2530c..58eca558ea 100644
--- a/basis/alien/inline/inline-docs.factor
+++ b/basis/alien/inline/inline-docs.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Jeremy Hughes.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel strings effects ;
+USING: help.markup help.syntax kernel strings effects quotations ;
 IN: alien.inline
 
 : $binding-note ( x -- )
@@ -198,6 +198,12 @@ HELP: delete-inline-library
 { $description "Delete the shared library file corresponding to " { $snippet "name" } "." }
 { $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ;
 
+HELP: with-c-library
+{ $values
+    { "name" string } { "quot" quotation }
+}
+{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ;
+
 ARTICLE: "alien.inline" "Inline C"
 { $vocab-link "alien.inline" }
 ;
diff --git a/basis/alien/inline/inline.factor b/basis/alien/inline/inline.factor
index 37e01b5209..1df77d6600 100644
--- a/basis/alien/inline/inline.factor
+++ b/basis/alien/inline/inline.factor
@@ -6,7 +6,7 @@ generalizations grouping io.directories io.files
 io.files.info io.files.temp kernel lexer math math.order
 math.ranges multiline namespaces sequences source-files
 splitting strings system vocabs.loader vocabs.parser words
-alien.c-types alien.structs make parser ;
+alien.c-types alien.structs make parser continuations ;
 IN: alien.inline
 
 <PRIVATE
@@ -15,6 +15,10 @@ SYMBOL: library-is-c++
 SYMBOL: compiler-args
 SYMBOL: c-strings
 
+: cleanup-variables ( -- )
+    { c-library library-is-c++ compiler-args c-strings }
+    [ off ] each ;
+
 : function-types-effect ( -- function types effect )
     scan scan swap ")" parse-tokens
     [ "(" subseq? not ] filter swap parse-arglist ;
@@ -114,6 +118,10 @@ PRIVATE>
     c-library-name [ remove-library ]
     [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
 
+: with-c-library ( name quot -- )
+    [ [ define-c-library ] dip call compile-c-library ]
+    [ cleanup-variables ] [ ] cleanup ; inline
+
 SYNTAX: C-LIBRARY: scan define-c-library ;
 
 SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;

From b7aac8c13a68418e7ef2d544126ddfb28f4a0150 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@linux-x86-32.(none)>
Date: Fri, 10 Jul 2009 07:38:19 -0500
Subject: [PATCH 17/30] llvm.core: fix add-llvm-library

---
 extra/llvm/core/core.factor | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/extra/llvm/core/core.factor b/extra/llvm/core/core.factor
index cb62821390..0d1b22e288 100644
--- a/extra/llvm/core/core.factor
+++ b/extra/llvm/core/core.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Matthew Willis.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.libraries alien.syntax system sequences combinators ;
+USING: alien.libraries alien.syntax system sequences combinators kernel ;
 
 IN: llvm.core
 
@@ -11,8 +11,8 @@ IN: llvm.core
     {
         { [ os macosx? ] [ "/usr/local/lib/lib" ".dylib" surround ] }
         { [ os windows? ] [ ".dll" append ] }
-        { [ os unix? ] [ ".so" append ] }
-    } cond add-library ;
+        { [ os unix? ] [ "lib" ".so" surround ] }
+    } cond "cdecl" add-library ;
 
 "LLVMSystem" add-llvm-library
 "LLVMSupport" add-llvm-library

From c25ac2a066fa682a63c63378e6bcc5781610202a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Fri, 10 Jul 2009 07:46:47 -0500
Subject: [PATCH 18/30] llvm: add unportable tag

---
 extra/llvm/core/tags.txt     | 1 +
 extra/llvm/engine/tags.txt   | 1 +
 extra/llvm/invoker/tags.txt  | 1 +
 extra/llvm/jit/tags.txt      | 1 +
 extra/llvm/reader/tags.txt   | 1 +
 extra/llvm/tags.txt          | 1 +
 extra/llvm/types/tags.txt    | 1 +
 extra/llvm/wrappers/tags.txt | 1 +
 8 files changed, 8 insertions(+)
 create mode 100644 extra/llvm/core/tags.txt
 create mode 100644 extra/llvm/engine/tags.txt
 create mode 100644 extra/llvm/invoker/tags.txt
 create mode 100644 extra/llvm/jit/tags.txt
 create mode 100644 extra/llvm/reader/tags.txt
 create mode 100644 extra/llvm/types/tags.txt
 create mode 100644 extra/llvm/wrappers/tags.txt

diff --git a/extra/llvm/core/tags.txt b/extra/llvm/core/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/llvm/core/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/llvm/engine/tags.txt b/extra/llvm/engine/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/llvm/engine/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/llvm/invoker/tags.txt b/extra/llvm/invoker/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/llvm/invoker/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/llvm/jit/tags.txt b/extra/llvm/jit/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/llvm/jit/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/llvm/reader/tags.txt b/extra/llvm/reader/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/llvm/reader/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/llvm/tags.txt b/extra/llvm/tags.txt
index bb863cf9a0..bf2a35f15b 100644
--- a/extra/llvm/tags.txt
+++ b/extra/llvm/tags.txt
@@ -1 +1,2 @@
 bindings
+unportable
diff --git a/extra/llvm/types/tags.txt b/extra/llvm/types/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/llvm/types/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/llvm/wrappers/tags.txt b/extra/llvm/wrappers/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/llvm/wrappers/tags.txt
@@ -0,0 +1 @@
+unportable

From 1cf6bb7f99b0369a413670d8306eea0b2d4935ff Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Fri, 10 Jul 2009 07:48:49 -0500
Subject: [PATCH 19/30] compiler.cfg.linear-scan: disable unit test for
 unimplemented feature

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

diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index bc3061128c..e8b4b67cf0 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -1770,7 +1770,8 @@ test-diamond
     2 get instructions>> first regs>> V int-regs 1 swap at assert=
 ] unit-test
 
-[ _copy ] [ 3 get instructions>> second class ] unit-test
+! Not until splitting is finished
+! [ _copy ] [ 3 get instructions>> second class ] unit-test
 
 ! Resolve pass; make sure the spilling is done correctly
 V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb

From 949b527ed58167bf6d667108ecb00cd678603f44 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.local>
Date: Fri, 10 Jul 2009 07:52:20 -0500
Subject: [PATCH 20/30] Help lint fixes for urls.encoding and mongodb.driver

---
 basis/urls/encoding/encoding-docs.factor | 2 +-
 extra/mongodb/driver/driver-docs.factor  | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/urls/encoding/encoding-docs.factor b/basis/urls/encoding/encoding-docs.factor
index 82ab3d1f69..a021bd6d23 100644
--- a/basis/urls/encoding/encoding-docs.factor
+++ b/basis/urls/encoding/encoding-docs.factor
@@ -26,7 +26,7 @@ HELP: assoc>query
         "USING: io urls.encoding ;"
         "{ { \"from\" \"Lead\" } { \"to\" \"Gold, please\" } }"
         "assoc>query print"
-        "from=Lead&to=Gold%2c%20please"
+        "from=Lead&to=Gold%2C%20please"
     }
 } ;
 
diff --git a/extra/mongodb/driver/driver-docs.factor b/extra/mongodb/driver/driver-docs.factor
index e8f726374c..532dfe1dce 100644
--- a/extra/mongodb/driver/driver-docs.factor
+++ b/extra/mongodb/driver/driver-docs.factor
@@ -76,7 +76,7 @@ HELP: count
 
 HELP: create-collection
 { $values
-  { "name" "collection name" }
+  { "name/collection" "collection name" }
 }
 { $description "Creates a new collection with the given name." } ;
 

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 21/30] 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 22/30] 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 23/30] 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 24/30] 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 25/30] 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 26/30] 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 27/30] 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 28/30] 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 29/30] 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 30/30] 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