From d387947033189141696897ae37ad2b45c12b7ae3 Mon Sep 17 00:00:00 2001
From: Erik Charlebois <erikcharlebois@gmail.com>
Date: Fri, 16 Apr 2010 13:41:16 -0700
Subject: [PATCH 001/158] FUEL: Syntax highlight CONSULT: and PROTOCOL:

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

diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el
index 026a7738e0..c6638915b7 100644
--- a/misc/fuel/fuel-syntax.el
+++ b/misc/fuel/fuel-syntax.el
@@ -1,3 +1,4 @@
+
 ;;; fuel-syntax.el --- auxiliar definitions for factor code navigation.
 
 ;; Copyright (C) 2008, 2009  Jose Antonio Ortega Ruiz
@@ -46,7 +47,7 @@
   '(":" "::" ";" "&:" "<<" "<PRIVATE" ">>"
     "ABOUT:" "AFTER:" "ALIAS:" "ALIEN:" "ARTICLE:"
     "B" "BEFORE:" "BIN:"
-    "C:" "CALLBACK:" "C-ENUM:" "C-STRUCT:" "C-TYPE:" "C-UNION:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "call-next-method"
+    "C:" "CALLBACK:" "C-ENUM:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"
     "DEFER:"
     "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
     "f" "FORGET:" "FROM:" "FUNCTION:"
@@ -59,7 +60,7 @@
     "MEMO:" "MEMO:" "METHOD:" "MIXIN:"
     "NAN:"
     "OCT:"
-    "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
+    "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROTOCOL:" "PROVIDE:"
     "QUALIFIED-WITH:" "QUALIFIED:"
     "read-only" "RENAME:" "REQUIRE:"  "REQUIRES:"
     "SINGLETON:" "SINGLETONS:" "SLOT:" "SPECIALIZED-ARRAY:" "SPECIALIZED-ARRAYS:" "STRING:" "STRUCT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
@@ -164,13 +165,13 @@
 
 (defconst fuel-syntax--indent-def-starts '("" ":"
                                            "AFTER" "BEFORE"
-                                           "C-ENUM" "C-STRUCT" "C-UNION" "COM-INTERFACE"
+                                           "C-ENUM" "COM-INTERFACE" "CONSULT"
                                            "FROM" "FUNCTION:"
                                            "INTERSECTION:"
                                            "M" "M:" "MACRO" "MACRO:"
                                            "MEMO" "MEMO:" "METHOD"
                                            "SYNTAX"
-                                           "PREDICATE" "PRIMITIVE"
+                                           "PREDICATE" "PRIMITIVE" "PROTOCOL"
                                            "SINGLETONS"
                                            "STRUCT" "SYMBOLS" "TAG" "TUPLE"
                                            "TYPED" "TYPED:"

From 265fe6208fb53e5ce5f6d0aea4c4ea40508400ba Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Sat, 17 Apr 2010 16:25:51 -0500
Subject: [PATCH 002/158] Adding null? word to test if a set is empty

---
 basis/bit-sets/bit-sets-tests.factor  | 3 +++
 core/hash-sets/hash-sets-tests.factor | 3 +++
 core/hash-sets/hash-sets.factor       | 1 +
 core/sets/sets-tests.factor           | 3 +++
 core/sets/sets.factor                 | 6 ++++++
 5 files changed, 16 insertions(+)

diff --git a/basis/bit-sets/bit-sets-tests.factor b/basis/bit-sets/bit-sets-tests.factor
index 4e97e703d0..0d4543f8f2 100644
--- a/basis/bit-sets/bit-sets-tests.factor
+++ b/basis/bit-sets/bit-sets-tests.factor
@@ -11,6 +11,9 @@ IN: bit-sets.tests
     T{ bit-set f ?{ f f t f t f } } intersect
 ] unit-test
 
+[ f ] [ T{ bit-set f ?{ t f f f t f } } null? ] unit-test
+[ t ] [ T{ bit-set f ?{ f f f f f f } } null? ] unit-test
+
 [ T{ bit-set f ?{ t f t f f f } } ] [
     T{ bit-set f ?{ t t t f f f } }
     T{ bit-set f ?{ f t f f t t } } diff
diff --git a/core/hash-sets/hash-sets-tests.factor b/core/hash-sets/hash-sets-tests.factor
index 5b7ffafc8b..ca995a38e6 100644
--- a/core/hash-sets/hash-sets-tests.factor
+++ b/core/hash-sets/hash-sets-tests.factor
@@ -31,3 +31,6 @@ IN: hash-sets.tests
 [ f ] [ HS{ 1 2 3 } HS{ 2 3 } set= ] unit-test
 
 [ HS{ 1 2 } HS{ 1 2 3 } ] [ HS{ 1 2 } clone dup clone [ 3 swap adjoin ] keep ] unit-test
+
+[ t ] [ HS{ } null? ] unit-test
+[ f ] [ HS{ 1 } null? ] unit-test
diff --git a/core/hash-sets/hash-sets.factor b/core/hash-sets/hash-sets.factor
index 3ca2cce93c..ac198a2ca2 100644
--- a/core/hash-sets/hash-sets.factor
+++ b/core/hash-sets/hash-sets.factor
@@ -18,6 +18,7 @@ M: hash-set delete table>> delete-at ; inline
 M: hash-set members table>> keys ; inline
 M: hash-set set-like drop dup hash-set? [ members <hash-set> ] unless ;
 M: hash-set clone table>> clone hash-set boa ;
+M: hash-set null? table>> assoc-empty? ;
 
 M: sequence fast-set <hash-set> ;
 M: f fast-set drop H{ } clone hash-set boa ;
diff --git a/core/sets/sets-tests.factor b/core/sets/sets-tests.factor
index e4bc762512..9a48acc4cf 100644
--- a/core/sets/sets-tests.factor
+++ b/core/sets/sets-tests.factor
@@ -61,3 +61,6 @@ IN: sets.tests
 [ f ] [ HS{ 1 2 3 1 2 1 } duplicates ] unit-test
 
 [ H{ { 3 HS{ 1 2 } } } ] [ H{ } clone 1 3 pick adjoin-at 2 3 pick adjoin-at ] unit-test
+
+[ t ] [ f null? ] unit-test
+[ f ] [ { 4 } null? ] unit-test
diff --git a/core/sets/sets.factor b/core/sets/sets.factor
index d279f036d4..9c1870aa2e 100644
--- a/core/sets/sets.factor
+++ b/core/sets/sets.factor
@@ -21,10 +21,13 @@ GENERIC: subset? ( set1 set2 -- ? )
 GENERIC: set= ( set1 set2 -- ? )
 GENERIC: duplicates ( set -- seq )
 GENERIC: all-unique? ( set -- ? )
+GENERIC: null? ( set -- ? )
 
 ! Defaults for some methods.
 ! Override them for efficiency
 
+M: set null? members null? ; inline
+
 M: set set-like drop ; inline
 
 M: set union
@@ -91,6 +94,9 @@ M: sequence set-like
 
 M: sequence members
     [ pruned ] keep like ;
+  
+M: sequence null?
+    empty? ; inline
 
 : combine ( sets -- set )
     [ f ]

From 00176e7bd19e3bd63a7c279d3624fa19b8165578 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Sat, 17 Apr 2010 17:19:37 -0500
Subject: [PATCH 003/158] Attempting to make require-when work with multiple
 vocabs

---
 core/vocabs/loader/loader.factor   | 31 ++++++++++++++++++++-----
 core/vocabs/loader/test/m/m.factor |  3 ++-
 core/vocabs/vocabs.factor          | 37 ++++++++++++++++++++++++++++--
 3 files changed, 62 insertions(+), 9 deletions(-)

diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 59fe06e6fd..4e811d8914 100644
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -3,7 +3,7 @@
 USING: namespaces make sequences io io.files io.pathnames kernel
 assocs words vocabs definitions parser continuations hashtables
 sorting source-files arrays combinators strings system
-math.parser splitting init accessors sets ;
+math.parser splitting init accessors sets fry ;
 IN: vocabs.loader
 
 SYMBOL: vocab-roots
@@ -66,9 +66,17 @@ DEFER: require
 
 <PRIVATE
 
+: transfer-conditionals ( vocab-name record -- )
+    {
+        [ unloaded>> delete ]
+        [ loaded>> adjoin ]
+        [ swap partly-required get adjoin-at ]
+        [ unloaded>> null? swap '[ _ require ] when ]
+    } 2cleave ;
+
 : load-conditional-requires ( vocab-name -- )
     conditional-requires get
-    [ at [ require ] each ] 
+    [ dupd at members [ transfer-conditionals ] with each ] 
     [ delete-at ] 2bi ;
 
 : load-source ( vocab -- )
@@ -96,11 +104,22 @@ PRIVATE>
 : require ( vocab -- )
     load-vocab drop ;
 
+<PRIVATE
+
+: adjoin-each-at ( elt seq assoc -- )
+    [ swap ] dip '[ _ swap _ adjoin-at ] each ;
+
+: record-require-when ( then loaded unloaded -- )
+    [ [ fast-set ] bi@ <require-when-record> ] 2keep
+    [ conditional-requires get adjoin-each-at ]
+    [ partly-required get adjoin-each-at ]
+    bi-curry* bi ;
+
+PRIVATE>
+
 : require-when ( if then -- )
-    over vocab
-    [ nip require ]
-    [ swap conditional-requires get [ swap suffix ] change-at ]
-    if ;
+    swap [ vocab ] partition
+    [ drop require ] [ record-require-when ] if-empty ;
 
 : reload ( name -- )
     dup vocab
diff --git a/core/vocabs/loader/test/m/m.factor b/core/vocabs/loader/test/m/m.factor
index d6d3bd8a7a..cd35d83e4f 100644
--- a/core/vocabs/loader/test/m/m.factor
+++ b/core/vocabs/loader/test/m/m.factor
@@ -1,4 +1,5 @@
 USE: vocabs.loader
 IN: vocabs.loader.test.m
 
-"vocabs.loader.test.o" "vocabs.loader.test.n" require-when
+{ "vocabs.loader.test.o" "vocabs.loader.test.m" }
+"vocabs.loader.test.n" require-when
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index e48d6c3031..db28c9981b 100644
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2009 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs strings kernel sorting namespaces
-sequences definitions sets ;
+sequences definitions sets combinators ;
 IN: vocabs
 
 SYMBOL: dictionary
@@ -83,9 +83,25 @@ ERROR: bad-vocab-name name ;
 : check-vocab-name ( name -- name )
     dup string? [ bad-vocab-name ] unless ;
 
+TUPLE: require-when-record
+    vocab loaded unloaded ;
+
+! These are identified by their vocab
+M: require-when-record equal?
+    over require-when-record?
+    [ [ vocab>> ] bi@ = ] [ 2drop f ] if ;
+
+M: require-when-record hashcode*
+    vocab>> hashcode* ;
+
+C: <require-when-record> require-when-record
+
 SYMBOL: conditional-requires
 conditional-requires [ H{ } clone ] initialize
 
+SYMBOL: partly-required
+partly-required [ H{ } clone ] initialize
+
 : create-vocab ( name -- vocab )
     check-vocab-name
     dictionary get [ <vocab> ] cache
@@ -120,9 +136,26 @@ M: vocab-spec >vocab-link ;
 
 M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
 
+<PRIVATE
+
+: untransfer-conditionals ( vocab-name record -- )
+    {
+        [ loaded>> delete ]
+        [ unloaded>> adjoin ]
+        [ swap conditional-requires get adjoin-at ]
+    } 2cleave ;
+
+: unload-conditional-requires ( vocab-name -- )
+    partly-required get
+    [ dupd at members [ untransfer-conditionals ] with each ] 
+    [ delete-at ] 2bi ;
+
+PRIVATE>
+
 : forget-vocab ( vocab -- )
     [ words forget-all ]
-    [ vocab-name dictionary get delete-at ] bi
+    [ vocab-name dictionary get delete-at ]
+    [ unload-conditional-requires ] tri
     notify-vocab-observers ;
 
 M: vocab-spec forget* forget-vocab ;

From 23cf6413dc9a34c4f0f0d381bb6d0e05f428e098 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 18 Apr 2010 11:54:22 -0700
Subject: [PATCH 004/158] cuda.ptx: some unit tests

---
 extra/cuda/ptx/ptx-tests.factor | 114 ++++++++++++++++++++++++++++++++
 extra/cuda/ptx/ptx.factor       |  32 ++++++---
 2 files changed, 136 insertions(+), 10 deletions(-)
 create mode 100644 extra/cuda/ptx/ptx-tests.factor

diff --git a/extra/cuda/ptx/ptx-tests.factor b/extra/cuda/ptx/ptx-tests.factor
new file mode 100644
index 0000000000..877bc82811
--- /dev/null
+++ b/extra/cuda/ptx/ptx-tests.factor
@@ -0,0 +1,114 @@
+USING: cuda.ptx tools.test ;
+IN: cuda.ptx.tests
+
+[ """	.version 2.0
+	.target sm_20
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20, .texmode_independent
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } { texmode .texmode_independent } } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_11, map_f64_to_f32
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target
+            { arch sm_11 }
+            { map_f64_to_f32? t }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_11, map_f64_to_f32, .texmode_independent
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target
+            { arch sm_11 }
+            { map_f64_to_f32? t }
+            { texmode .texmode_independent }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	.global .f32 foo[9000];
+	.extern .align 16 .shared .v4.f32 bar[];
+	.func (.reg .f32 sum) zap (.reg .f32 a, .reg .f32 b)
+	{
+	add.rn.f32 sum, a, b;
+	ret;
+	}
+	.func frob (.align 8 .param .u64 in, .align 8 .param .u64 out, .align 8 .param .u64 len)
+	{
+	ret;
+	}
+	.func twib
+	{
+	ret;
+	}
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ ptx-variable
+                { storage-space .global }
+                { type .f32 }
+                { name "foo" }
+                { dim 9000 }
+            }
+            T{ ptx-variable
+                { extern? t }
+                { align 16 }
+                { storage-space .shared }
+                { type T{ .v4 f .f32 } }
+                { name "bar" }
+                { dim 0 }
+            }
+            T{ ptx-func
+                { return T{ ptx-variable { storage-space .reg } { type .f32 } { name "sum" } } }
+                { name "zap" }
+                { params {
+                    T{ ptx-variable { storage-space .reg } { type .f32 } { name "a" } }
+                    T{ ptx-variable { storage-space .reg } { type .f32 } { name "b" } }
+                } }
+                { body {
+                    T{ add { round .rn } { type .f32 } { dest "sum" } { a "a" } { b "b" } }
+                    T{ ret }
+                } }
+            }
+            T{ ptx-func
+                { name "frob" }
+                { params {
+                    T{ ptx-variable { align 8 } { storage-space .param } { type .u64 } { name "in" } }
+                    T{ ptx-variable { align 8 } { storage-space .param } { type .u64 } { name "out" } }
+                    T{ ptx-variable { align 8 } { storage-space .param } { type .u64 } { name "len" } }
+                } }
+                { body {
+                    T{ ret }
+                } }
+            }
+            T{ ptx-func
+                { name "twib" }
+                { body {
+                    T{ ret }
+                } }
+            }
+        } }
+    } ptx>string
+] unit-test
diff --git a/extra/cuda/ptx/ptx.factor b/extra/cuda/ptx/ptx.factor
index 8d4925d55f..8a30659640 100644
--- a/extra/cuda/ptx/ptx.factor
+++ b/extra/cuda/ptx/ptx.factor
@@ -1,6 +1,6 @@
 ! (c)2010 Joe Groff bsd license
-USING: accessors arrays combinators io kernel math math.parser
-roles sequences strings variants words ;
+USING: accessors arrays combinators io io.streams.string kernel
+math math.parser roles sequences strings variants words ;
 FROM: roles => TUPLE: ;
 IN: cuda.ptx
 
@@ -62,6 +62,7 @@ TUPLE: ptx-variable
     { parameter ?integer }
     { dim dim }
     { initializer ?string } ;
+UNION: ?ptx-variable POSTPONE: f ptx-variable ;
 
 TUPLE: ptx-predicate
     { negated? boolean }
@@ -79,7 +80,7 @@ TUPLE: ptx-entry
     body ;
 
 TUPLE: ptx-func < ptx-entry
-    { return ptx-variable } ;
+    { return ?ptx-variable } ;
 
 TUPLE: ptx-directive ;
 
@@ -331,15 +332,23 @@ TUPLE: xor       < ptx-3op-instruction ;
 GENERIC: ptx-element-label ( elt -- label )
 M: object ptx-element-label  drop f ;
 
+GENERIC: ptx-semicolon? ( elt -- ? )
+M: object ptx-semicolon? drop t ;
+M: ptx-target ptx-semicolon? drop f ;
+M: ptx-entry ptx-semicolon? drop f ;
+M: ptx-func ptx-semicolon? drop f ;
+M: .file ptx-semicolon? drop f ;
+M: .loc ptx-semicolon? drop f ;
+
 GENERIC: (write-ptx-element) ( elt -- )
 
 : write-ptx-element ( elt -- )
     dup ptx-element-label [ write ":" write ] when*
-    "\t" write (write-ptx-element) 
-    ";" print ;
+    "\t" write dup (write-ptx-element) 
+    ptx-semicolon? [ ";" print ] [ nl ] if ;
 
 : write-ptx ( ptx -- )
-    "\t.version " write dup version>> write ";" print
+    "\t.version " write dup version>> print
     dup target>> write-ptx-element
     body>> [ write-ptx-element ] each ;
 
@@ -399,9 +408,9 @@ M: ptx-variable (write-ptx-element)
     "\t}" write ;
 
 : write-entry ( entry -- )
-    dup name>> write " " write
-    dup params>> [ write-params ] when* nl
-    dup directives>> [ (write-ptx-element) ] each nl
+    dup name>> write
+    dup params>> [  " " write write-params ] when* nl
+    dup directives>> [ (write-ptx-element) nl ] each
     dup body>> write-body
     drop ;
 
@@ -754,5 +763,8 @@ M: vote (write-ptx-element)
     dup mode>> (write-ptx-element)
     write-2op ;
 M: xor (write-ptx-element)
-    "or" write-insn
+    "xor" write-insn
     write-3op ;
+
+: ptx>string ( ptx -- string )
+    [ write-ptx ] with-string-writer ;

From 099ffa1f5e436e1b1a84b87e835639742670ea9c Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Sun, 18 Apr 2010 14:08:21 -0500
Subject: [PATCH 005/158] Fixing require-when

---
 core/vocabs/loader/loader.factor | 46 +++++++++++++-------------------
 core/vocabs/vocabs.factor        | 38 +-------------------------
 2 files changed, 20 insertions(+), 64 deletions(-)

diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 4e811d8914..b09ba8c2bc 100644
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -66,18 +66,19 @@ DEFER: require
 
 <PRIVATE
 
-: transfer-conditionals ( vocab-name record -- )
-    {
-        [ unloaded>> delete ]
-        [ loaded>> adjoin ]
-        [ swap partly-required get adjoin-at ]
-        [ unloaded>> null? swap '[ _ require ] when ]
-    } 2cleave ;
+SYMBOL: require-when-vocabs
+require-when-vocabs [ HS{ } clone ] initialize
 
-: load-conditional-requires ( vocab-name -- )
-    conditional-requires get
-    [ dupd at members [ transfer-conditionals ] with each ] 
-    [ delete-at ] 2bi ;
+SYMBOL: require-when-table
+require-when-table [ V{ } clone ] initialize
+
+: load-conditional-requires ( vocab -- )
+    vocab-name require-when-vocabs get in? [
+        require-when-table get [
+            [ [ vocab ] all? ] dip
+            '[ _ require ] when
+        ] assoc-each
+    ] when ;
 
 : load-source ( vocab -- )
     dup check-vocab-hook get call( vocab -- )
@@ -87,7 +88,7 @@ DEFER: require
         [ +parsing+ >>source-loaded? ] dip
         [ % ] [ call( -- ) ] if-bootstrapping
         +done+ >>source-loaded?
-        vocab-name load-conditional-requires
+        load-conditional-requires
     ] [ ] [ f >>source-loaded? ] cleanup ;
 
 : load-docs ( vocab -- )
@@ -104,22 +105,13 @@ PRIVATE>
 : require ( vocab -- )
     load-vocab drop ;
 
-<PRIVATE
-
-: adjoin-each-at ( elt seq assoc -- )
-    [ swap ] dip '[ _ swap _ adjoin-at ] each ;
-
-: record-require-when ( then loaded unloaded -- )
-    [ [ fast-set ] bi@ <require-when-record> ] 2keep
-    [ conditional-requires get adjoin-each-at ]
-    [ partly-required get adjoin-each-at ]
-    bi-curry* bi ;
-
-PRIVATE>
-
 : require-when ( if then -- )
-    swap [ vocab ] partition
-    [ drop require ] [ record-require-when ] if-empty ;
+    over [ vocab ] all? [
+        require drop
+    ] [
+        [ drop [ require-when-vocabs get adjoin ] each ]
+        [ 2array require-when-table get push ] 2bi
+    ] if ;
 
 : reload ( name -- )
     dup vocab
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index db28c9981b..38881673e9 100644
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -83,25 +83,6 @@ ERROR: bad-vocab-name name ;
 : check-vocab-name ( name -- name )
     dup string? [ bad-vocab-name ] unless ;
 
-TUPLE: require-when-record
-    vocab loaded unloaded ;
-
-! These are identified by their vocab
-M: require-when-record equal?
-    over require-when-record?
-    [ [ vocab>> ] bi@ = ] [ 2drop f ] if ;
-
-M: require-when-record hashcode*
-    vocab>> hashcode* ;
-
-C: <require-when-record> require-when-record
-
-SYMBOL: conditional-requires
-conditional-requires [ H{ } clone ] initialize
-
-SYMBOL: partly-required
-partly-required [ H{ } clone ] initialize
-
 : create-vocab ( name -- vocab )
     check-vocab-name
     dictionary get [ <vocab> ] cache
@@ -136,26 +117,9 @@ M: vocab-spec >vocab-link ;
 
 M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
 
-<PRIVATE
-
-: untransfer-conditionals ( vocab-name record -- )
-    {
-        [ loaded>> delete ]
-        [ unloaded>> adjoin ]
-        [ swap conditional-requires get adjoin-at ]
-    } 2cleave ;
-
-: unload-conditional-requires ( vocab-name -- )
-    partly-required get
-    [ dupd at members [ untransfer-conditionals ] with each ] 
-    [ delete-at ] 2bi ;
-
-PRIVATE>
-
 : forget-vocab ( vocab -- )
     [ words forget-all ]
-    [ vocab-name dictionary get delete-at ]
-    [ unload-conditional-requires ] tri
+    [ vocab-name dictionary get delete-at ] bi
     notify-vocab-observers ;
 
 M: vocab-spec forget* forget-vocab ;

From aa6158b366531f42a76f74178bd36c6243905ce7 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Sun, 18 Apr 2010 14:29:24 -0500
Subject: [PATCH 006/158] Changing require-when usages to the new syntax for
 require-when

---
 basis/bootstrap/compiler/compiler.factor           | 4 ++--
 basis/bootstrap/handbook/handbook.factor           | 2 +-
 basis/bootstrap/threads/threads.factor             | 2 +-
 basis/bootstrap/ui/tools/tools.factor              | 2 +-
 basis/classes/struct/struct.factor                 | 2 +-
 basis/http/client/client.factor                    | 4 ++--
 basis/locals/locals.factor                         | 4 ++--
 basis/math/rectangles/rectangles.factor            | 2 +-
 basis/math/vectors/simd/simd.factor                | 2 +-
 basis/peg/peg.factor                               | 4 ++--
 basis/regexp/regexp.factor                         | 4 ++--
 basis/specialized-arrays/specialized-arrays.factor | 4 ++--
 basis/stack-checker/errors/errors.factor           | 2 +-
 basis/typed/typed.factor                           | 4 ++--
 basis/ui/gadgets/gadgets.factor                    | 2 +-
 basis/unix/unix.factor                             | 2 +-
 basis/urls/urls.factor                             | 2 +-
 basis/windows/com/syntax/syntax.factor             | 2 +-
 basis/x11/x11.factor                               | 2 +-
 basis/xml/syntax/syntax.factor                     | 2 +-
 extra/game/loop/loop.factor                        | 4 ++--
 extra/gpu/shaders/shaders.factor                   | 2 +-
 22 files changed, 30 insertions(+), 30 deletions(-)

diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor
index 0237ed99ee..dc278df572 100644
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@@ -20,8 +20,8 @@ IN: bootstrap.compiler
     "alien.remote-control" require
 ] unless
 
-"prettyprint" "alien.prettyprint" require-when
-"debugger" "alien.debugger" require-when
+{ "boostrap.compiler" "prettyprint" } "alien.prettyprint" require-when
+{ "boostrap.compiler" "debugger" } "alien.debugger" require-when
 
 "cpu." cpu name>> append require
 
diff --git a/basis/bootstrap/handbook/handbook.factor b/basis/bootstrap/handbook/handbook.factor
index 11f7349b79..ef7a456b7b 100644
--- a/basis/bootstrap/handbook/handbook.factor
+++ b/basis/bootstrap/handbook/handbook.factor
@@ -1,4 +1,4 @@
 USING: vocabs.loader vocabs kernel ;
 IN: bootstrap.handbook
 
-"bootstrap.help" "help.handbook" require-when
+{ "boostrap.handbook" "bootstrap.help" } "help.handbook" require-when
diff --git a/basis/bootstrap/threads/threads.factor b/basis/bootstrap/threads/threads.factor
index 3a8fe98cf4..2bc8d612b6 100644
--- a/basis/bootstrap/threads/threads.factor
+++ b/basis/bootstrap/threads/threads.factor
@@ -4,6 +4,6 @@ USING: vocabs.loader kernel io.thread threads
 compiler.utilities namespaces ;
 IN: bootstrap.threads
 
-"debugger" "debugger.threads" require-when
+{ "bootstrap.threads" "debugger" } "debugger.threads" require-when
 
 [ yield ] yield-hook set-global
diff --git a/basis/bootstrap/ui/tools/tools.factor b/basis/bootstrap/ui/tools/tools.factor
index 7db69ce9c1..3efd156983 100644
--- a/basis/bootstrap/ui/tools/tools.factor
+++ b/basis/bootstrap/ui/tools/tools.factor
@@ -4,7 +4,7 @@ USING: kernel vocabs vocabs.loader sequences system ;
 [ "bootstrap." prepend vocab ] all? [
     "ui.tools" require
 
-    "ui.backend.cocoa" "ui.backend.cocoa.tools" require-when
+    { "ui.backend.cocoa" } "ui.backend.cocoa.tools" require-when
 
     "ui.tools.walker" require
 ] when
diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index ffde233748..605ee573f5 100644
--- a/basis/classes/struct/struct.factor
+++ b/basis/classes/struct/struct.factor
@@ -404,4 +404,4 @@ FUNCTOR-SYNTAX: STRUCT:
 
 USING: vocabs vocabs.loader ;
 
-"prettyprint" "classes.struct.prettyprint" require-when
+{ "classes.struct" "prettyprint" } "classes.struct.prettyprint" require-when
diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor
index 1221ee39f3..aa2fc8962b 100644
--- a/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@ -194,6 +194,6 @@ ERROR: download-failed response ;
 : http-delete ( url -- response data )
     <delete-request> http-request ;
 
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
 
-"debugger" "http.client.debugger" require-when
+{ "http.client" "debugger" } "http.client.debugger" require-when
diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
index 7d67881c47..5fd12e2fb3 100644
--- a/basis/locals/locals.factor
+++ b/basis/locals/locals.factor
@@ -26,5 +26,5 @@ SYNTAX: MEMO:: (::) define-memoized ;
     "locals.fry"
 } [ require ] each
 
-"prettyprint" "locals.definitions" require-when
-"prettyprint" "locals.prettyprint" require-when
+{ "locals" "prettyprint" } "locals.definitions" require-when
+{ "locals" "prettyprint" } "locals.prettyprint" require-when
diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor
index 78ac5457bc..15f4d5376d 100644
--- a/basis/math/rectangles/rectangles.factor
+++ b/basis/math/rectangles/rectangles.factor
@@ -64,4 +64,4 @@ M: rect contains-point?
 
 USE: vocabs.loader
 
-"prettyprint" "math.rectangles.prettyprint" require-when
+{ "math.rectangles" "prettyprint" } "math.rectangles.prettyprint" require-when
diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor
index 65d6e113bf..c845a4df63 100644
--- a/basis/math/vectors/simd/simd.factor
+++ b/basis/math/vectors/simd/simd.factor
@@ -339,4 +339,4 @@ M: short-8 v*hs+
 M: int-4 v*hs+
     int-4-rep [ (simd-v*hs+) ] [ call-next-method ] vv->v-op longlong-2-cast ; inline
 
-"mirrors" "math.vectors.simd.mirrors" require-when
+{ "math.vectors.simd" "mirrors" } "math.vectors.simd.mirrors" require-when
diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor
index ca7d28bb97..e50c1d8d95 100644
--- a/basis/peg/peg.factor
+++ b/basis/peg/peg.factor
@@ -628,6 +628,6 @@ SYNTAX: PEG:
         ] append!
     ] ;
 
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
 
-"debugger" "peg.debugger" require-when
+{ "debugger" "peg" } "peg.debugger" require-when
diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor
index eea0a26ea5..bbfe440967 100644
--- a/basis/regexp/regexp.factor
+++ b/basis/regexp/regexp.factor
@@ -216,6 +216,6 @@ SYNTAX: R` CHAR: ` parsing-regexp ;
 SYNTAX: R{ CHAR: } parsing-regexp ;
 SYNTAX: R| CHAR: | parsing-regexp ;
 
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
 
-"prettyprint" "regexp.prettyprint" require-when
+{ "prettyprint" "regexp" } "regexp.prettyprint" require-when
diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor
index c82ebd78c8..38f97303ba 100644
--- a/basis/specialized-arrays/specialized-arrays.factor
+++ b/basis/specialized-arrays/specialized-arrays.factor
@@ -173,6 +173,6 @@ SYNTAX: SPECIALIZED-ARRAYS:
 SYNTAX: SPECIALIZED-ARRAY:
     scan-c-type define-array-vocab use-vocab ;
 
-"prettyprint" "specialized-arrays.prettyprint" require-when
+{ "specialized-arrays" "prettyprint" } "specialized-arrays.prettyprint" require-when
 
-"mirrors" "specialized-arrays.mirrors" require-when
+{ "specialized-arrays" "mirrors" } "specialized-arrays.mirrors" require-when
diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor
index 5eca37ffbe..f3aeb7bb64 100644
--- a/basis/stack-checker/errors/errors.factor
+++ b/basis/stack-checker/errors/errors.factor
@@ -35,4 +35,4 @@ ERROR: bad-declaration-error < inference-error declaration ;
 
 ERROR: unbalanced-branches-error < inference-error word quots declareds actuals ;
 
-"debugger" "stack-checker.errors.prettyprint" require-when
+{ "stack-checker.errors" "debugger" } "stack-checker.errors.prettyprint" require-when
diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor
index df46303b79..65b21fcc38 100644
--- a/basis/typed/typed.factor
+++ b/basis/typed/typed.factor
@@ -164,6 +164,6 @@ SYNTAX: TYPED:
 SYNTAX: TYPED::
     (::) define-typed ;
 
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
 
-"prettyprint" "typed.prettyprint" require-when
+{ "typed" "prettyprint" } "typed.prettyprint" require-when
diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor
index dca340cd3b..3c1ece1f5e 100644
--- a/basis/ui/gadgets/gadgets.factor
+++ b/basis/ui/gadgets/gadgets.factor
@@ -395,4 +395,4 @@ M: f request-focus-on 2drop ;
 
 USE: vocabs.loader
 
-"prettyprint" "ui.gadgets.prettyprint" require-when
+{ "ui.gadgets" "prettyprint" } "ui.gadgets.prettyprint" require-when
diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor
index dbbfbcce6e..d860bf490e 100644
--- a/basis/unix/unix.factor
+++ b/basis/unix/unix.factor
@@ -72,6 +72,6 @@ M: unix open-file [ open ] unix-system-call ;
 
 <<
 
-"debugger" "unix.debugger" require-when
+{ "unix" "debugger" } "unix.debugger" require-when
 
 >>
diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor
index cd470a451a..0f89ba0d9f 100644
--- a/basis/urls/urls.factor
+++ b/basis/urls/urls.factor
@@ -185,4 +185,4 @@ SYNTAX: URL" lexer get skip-blank parse-string >url suffix! ;
 
 USE: vocabs.loader
 
-"prettyprint" "urls.prettyprint" require-when
+{ "urls" "prettyprint" } "urls.prettyprint" require-when
diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor
index 9d74ac49f8..dc6a0604fb 100644
--- a/basis/windows/com/syntax/syntax.factor
+++ b/basis/windows/com/syntax/syntax.factor
@@ -96,4 +96,4 @@ SYNTAX: GUID: scan string>guid suffix! ;
 
 USE: vocabs.loader
 
-"prettyprint" "windows.com.prettyprint" require-when
+{ "windows.com" "prettyprint" } "windows.com.prettyprint" require-when
diff --git a/basis/x11/x11.factor b/basis/x11/x11.factor
index e91c6a6909..67c94c88ea 100644
--- a/basis/x11/x11.factor
+++ b/basis/x11/x11.factor
@@ -33,4 +33,4 @@ SYMBOL: root
 : with-x ( display-string quot -- )
     [ init-x ] dip [ close-x ] [ ] cleanup ; inline
 
-"io.backend.unix" "x11.io.unix" require-when
+{ "x11" "io.backend.unix" } "x11.io.unix" require-when
diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor
index a58526faa3..e7e8714b29 100644
--- a/basis/xml/syntax/syntax.factor
+++ b/basis/xml/syntax/syntax.factor
@@ -177,4 +177,4 @@ SYNTAX: [XML
 
 USE: vocabs.loader
 
-"inverse" "xml.syntax.inverse" require-when
+{ "xml.syntax" "inverse" } "xml.syntax.inverse" require-when
diff --git a/extra/game/loop/loop.factor b/extra/game/loop/loop.factor
index ffe5acd879..312d7dbd1c 100644
--- a/extra/game/loop/loop.factor
+++ b/extra/game/loop/loop.factor
@@ -112,6 +112,6 @@ PRIVATE>
 M: game-loop dispose
     stop-loop ;
 
-USING: vocabs vocabs.loader ;
+USE: vocabs.loader
 
-"prettyprint" "game.loop.prettyprint" require-when
+{ "game.loop" "prettyprint" } "game.loop.prettyprint" require-when
diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor
index 974f2f8070..8a2931e431 100755
--- a/extra/gpu/shaders/shaders.factor
+++ b/extra/gpu/shaders/shaders.factor
@@ -632,4 +632,4 @@ M: program-instance dispose
     [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
     reset-memos ;
 
-"prettyprint" "gpu.shaders.prettyprint" require-when
+{ "gpu.shaders" "prettyprint" } "gpu.shaders.prettyprint" require-when

From 26c3bf2611832a156b46d160553e7c203bf16ba1 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Sun, 18 Apr 2010 14:44:52 -0500
Subject: [PATCH 007/158] Adding docs on null? and the changes for require-when

---
 core/sets/sets-docs.factor            | 6 ++++++
 core/vocabs/loader/loader-docs.factor | 8 ++++----
 core/vocabs/loader/loader.factor      | 4 ++--
 3 files changed, 12 insertions(+), 6 deletions(-)

diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor
index 5bde8a1feb..5ae9641734 100644
--- a/core/sets/sets-docs.factor
+++ b/core/sets/sets-docs.factor
@@ -23,6 +23,8 @@ ARTICLE: "set-operations" "Operations on sets"
     adjoin
     delete
 }
+"To test if a set is the empty set:"
+{ $subsections null? }
 "Basic mathematical operations, which any type of set may override for efficiency:"
 { $subsections
     diff
@@ -178,3 +180,7 @@ HELP: within
 HELP: without
 { $values { "seq" sequence } { "set" set } { "subseq" sequence } }
 { $description "Returns the subsequence of the given sequence consisting of things that are not members of the set. This may contain duplicates, if the sequence has duplicates." } ;
+
+HELP: null?
+{ $values { "set" set } { "?" "a boolean" } }
+{ $description "Tests whether the given set is empty. This outputs " { $snippet "t" } " when given a null set of any type." } ;
diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor
index d5a6be5335..423abbc277 100755
--- a/core/vocabs/loader/loader-docs.factor
+++ b/core/vocabs/loader/loader-docs.factor
@@ -114,10 +114,10 @@ HELP: require
 { $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "vocabs.refresh" } "." } ;
 
 HELP: require-when
-{ $values { "if" "a vocabulary specifier" } { "then" "a vocabulary specifier" } }
-{ $description "Loads the " { $snippet "then" } " vocabulary if it is not loaded and the " { $snippet "if" } " vocabulary is. If the " { $snippet "if" } " vocabulary is not loaded now, but it is later, then the " { $snippet "then" } " vocabulary will be loaded along with it at that time." }
-{ $notes "This is used to express a joint dependency of vocabularies. If vocabularies " { $snippet "a" } " and " { $snippet "b" } " use code in vocabulary " { $snippet "c" } " to interact, then the following line can be placed in " { $snippet "a" } " in order express the dependency."
-{ $code "\"b\" \"c\" require-when" } } ;
+{ $values { "if" "a sequence of vocabulary specifiers" } { "then" "a vocabulary specifier" } }
+{ $description "Loads the " { $snippet "then" } " vocabulary if it is not loaded and all of the " { $snippet "if" } " vocabulary is. If some of the " { $snippet "if" } " vocabularies are not loaded now, but they are later, then the " { $snippet "then" } " vocabulary will be loaded along with the final one." }
+{ $notes "This is used to express a joint dependency of vocabularies. If vocabularies " { $snippet "a" } " and " { $snippet "b" } " use code in vocabulary " { $snippet "c" } " to interact, then the following line, which can be placed in " { $snippet "a" } " or " { $snippet "b" } ", expresses the dependency."
+{ $code "{ \"a\" \"b\" } \"c\" require-when" } } ;
 
 HELP: run
 { $values { "vocab" "a vocabulary specifier" } }
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index b09ba8c2bc..2945736f3c 100644
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -3,7 +3,7 @@
 USING: namespaces make sequences io io.files io.pathnames kernel
 assocs words vocabs definitions parser continuations hashtables
 sorting source-files arrays combinators strings system
-math.parser splitting init accessors sets fry ;
+math.parser splitting init accessors sets ;
 IN: vocabs.loader
 
 SYMBOL: vocab-roots
@@ -76,7 +76,7 @@ require-when-table [ V{ } clone ] initialize
     vocab-name require-when-vocabs get in? [
         require-when-table get [
             [ [ vocab ] all? ] dip
-            '[ _ require ] when
+            [ require ] curry when
         ] assoc-each
     ] when ;
 

From eb3c6f414b6e955f54946c4fd885bf9330855869 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 18 Apr 2010 20:52:09 -0500
Subject: [PATCH 008/158] Fix the ptx path in cuda demo

---
 extra/cuda/demos/hello-world/hello-world.factor | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/extra/cuda/demos/hello-world/hello-world.factor b/extra/cuda/demos/hello-world/hello-world.factor
index 6a598dda44..540c4b9148 100644
--- a/extra/cuda/demos/hello-world/hello-world.factor
+++ b/extra/cuda/demos/hello-world/hello-world.factor
@@ -2,16 +2,16 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.strings cuda cuda.syntax destructors
 io.encodings.utf8 kernel locals math prettyprint sequences ;
-IN: cuda.hello-world
+IN: cuda.demos.hello-world
 
-CUDA-LIBRARY: hello vocab:cuda/hello.ptx
+CUDA-LIBRARY: hello vocab:cuda/demos/hello-world/hello.ptx
 
 CUDA-FUNCTION: helloWorld ( char* string-ptr ) ;
 
 :: cuda-hello-world ( -- )
     T{ launcher
         { device 0 }
-        { path "vocab:cuda/hello.ptx" }
+        { path "vocab:cuda/demos/hello-world/hello.ptx" }
     } [
         "Hello World!" [ - ] map-index malloc-device-string &dispose dup :> str
 

From cf69c58eee14780f2e89260ed37abf0f2942bd51 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 18 Apr 2010 14:24:17 -0500
Subject: [PATCH 009/158] binary-search: use nth-unsafe for a further
 performance gain

---
 basis/binary-search/binary-search.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/binary-search/binary-search.factor b/basis/binary-search/binary-search.factor
index 36e983a1c8..db40408d5e 100644
--- a/basis/binary-search/binary-search.factor
+++ b/basis/binary-search/binary-search.factor
@@ -1,14 +1,14 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators hints kernel locals math
-math.order sequences ;
+math.order sequences sequences.private ;
 IN: binary-search
 
 <PRIVATE
 
 :: (search) ( seq from to quot: ( elt -- <=> ) -- i elt )
     from to + 2/ :> midpoint@
-    midpoint@ seq nth :> midpoint
+    midpoint@ seq nth-unsafe :> midpoint
 
     to from - 1 <= [
         midpoint@ midpoint

From 2aaf24412a87794f33dbb5bf3033ae233c26ae67 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 18 Apr 2010 15:26:31 -0500
Subject: [PATCH 010/158] compiler: change how 'f' is represented in low level
 IR to simplify some code, and fuse a ##load-constant of a word with a
 ##compare into a ##compare-imm on x86-32. This eliminates a spill from
 binary-search

---
 .../cfg/alias-analysis/alias-analysis.factor  |   2 +-
 basis/compiler/cfg/builder/builder.factor     |   4 +-
 basis/compiler/cfg/hats/hats.factor           |  14 ++-
 .../cfg/intrinsics/fixnum/fixnum.factor       |   5 +-
 .../value-numbering/rewrite/rewrite.factor    |  29 +++--
 .../value-numbering-tests.factor              |  85 +++++++++-----
 basis/compiler/tests/low-level-ir.factor      |   4 +-
 basis/cpu/architecture/architecture.factor    |  22 +++-
 basis/cpu/x86/32/32.factor                    |  17 +--
 basis/cpu/x86/x86.factor                      | 109 ++++++++++--------
 10 files changed, 176 insertions(+), 115 deletions(-)

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 44326c179f..2e0684c5d0 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -287,7 +287,7 @@ M: ##copy analyze-aliases*
 M: ##compare analyze-aliases*
     call-next-method
     dup useless-compare? [
-        dst>> \ f type-number \ ##load-immediate new-insn
+        dst>> f \ ##load-constant new-insn
         analyze-aliases*
     ] when ;
 
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 529c3b5ae6..8dec435b9c 100644
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -123,7 +123,7 @@ M: #recursive emit-node
     and ;
 
 : emit-trivial-if ( -- )
-    ds-pop \ f type-number cc/= ^^compare-imm ds-push ;
+    ds-pop f cc/= ^^compare-imm ds-push ;
 
 : trivial-not-if? ( #if -- ? )
     children>> first2
@@ -132,7 +132,7 @@ M: #recursive emit-node
     and ;
 
 : emit-trivial-not-if ( -- )
-    ds-pop \ f type-number cc= ^^compare-imm ds-push ;
+    ds-pop f cc= ^^compare-imm ds-push ;
 
 : emit-actual-if ( #if -- )
     ! Inputs to the final instruction need to be copied because of
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index 9d1945c525..fb89b36efa 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays kernel layouts math
-namespaces sequences combinators splitting parser effects
-words cpu.architecture compiler.cfg.registers
+USING: accessors arrays byte-arrays combinators.short-circuit
+kernel layouts math namespaces sequences combinators splitting
+parser effects words cpu.architecture compiler.cfg.registers
 compiler.cfg.instructions compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.hats
 
@@ -41,11 +41,13 @@ insn-classes get [
 
 >>
 
+: immutable? ( obj -- ? )
+    { [ float? ] [ word? ] [ not ] } 1|| ; inline
+
 : ^^load-literal ( obj -- dst )
     [ next-vreg dup ] dip {
-        { [ dup not ] [ drop \ f type-number ##load-immediate ] }
         { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
-        { [ dup float? ] [ ##load-constant ] }
+        { [ dup immutable? ] [ ##load-constant ] }
         [ ##load-reference ]
     } cond ;
 
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index e4d1735eae..ad7e02df8a 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -20,9 +20,6 @@ IN: compiler.cfg.intrinsics.fixnum
     0 cc= ^^compare-imm
     ds-push ;
 
-: tag-literal ( n -- tagged )
-    literal>> [ tag-fixnum ] [ \ f type-number ] if* ;
-
 : emit-fixnum-op ( insn -- )
     [ 2inputs ] dip call ds-push ; inline
 
@@ -44,7 +41,7 @@ IN: compiler.cfg.intrinsics.fixnum
         { [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] }
         [ drop emit-fixnum-shift-general ]
     } cond ;
-    
+
 : emit-fixnum-bitnot ( -- )
     ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
 
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 0fa0314c3e..398c73c32c 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -27,6 +27,12 @@ IN: compiler.cfg.value-numbering.rewrite
         [ value>> immediate-bitwise? ]
     } 1&& ;
 
+: vreg-immediate-comparand? ( vreg -- ? )
+    vreg>expr {
+        [ constant-expr? ]
+        [ value>> immediate-comparand? ]
+    } 1&& ;
+
 ! Outputs f to mean no change
 
 GENERIC: rewrite ( insn -- insn/f )
@@ -35,10 +41,7 @@ M: insn rewrite drop f ;
 
 : ##branch-t? ( insn -- ? )
     dup ##compare-imm-branch? [
-        {
-            [ cc>> cc/= eq? ]
-            [ src2>> \ f type-number eq? ]
-        } 1&&
+        { [ cc>> cc/= eq? ] [ src2>> not ] } 1&&
     ] [ drop f ] if ; inline
 
 : general-compare-expr? ( insn -- ? )
@@ -118,8 +121,8 @@ M: ##compare-imm rewrite-tagged-comparison
 : rewrite-redundant-comparison? ( insn -- ? )
     {
         [ src1>> vreg>expr general-compare-expr? ]
-        [ src2>> \ f type-number = ]
-        [ cc>> { cc= cc/= } member-eq? ]
+        [ src2>> not ]
+        [ cc>> { cc= cc/= } member? ]
     } 1&& ; inline
 
 : rewrite-redundant-comparison ( insn -- insn' )
@@ -189,8 +192,8 @@ M: ##compare-imm-branch rewrite
 
 M: ##compare-branch rewrite
     {
-        { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm-branch ] }
-        { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm-branch ] }
+        { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm-branch ] }
+        { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm-branch ] }
         { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
         [ drop f ]
     } cond ;
@@ -209,19 +212,15 @@ M: ##compare-branch rewrite
     next-vreg \ ##compare-imm new-insn ; inline
 
 : >boolean-insn ( insn ? -- insn' )
-    [ dst>> ] dip
-    {
-        { t [ t \ ##load-constant new-insn ] }
-        { f [ \ f type-number \ ##load-immediate new-insn ] }
-    } case ;
+    [ dst>> ] dip \ ##load-constant new-insn ;
 
 : rewrite-self-compare ( insn -- insn' )
     dup (rewrite-self-compare) >boolean-insn ;
 
 M: ##compare rewrite
     {
-        { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-imm ] }
-        { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-imm ] }
+        { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm ] }
+        { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm ] }
         { [ dup self-compare? ] [ rewrite-self-compare ] }
         [ drop f ]
     } cond ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index ac992ff98d..7e41df69d6 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -4,7 +4,8 @@ cpu.architecture tools.test kernel math combinators.short-circuit
 accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce
 compiler.cfg.ssa.destruction compiler.cfg.loop-detection
 compiler.cfg.representations compiler.cfg assocs vectors arrays
-layouts literals namespaces alien compiler.cfg.value-numbering.simd ;
+layouts literals namespaces alien compiler.cfg.value-numbering.simd
+system ;
 IN: compiler.cfg.value-numbering.tests
 
 : trim-temps ( insns -- insns )
@@ -82,7 +83,7 @@ IN: compiler.cfg.value-numbering.tests
         T{ ##load-reference f 1 + }
         T{ ##peek f 2 D 0 }
         T{ ##compare f 4 2 1 cc> }
-        T{ ##compare-imm f 6 4 $[ \ f type-number ] cc/= }
+        T{ ##compare-imm f 6 4 f cc/= }
         T{ ##replace f 6 D 0 }
     } value-numbering-step trim-temps
 ] unit-test
@@ -100,7 +101,7 @@ IN: compiler.cfg.value-numbering.tests
         T{ ##load-reference f 1 + }
         T{ ##peek f 2 D 0 }
         T{ ##compare f 4 2 1 cc<= }
-        T{ ##compare-imm f 6 4 $[ \ f type-number ] cc= }
+        T{ ##compare-imm f 6 4 f cc= }
         T{ ##replace f 6 D 0 }
     } value-numbering-step trim-temps
 ] unit-test
@@ -118,7 +119,7 @@ IN: compiler.cfg.value-numbering.tests
         T{ ##peek f 8 D 0 }
         T{ ##peek f 9 D -1 }
         T{ ##compare-float-unordered f 12 8 9 cc< }
-        T{ ##compare-imm f 14 12 $[ \ f type-number ] cc= }
+        T{ ##compare-imm f 14 12 f cc= }
         T{ ##replace f 14 D 0 }
     } value-numbering-step trim-temps
 ] unit-test
@@ -135,7 +136,7 @@ IN: compiler.cfg.value-numbering.tests
         T{ ##peek f 29 D -1 }
         T{ ##peek f 30 D -2 }
         T{ ##compare f 33 29 30 cc<= }
-        T{ ##compare-imm-branch f 33 $[ \ f type-number ] cc/= }
+        T{ ##compare-imm-branch f 33 f cc/= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -149,7 +150,7 @@ IN: compiler.cfg.value-numbering.tests
     {
         T{ ##peek f 1 D -1 }
         T{ ##test-vector f 2 1 f float-4-rep vcc-any }
-        T{ ##compare-imm-branch f 2 $[ \ f type-number ] cc/= }
+        T{ ##compare-imm-branch f 2 f cc/= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -418,6 +419,36 @@ IN: compiler.cfg.value-numbering.tests
     } value-numbering-step trim-temps
 ] unit-test
 
+cpu x86.32? [
+    [
+        {
+            T{ ##peek f 0 D 0 }
+            T{ ##load-constant f 1 + }
+            T{ ##compare-imm f 2 0 + cc= }
+        }
+    ] [
+        {
+            T{ ##peek f 0 D 0 }
+            T{ ##load-constant f 1 + }
+            T{ ##compare f 2 0 1 cc= }
+        } value-numbering-step trim-temps
+    ] unit-test
+
+    [
+        {
+            T{ ##peek f 0 D 0 }
+            T{ ##load-constant f 1 + }
+            T{ ##compare-imm-branch f 0 + cc= }
+        }
+    ] [
+        {
+            T{ ##peek f 0 D 0 }
+            T{ ##load-constant f 1 + }
+            T{ ##compare-branch f 0 1 cc= }
+        } value-numbering-step trim-temps
+    ] unit-test
+] when
+
 [
     {
         T{ ##peek f 0 D 0 }
@@ -432,6 +463,20 @@ IN: compiler.cfg.value-numbering.tests
     } value-numbering-step trim-temps
 ] unit-test
 
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-constant f 1 3.5 }
+        T{ ##compare-branch f 0 1 cc= }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-constant f 1 3.5 }
+        T{ ##compare-branch f 0 1 cc= }
+    } value-numbering-step trim-temps
+] unit-test
+
 [
     {
         T{ ##peek f 0 D 0 }
@@ -460,20 +505,6 @@ IN: compiler.cfg.value-numbering.tests
     } value-numbering-step
 ] unit-test
 
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 3.5 }
-        T{ ##compare-branch f 0 1 cc= }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 3.5 }
-        T{ ##compare-branch f 0 1 cc= }
-    } value-numbering-step trim-temps
-] unit-test
-
 [
     {
         T{ ##peek f 0 D 0 }
@@ -1073,7 +1104,7 @@ cell 8 = [
     {
         T{ ##load-immediate f 1 10 }
         T{ ##load-immediate f 2 20 }
-        T{ ##load-immediate f 3 $[ \ f type-number ] }
+        T{ ##load-constant f 3 f }
     }
 ] [
     {
@@ -1115,7 +1146,7 @@ cell 8 = [
     {
         T{ ##load-immediate f 1 10 }
         T{ ##load-immediate f 2 20 }
-        T{ ##load-immediate f 3 $[ \ f type-number ] }
+        T{ ##load-constant f 3 f }
     }
 ] [
     {
@@ -1128,7 +1159,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 $[ \ f type-number ] }
+        T{ ##load-constant f 1 f }
     }
 ] [
     {
@@ -1152,7 +1183,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 $[ \ f type-number ] }
+        T{ ##load-constant f 1 f }
     }
 ] [
     {
@@ -1176,7 +1207,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 $[ \ f type-number ] }
+        T{ ##load-constant f 1 f }
     }
 ] [
     {
@@ -1557,7 +1588,7 @@ cell 8 = [
     {
         T{ ##peek f 0 D 0 }
         T{ ##compare f 1 0 0 cc<= }
-        T{ ##compare-imm-branch f 1 $[ \ f type-number ] cc/= }
+        T{ ##compare-imm-branch f 1 f cc/= }
     } test-branch-folding
 ] unit-test
 
@@ -1659,7 +1690,7 @@ V{
     T{ ##copy { dst 21 } { src 20 } { rep any-rep } }
     T{ ##compare-imm-branch
         { src1 21 }
-        { src2 $[ \ f type-number ] }
+        { src2 f }
         { cc cc/= }
     }
 } 1 test-bb
diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index bc7f3fa2f2..5f00d251cf 100644
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -33,10 +33,10 @@ IN: compiler.tests.low-level-ir
     compile-test-cfg
     execute( -- result ) ;
 
-! loading immediates
+! loading constants
 [ f ] [
     V{
-        T{ ##load-immediate f 0 $[ \ f type-number ] }
+        T{ ##load-constant f 0 f }
     } compile-test-bb
 ] unit-test
 
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 1aaf1bf2ea..0051e83356 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -496,15 +496,27 @@ M: reg-class param-reg param-regs nth ;
 
 M: stack-params param-reg 2drop ;
 
-! Is this integer small enough to be an immediate operand for
-! %add-imm, %sub-imm, and %mul-imm?
+! Can this value be an immediate operand for %add-imm, %sub-imm,
+! or %mul-imm?
 HOOK: immediate-arithmetic? cpu ( n -- ? )
 
-! Is this integer small enough to be an immediate operand for
-! %and-imm, %or-imm, and %xor-imm?
+! Can this value be an immediate operand for %and-imm, %or-imm,
+! or %xor-imm?
 HOOK: immediate-bitwise? cpu ( n -- ? )
 
-! What c-type describes the implicit struct return pointer for large structs?
+! Can this value be an immediate operand for %compare-imm or
+! %compare-imm-branch?
+HOOK: immediate-comparand? cpu ( n -- ? )
+
+M: object immediate-comparand? ( n -- ? )
+    {
+        { [ dup integer? ] [ immediate-arithmetic? ] }
+        { [ dup not ] [ drop t ] }
+        [ drop f ]
+    } cond ;
+
+! What c-type describes the implicit struct return pointer for
+! large structs?
 HOOK: struct-return-pointer-type cpu ( -- c-type )
 
 ! Is this structure small enough to be returned in registers?
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 05c627fb99..00422dcf03 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -2,16 +2,19 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: locals alien alien.c-types alien.libraries alien.syntax
 arrays kernel fry math namespaces sequences system layouts io
-vocabs.loader accessors init classes.struct combinators command-line
-make compiler compiler.units compiler.constants compiler.alien
-compiler.codegen compiler.codegen.fixup
-compiler.cfg.instructions compiler.cfg.builder
-compiler.cfg.intrinsics compiler.cfg.stack-frame
-cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
-cpu.architecture vm ;
+vocabs.loader accessors init classes.struct combinators
+command-line make words compiler compiler.units
+compiler.constants compiler.alien compiler.codegen
+compiler.codegen.fixup compiler.cfg.instructions
+compiler.cfg.builder compiler.cfg.intrinsics
+compiler.cfg.stack-frame cpu.x86.assembler
+cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
 FROM: layouts => cell ;
 IN: cpu.x86.32
 
+M: x86.32 immediate-comparand? ( n -- ? )
+    [ call-next-method ] [ word? ] bi or ;
+
 M: x86.32 machine-registers
     {
         { int-regs { EAX ECX EDX EBP EBX } }
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 028cca48e3..220db859d0 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -491,43 +491,60 @@ M: x86 %push-context-stack ( -- )
 
 M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 
-:: %boolean ( dst temp word -- )
+:: (%boolean) ( dst temp insn -- )
     dst \ f type-number MOV
     temp 0 MOV \ t rc-absolute-cell rel-immediate
-    dst temp word execute ; inline
+    dst temp insn execute ; inline
 
-: (%compare) ( src1 src2 cc -- )
-    2over [ { cc= cc/= } member? ] [ register? ] [ 0 = ] tri* and and
-    [ drop dup TEST ]
-    [ CMP ] if ;
+: %boolean ( dst cc temp -- )
+    swap order-cc {
+        { cc<  [ \ CMOVL (%boolean) ] }
+        { cc<= [ \ CMOVLE (%boolean) ] }
+        { cc>  [ \ CMOVG (%boolean) ] }
+        { cc>= [ \ CMOVGE (%boolean) ] }
+        { cc=  [ \ CMOVE (%boolean) ] }
+        { cc/= [ \ CMOVNE (%boolean) ] }
+    } case ;
 
 M:: x86 %compare ( dst src1 src2 cc temp -- )
-    src1 src2 cc (%compare)
-    cc order-cc {
-        { cc<  [ dst temp \ CMOVL %boolean ] }
-        { cc<= [ dst temp \ CMOVLE %boolean ] }
-        { cc>  [ dst temp \ CMOVG %boolean ] }
-        { cc>= [ dst temp \ CMOVGE %boolean ] }
-        { cc=  [ dst temp \ CMOVE %boolean ] }
-        { cc/= [ dst temp \ CMOVNE %boolean ] }
-    } case ;
+    src1 src2 CMP
+    dst cc temp %boolean ;
 
-M: x86 %compare-imm ( dst src1 src2 cc temp -- )
-    %compare ;
+: use-test? ( src1 src2 cc -- ? )
+    [ register? ] [ 0 = ] [ { cc= cc/= } member? ] tri* and and ;
+
+: (%compare-tagged) ( src1 src2 -- )
+    [ HEX: ffffffff CMP ] dip rc-absolute rel-immediate ;
+
+: (%compare-imm) ( src1 src2 cc -- )
+    {
+        { [ 3dup use-test? ] [ 2drop dup TEST ] }
+        { [ over integer? ] [ drop CMP ] }
+        { [ over word? ] [ drop (%compare-tagged) ] }
+        { [ over not ] [ 2drop f type-number CMP ] }
+    } cond ;
+
+M:: x86 %compare-imm ( dst src1 src2 cc temp -- )
+    src1 src2 cc (%compare-imm)
+    dst cc temp %boolean ;
+
+: %branch ( label cc -- )
+    order-cc {
+        { cc<  [ JL ] }
+        { cc<= [ JLE ] }
+        { cc>  [ JG ] }
+        { cc>= [ JGE ] }
+        { cc=  [ JE ] }
+        { cc/= [ JNE ] }
+    } case ;
 
 M:: x86 %compare-branch ( label src1 src2 cc -- )
-    src1 src2 cc (%compare)
-    cc order-cc {
-        { cc<  [ label JL ] }
-        { cc<= [ label JLE ] }
-        { cc>  [ label JG ] }
-        { cc>= [ label JGE ] }
-        { cc=  [ label JE ] }
-        { cc/= [ label JNE ] }
-    } case ;
+    src1 src2 CMP
+    label cc %branch ;
 
-M: x86 %compare-imm-branch ( label src1 src2 cc -- )
-    %compare-branch ;
+M:: x86 %compare-imm-branch ( label src1 src2 cc -- )
+    src1 src2 cc (%compare-imm)
+    label cc %branch ;
 
 M: x86 %add-float double-rep two-operand ADDSD ;
 M: x86 %sub-float double-rep two-operand SUBSD ;
@@ -569,20 +586,20 @@ M: x86 %float>integer CVTTSD2SI ;
 
 :: (%compare-float) ( dst src1 src2 cc temp compare -- )
     cc {
-        { cc<    [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA  %boolean ] }
-        { cc<=   [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
-        { cc>    [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA  %boolean ] }
-        { cc>=   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
-        { cc=    [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= %boolean ] }
-        { cc<>   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE %boolean ] }
-        { cc<>=  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP %boolean ] }
-        { cc/<   [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
-        { cc/<=  [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB  %boolean ] }
-        { cc/>   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
-        { cc/>=  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB  %boolean ] }
-        { cc/=   [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= %boolean ] }
-        { cc/<>  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE  %boolean ] }
-        { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP  %boolean ] }
+        { cc<    [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA  (%boolean) ] }
+        { cc<=   [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+        { cc>    [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA  (%boolean) ] }
+        { cc>=   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE (%boolean) ] }
+        { cc=    [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= (%boolean) ] }
+        { cc<>   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE (%boolean) ] }
+        { cc<>=  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP (%boolean) ] }
+        { cc/<   [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+        { cc/<=  [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB  (%boolean) ] }
+        { cc/>   [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE (%boolean) ] }
+        { cc/>=  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB  (%boolean) ] }
+        { cc/=   [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= (%boolean) ] }
+        { cc/<>  [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE  (%boolean) ] }
+        { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP  (%boolean) ] }
     } case ; inline
 
 M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
@@ -954,10 +971,10 @@ M: x86 %compare-vector-ccs
 
 :: %test-vector-mask ( dst temp mask vcc -- )
     vcc {
-        { vcc-any    [ dst dst TEST dst temp \ CMOVNE %boolean ] }
-        { vcc-none   [ dst dst TEST dst temp \ CMOVE  %boolean ] }
-        { vcc-all    [ dst mask CMP dst temp \ CMOVE  %boolean ] }
-        { vcc-notall [ dst mask CMP dst temp \ CMOVNE %boolean ] }
+        { vcc-any    [ dst dst TEST dst temp \ CMOVNE (%boolean) ] }
+        { vcc-none   [ dst dst TEST dst temp \ CMOVE  (%boolean) ] }
+        { vcc-all    [ dst mask CMP dst temp \ CMOVE  (%boolean) ] }
+        { vcc-notall [ dst mask CMP dst temp \ CMOVNE (%boolean) ] }
     } case ;
 
 : %move-vector-mask ( dst src rep -- mask )

From bc9241d2b74fbe8be072f4feeca3972ad0935bc2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 18 Apr 2010 15:26:59 -0500
Subject: [PATCH 011/158] compiler.tree.propagation.recursive: more
 fine-grained generalize-counter-interval eliminates overflow checks from
 binary-search

---
 .../tree/propagation/recursive/recursive.factor    | 14 +++++++++++---
 1 file changed, 11 insertions(+), 3 deletions(-)

diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index d4ab697e21..854e730662 100644
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors arrays fry math math.intervals
-layouts combinators namespaces locals
+USING: kernel classes.algebra sequences accessors arrays fry
+math math.intervals layouts combinators namespaces locals
 stack-checker.inlining
 compiler.tree
 compiler.tree.combinators
@@ -11,6 +11,7 @@ compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
 compiler.tree.propagation.branches
 compiler.tree.propagation.constraints ;
+FROM: sequences.private => array-capacity ;
 IN: compiler.tree.propagation.recursive
 
 : check-fixed-point ( node infos1 infos2 -- )
@@ -24,7 +25,14 @@ IN: compiler.tree.propagation.recursive
     [ label>> calls>> [ node>> node-input-infos ] map flip ]
     [ latest-input-infos ] bi ;
 
+: counter-class ( interval class -- class' )
+    dup fixnum class<= [
+        swap array-capacity-interval interval-subset?
+        [ drop array-capacity ] when
+    ] [ nip ] if ;
+
 :: generalize-counter-interval ( interval initial-interval class -- interval' )
+    interval class counter-class :> class
     {
         { [ interval initial-interval interval-subset? ] [ initial-interval ] }
         { [ interval empty-interval eq? ] [ initial-interval ] }

From 8f0739197e385dbc882df898739357fae148c5c9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 18 Apr 2010 17:47:50 -0500
Subject: [PATCH 012/158] compiler.cfg: fix some bugs introduced by the
 ##compare-imm fusion patch

---
 basis/compiler/cfg/builder/builder.factor     |  2 +-
 .../value-numbering/rewrite/rewrite.factor    | 28 ++++----
 .../value-numbering-tests.factor              | 66 +++++++++++++++++++
 basis/cpu/x86/x86.factor                      |  2 +-
 4 files changed, 82 insertions(+), 16 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 8dec435b9c..370f3d053f 100644
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -137,7 +137,7 @@ M: #recursive emit-node
 : emit-actual-if ( #if -- )
     ! Inputs to the final instruction need to be copied because of
     ! loc>vreg sync
-    ds-pop any-rep ^^copy \ f type-number cc/= ##compare-imm-branch emit-if ;
+    ds-pop any-rep ^^copy f cc/= ##compare-imm-branch emit-if ;
 
 M: #if emit-node
     {
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 398c73c32c..81f39d7da2 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -134,17 +134,12 @@ M: ##compare-imm rewrite-tagged-comparison
     } cond
     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 
-ERROR: bad-comparison ;
-
 : (fold-compare-imm) ( insn -- ? )
-    [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi
-    pick integer?
-    [ [ <=> ] dip evaluate-cc ]
-    [
-        2nip {
-            { cc= [ f ] }
-            { cc/= [ t ] }
-            [ bad-comparison ]
+    [ src1>> vreg>constant ] [ src2>> ] [ cc>> ] tri
+    2over [ integer? ] both? [ [ <=> ] dip evaluate-cc ] [
+        {
+            { cc= [ eq? ] }
+            { cc/= [ eq? not ] }
         } case
     ] if ;
 
@@ -253,7 +248,12 @@ M: ##shl-imm constant-fold* drop shift ;
 
 : constant-fold ( insn -- insn' )
     [ dst>> ]
-    [ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
+    [
+        [ src1>> vreg>constant \ f type-number or ]
+        [ src2>> ]
+        [ ]
+        tri constant-fold*
+    ] bi
     \ ##load-immediate new-insn ; inline
 
 : unary-constant-fold? ( insn -- ? )
@@ -379,7 +379,7 @@ M: ##sar-imm rewrite
         [ drop f ]
     } cond ;
 
-: insn>imm-insn ( insn op swap? -- )
+: insn>imm-insn ( insn op swap? -- new-insn )
     swap [
         [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
         [ swap ] when vreg>constant
@@ -389,13 +389,13 @@ M: ##sar-imm rewrite
     arithmetic-op?
     [ vreg-immediate-arithmetic? ] [ vreg-immediate-bitwise? ] if ;
 
-: rewrite-arithmetic ( insn op -- ? )
+: rewrite-arithmetic ( insn op -- insn/f )
     {
         { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
         [ 2drop f ]
     } cond ; inline
 
-: rewrite-arithmetic-commutative ( insn op -- ? )
+: rewrite-arithmetic-commutative ( insn op -- insn/f )
     {
         { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
         { [ over src1>> over vreg-immediate? ] [ t insn>imm-insn ] }
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 7e41df69d6..f835200702 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -519,6 +519,59 @@ cpu x86.32? [
     } value-numbering-step trim-temps
 ] unit-test
 
+! Branch folding
+[
+    {
+        T{ ##load-immediate f 1 100 }
+        T{ ##load-immediate f 2 200 }
+        T{ ##load-constant f 3 t }
+    }
+] [
+    {
+        T{ ##load-immediate f 1 100 }
+        T{ ##load-immediate f 2 200 }
+        T{ ##compare f 3 1 2 cc<= }
+    } value-numbering-step trim-temps
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f 1 100 }
+        T{ ##load-immediate f 2 200 }
+        T{ ##load-constant f 3 f }
+    }
+] [
+    {
+        T{ ##load-immediate f 1 100 }
+        T{ ##load-immediate f 2 200 }
+        T{ ##compare f 3 1 2 cc= }
+    } value-numbering-step trim-temps
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f 1 100 }
+        T{ ##load-constant f 2 f }
+    }
+] [
+    {
+        T{ ##load-immediate f 1 100 }
+        T{ ##compare-imm f 2 1 f cc= }
+    } value-numbering-step trim-temps
+] unit-test
+
+[
+    {
+        T{ ##load-constant f 1 f }
+        T{ ##load-constant f 2 t }
+    }
+] [
+    {
+        T{ ##load-constant f 1 f }
+        T{ ##compare-imm f 2 1 f cc= }
+    } value-numbering-step trim-temps
+] unit-test
+
 ! Reassociation
 [
     {
@@ -1042,6 +1095,19 @@ cell 8 = [
     } value-numbering-step
 ] unit-test
 
+! Stupid constant folding corner case
+[
+    {
+        T{ ##load-constant f 1 f }
+        T{ ##load-immediate f 2 $[ \ f type-number ] }
+    }
+] [
+    {
+        T{ ##load-constant f 1 f }
+        T{ ##and-imm f 2 1 15 }
+    } value-numbering-step
+] unit-test
+
 ! Displaced alien optimizations
 3 vreg-counter set-global
 
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 220db859d0..bab90c0f09 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -521,7 +521,7 @@ M:: x86 %compare ( dst src1 src2 cc temp -- )
         { [ 3dup use-test? ] [ 2drop dup TEST ] }
         { [ over integer? ] [ drop CMP ] }
         { [ over word? ] [ drop (%compare-tagged) ] }
-        { [ over not ] [ 2drop f type-number CMP ] }
+        { [ over not ] [ 2drop \ f type-number CMP ] }
     } cond ;
 
 M:: x86 %compare-imm ( dst src1 src2 cc temp -- )

From 2517b2fc2bcb85e469d30500c524bfe58fdaf9fb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 18 Apr 2010 21:42:19 -0500
Subject: [PATCH 013/158] compiler: combine ##load-constant followed by
 ##alien-double into a ##load-double on x86-32, saving an integer register

---
 basis/bootstrap/compiler/compiler.factor      |   2 +-
 .../cfg/instructions/instructions.factor      |   4 +
 .../preferred/preferred.factor                |  14 +-
 .../representations-tests.factor              | 116 +++++++++++++-
 .../representations/representations.factor    | 151 +++++++++++-------
 basis/compiler/codegen/codegen.factor         |   1 +
 basis/compiler/codegen/fixup/fixup.factor     |   5 +-
 basis/compiler/constants/constants.factor     |   3 +-
 .../recursive/recursive-tests.factor          |   2 +-
 basis/cpu/architecture/architecture.factor    |   8 +-
 basis/cpu/ppc/ppc.factor                      |   2 +-
 basis/cpu/x86/32/32.factor                    |  11 +-
 basis/cpu/x86/x86.factor                      |   6 +-
 vm/code_blocks.cpp                            |   3 +
 vm/compaction.cpp                             |   3 +
 vm/image.cpp                                  |   3 +
 vm/instruction_operands.cpp                   |  15 ++
 vm/instruction_operands.hpp                   |   7 +
 vm/layouts.hpp                                |   2 +
 vm/slot_visitor.hpp                           |  11 +-
 20 files changed, 290 insertions(+), 79 deletions(-)

diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor
index 0237ed99ee..90562e9fc7 100644
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@@ -57,7 +57,7 @@ gc
 
         curry compose uncurry
 
-        array-nth set-array-nth length>>
+        array-nth set-array-nth
 
         wrap probe
 
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index c015cb640b..5ddf7b4db5 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -33,6 +33,10 @@ INSN: ##load-constant
 def: dst/int-rep
 constant: obj ;
 
+INSN: ##load-double
+def: dst/double-rep
+constant: val ;
+
 INSN: ##peek
 def: dst/int-rep
 literal: loc ;
diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor
index ffb8f9a390..e4114c9249 100644
--- a/basis/compiler/cfg/representations/preferred/preferred.factor
+++ b/basis/compiler/cfg/representations/preferred/preferred.factor
@@ -68,23 +68,23 @@ PRIVATE>
     tri
 ] with-compilation-unit
 
-: each-def-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
     [ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
 
-: each-use-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
     [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
 
-: each-temp-rep ( ... insn vreg-quot: ( ... vreg rep -- ... ) -- ... )
+: each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
     [ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
 
+: each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
+    [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline
+
 : with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
     '[
         [ basic-block set ] [
             [
-                _
-                [ each-def-rep ]
-                [ each-use-rep ]
-                [ each-temp-rep ] 2tri
+                _ each-rep
             ] each-non-phi
         ] bi
     ] each-basic-block ; inline
diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor
index c50cfc4c86..a00f65e075 100644
--- a/basis/compiler/cfg/representations/representations-tests.factor
+++ b/basis/compiler/cfg/representations/representations-tests.factor
@@ -1,6 +1,7 @@
-USING: tools.test cpu.architecture
-compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.representations.preferred ;
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.representations.preferred cpu.architecture kernel
+namespaces tools.test sequences arrays system ;
 IN: compiler.cfg.representations
 
 [ { double-rep double-rep } ] [
@@ -16,4 +17,111 @@ IN: compiler.cfg.representations
        { dst 5 }
        { src 3 }
     } defs-vreg-rep
-] unit-test
\ No newline at end of file
+] unit-test
+
+: test-representations ( -- )
+    cfg new 0 get >>entry dup cfg set select-representations drop ;
+
+! Make sure cost calculation isn't completely wrong
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##peek f 2 D 1 }
+    T{ ##add-float f 3 1 2 }
+    T{ ##replace f 3 D 0 }
+    T{ ##replace f 3 D 1 }
+    T{ ##replace f 3 D 2 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+[ ] [ test-representations ] unit-test
+
+[ 1 ] [ 1 get instructions>> [ ##allot? ] count ] unit-test
+
+cpu x86.32? [
+
+    ! Make sure load-constant is converted into load-double
+    V{
+        T{ ##prologue }
+        T{ ##branch }
+    } 0 test-bb
+
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##load-constant f 2 0.5 }
+        T{ ##add-float f 3 1 2 }
+        T{ ##replace f 3 D 0 }
+        T{ ##branch }
+    } 1 test-bb
+
+    V{
+        T{ ##epilogue }
+        T{ ##return }
+    } 2 test-bb
+
+    0 1 edge
+    1 2 edge
+
+    [ ] [ test-representations ] unit-test
+
+    [ t ] [ 1 get instructions>> second ##load-double? ] unit-test
+
+    ! Make sure phi nodes are handled in a sane way
+    V{
+        T{ ##prologue }
+        T{ ##branch }
+    } 0 test-bb
+
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##compare-imm-branch f 1 2 }
+    } 1 test-bb
+
+    V{
+        T{ ##load-constant f 2 1.5 }
+        T{ ##branch }
+    } 2 test-bb
+
+    V{
+        T{ ##load-constant f 3 2.5 }
+        T{ ##branch }
+    } 3 test-bb
+
+    V{
+        T{ ##phi f 4 }
+        T{ ##peek f 5 D 0 }
+        T{ ##add-float f 6 4 5 }
+        T{ ##replace f 6 D 0 }
+    } 4 test-bb
+
+    V{
+        T{ ##epilogue }
+        T{ ##return }
+    } 5 test-bb
+
+    test-diamond
+    4 5 edge
+
+    2 get 2 2array
+    3 get 3 2array 2array 4 get instructions>> first (>>inputs)
+
+    [ ] [ test-representations ] unit-test
+
+    [ t ] [ 2 get instructions>> first ##load-double? ] unit-test
+
+    [ t ] [ 3 get instructions>> first ##load-double? ] unit-test
+
+    [ t ] [ 4 get instructions>> first ##phi? ] unit-test
+] when
\ No newline at end of file
diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor
index 05e365e5e4..f202dc4c6a 100644
--- a/basis/compiler/cfg/representations/representations.factor
+++ b/basis/compiler/cfg/representations/representations.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov
+! Copyright (C) 2009, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel fry accessors sequences assocs sets namespaces
 arrays combinators combinators.short-circuit math make locals
@@ -91,8 +91,8 @@ SYMBOL: possibilities
 : possible ( vreg -- reps ) possibilities get at ;
 
 : compute-possibilities ( cfg -- )
-    H{ } clone [ '[ swap _ conjoin-at ] with-vreg-reps ] keep
-    [ keys ] assoc-map possibilities set ;
+    H{ } clone [ '[ swap _ adjoin-at ] with-vreg-reps ] keep
+    [ members ] assoc-map possibilities set ;
 
 ! Compute vregs which must remain tagged for their lifetime.
 SYMBOL: always-boxed
@@ -119,15 +119,18 @@ SYMBOL: always-boxed
 SYMBOL: costs
 
 : init-costs ( -- )
-    possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
+    possibilities get [ drop H{ } clone ] assoc-map costs set ;
+
+: record-possibility ( rep vreg -- )
+    costs get at [ 0 or ] change-at ;
 
 : increase-cost ( rep vreg -- )
     ! Increase cost of keeping vreg in rep, making a choice of rep less
     ! likely.
-    [ basic-block get loop-nesting-at ] 2dip costs get at at+ ;
+    costs get at [ 0 or basic-block get loop-nesting-at 1 + + ] change-at ;
 
 : maybe-increase-cost ( possible vreg preferred -- )
-    pick eq? [ 2drop ] [ increase-cost ] if ;
+    pick eq? [ record-possibility ] [ increase-cost ] if ;
 
 : representation-cost ( vreg preferred -- )
     ! 'preferred' is a representation that the instruction can accept with no cost.
@@ -137,11 +140,29 @@ SYMBOL: costs
     [ '[ _ _ maybe-increase-cost ] ]
     2bi each ;
 
+GENERIC: compute-insn-costs ( insn -- )
+
+M: ##load-constant compute-insn-costs
+    ! There's no cost to unboxing the result of a ##load-constant
+    drop ;
+
+M: insn compute-insn-costs [ representation-cost ] each-rep ;
+
 : compute-costs ( cfg -- costs )
-    init-costs [ representation-cost ] with-vreg-reps costs get ;
+    init-costs
+    [
+        [ basic-block set ]
+        [
+            [
+                compute-insn-costs
+            ] each-non-phi
+        ] bi
+    ] each-basic-block
+    costs get ;
 
 ! For every vreg, compute preferred representation, that minimizes costs.
 : minimize-costs ( costs -- representations )
+    [ nip assoc-empty? not ] assoc-filter
     [ >alist alist-min first ] assoc-map ;
 
 : compute-representations ( cfg -- )
@@ -150,6 +171,54 @@ SYMBOL: costs
     bi assoc-union
     representations set ;
 
+! PHI nodes require special treatment
+! If the output of a phi instruction is only used as the input to another
+! phi instruction, then we want to use the same representation for both
+! if possible.
+SYMBOL: phis
+
+: collect-phis ( cfg -- )
+    H{ } clone phis set
+    [
+        phis get
+        '[ [ inputs>> values ] [ dst>> ] bi _ set-at ] each-phi
+    ] each-basic-block ;
+
+SYMBOL: work-list
+
+: add-to-work-list ( vregs -- )
+    work-list get push-all-front ;
+
+: rep-assigned ( vregs -- vregs' )
+    representations get '[ _ key? ] filter ;
+
+: rep-not-assigned ( vregs -- vregs' )
+    representations get '[ _ key? not ] filter ;
+
+: add-ready-phis ( -- )
+    phis get keys rep-assigned add-to-work-list ;
+
+: process-phi ( dst -- )
+    ! If dst = phi(src1,src2,...) and dst's representation has been
+    ! determined, assign that representation to each one of src1,...
+    ! that does not have a representation yet, and process those, too.
+    dup phis get at* [
+        [ rep-of ] [ rep-not-assigned ] bi*
+        [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
+    ] [ 2drop ] if ;
+
+: remaining-phis ( -- )
+    phis get keys rep-not-assigned { } assert-sequence= ;
+
+: process-phis ( -- )
+    <hashed-dlist> work-list set
+    add-ready-phis
+    work-list get [ process-phi ] slurp-deque
+    remaining-phis ;
+
+: compute-phi-representations ( cfg -- )
+    collect-phis process-phis ;
+
 ! Insert conversions. This introduces new temporaries, so we need
 ! to rename opearands too.
 
@@ -188,7 +257,7 @@ SYMBOLS: renaming-set needs-renaming? ;
 : record-renaming ( from to -- )
     2array renaming-set get push needs-renaming? on ;
 
-:: (compute-renaming-set) ( ..a vreg required quot: ( ..a vreg preferred required -- ..b ) -- ..b )
+:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- new-vreg ) -- )
     vreg rep-of :> preferred
     preferred required eq?
     [ vreg no-renaming ]
@@ -217,15 +286,16 @@ RENAMING: convert [ converted-value ] [ converted-value ] [ ]
 
 GENERIC: conversions-for-insn ( insn -- )
 
-SYMBOL: phi-mappings
+M: ##phi conversions-for-insn , ;
 
-! compiler.cfg.cssa inserts conversions which convert phi inputs into
-!  the representation of the output. However, we still have to do some
-!  processing here, because if the only node that uses the output of
-!  the phi instruction is another phi instruction then this phi node's
-! output won't have a representation assigned.
-M: ##phi conversions-for-insn
-    [ , ] [ [ inputs>> values ] [ dst>> ] bi phi-mappings get set-at ] bi ;
+! When a float is unboxed, we replace the ##load-constant with a ##load-double
+! if the architecture supports it
+: convert-to-load-double? ( insn -- ? )
+    {
+        [ drop load-double? ]
+        [ dst>> rep-of double-rep? ]
+        [ obj>> float? ]
+    } 1&& ;
 
 ! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
 ! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
@@ -234,17 +304,25 @@ M: ##phi conversions-for-insn
         [ dst>> rep-of vector-rep? ]
         [ obj>> B{ 0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 } = ]
     } 1&& ;
+
 : convert-to-fill-vector? ( insn -- ? )
     {
         [ dst>> rep-of vector-rep? ]
         [ obj>> B{ 255 255 255 255  255 255 255 255  255 255 255 255  255 255 255 255 } = ]
     } 1&& ;
 
+: (convert-to-load-double) ( insn -- dst val )
+    [ dst>> ] [ obj>> ] bi ; inline
+
 : (convert-to-zero/fill-vector) ( insn -- dst rep )
     dst>> dup rep-of ; inline
 
 : conversions-for-load-insn ( insn -- ?insn )
     {
+        {
+            [ dup convert-to-load-double? ]
+            [ (convert-to-load-double) ##load-double f ]
+        }
         {
             [ dup convert-to-zero-vector? ]
             [ (convert-to-zero/fill-vector) ##zero-vector f ]
@@ -277,46 +355,8 @@ M: insn conversions-for-insn , ;
         ] change-instructions drop
     ] if ;
 
-! If the output of a phi instruction is only used as the input to another
-! phi instruction, then we want to use the same representation for both
-! if possible.
-SYMBOL: work-list
-
-: add-to-work-list ( vregs -- )
-    work-list get push-all-front ;
-
-: rep-assigned ( vregs -- vregs' )
-    representations get '[ _ key? ] filter ;
-
-: rep-not-assigned ( vregs -- vregs' )
-    representations get '[ _ key? not ] filter ;
-
-: add-ready-phis ( -- )
-    phi-mappings get keys rep-assigned add-to-work-list ;
-
-: process-phi-mapping ( dst -- )
-    ! If dst = phi(src1,src2,...) and dst's representation has been
-    ! determined, assign that representation to each one of src1,...
-    ! that does not have a representation yet, and process those, too.
-    dup phi-mappings get at* [
-        [ rep-of ] [ rep-not-assigned ] bi*
-        [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
-    ] [ 2drop ] if ;
-
-: remaining-phi-mappings ( -- )
-    phi-mappings get keys rep-not-assigned
-    [ [ int-rep ] dip set-rep-of ] each ;
-
-: process-phi-mappings ( -- )
-    <hashed-dlist> work-list set
-    add-ready-phis
-    work-list get [ process-phi-mapping ] slurp-deque
-    remaining-phi-mappings ;
-
 : insert-conversions ( cfg -- )
-    H{ } clone phi-mappings set
-    [ conversions-for-block ] each-basic-block
-    process-phi-mappings ;
+    [ conversions-for-block ] each-basic-block ;
 
 PRIVATE>
 
@@ -326,6 +366,7 @@ PRIVATE>
     {
         [ compute-possibilities ]
         [ compute-representations ]
+        [ compute-phi-representations ]
         [ insert-conversions ]
         [ ]
     } cleave
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index b16f471d11..99564b7e0e 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -81,6 +81,7 @@ SYNTAX: CODEGEN:
 CODEGEN: ##load-immediate %load-immediate
 CODEGEN: ##load-reference %load-reference
 CODEGEN: ##load-constant %load-reference
+CODEGEN: ##load-double %load-double
 CODEGEN: ##peek %peek
 CODEGEN: ##replace %replace
 CODEGEN: ##inc-d %inc-d
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index eef517a2bb..fa8dfc2149 100644
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -70,9 +70,12 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
 : rel-word-pic-tail ( word class -- )
     [ add-literal ] dip rt-entry-point-pic-tail rel-fixup ;
 
-: rel-immediate ( literal class -- )
+: rel-literal ( literal class -- )
     [ add-literal ] dip rt-literal rel-fixup ;
 
+: rel-float ( literal class -- )
+    [ add-literal ] dip rt-float rel-fixup ;
+
 : rel-this ( class -- )
     rt-this rel-fixup ;
 
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index 2fec5ca190..0e2fc3041b 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -68,7 +68,8 @@ C-ENUM: f
     rt-vm
     rt-cards-offset
     rt-decks-offset
-    rt-exception-handler ;
+    rt-exception-handler
+    rt-float ;
 
 : rc-absolute? ( n -- ? )
     ${
diff --git a/basis/compiler/tree/propagation/recursive/recursive-tests.factor b/basis/compiler/tree/propagation/recursive/recursive-tests.factor
index 42325d97ca..af2bdbda60 100644
--- a/basis/compiler/tree/propagation/recursive/recursive-tests.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive-tests.factor
@@ -8,7 +8,7 @@ IN: compiler.tree.propagation.recursive.tests
     integer generalize-counter-interval
 ] unit-test
 
-[ T{ interval f { 0 t } { $[ most-positive-fixnum ] t } } ] [
+[ T{ interval f { 0 t } { $[ max-array-capacity ] t } } ] [
     T{ interval f { 1 t } { 1 t } }
     T{ interval f { 0 t } { 0 t } }
     fixnum generalize-counter-interval
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 0051e83356..a98b5cbafb 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -202,8 +202,9 @@ M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ;
 ! Mapping from register class to machine registers
 HOOK: machine-registers cpu ( -- assoc )
 
-HOOK: %load-immediate cpu ( reg obj -- )
+HOOK: %load-immediate cpu ( reg val -- )
 HOOK: %load-reference cpu ( reg obj -- )
+HOOK: %load-double cpu ( reg val -- )
 
 HOOK: %peek cpu ( vreg loc -- )
 HOOK: %replace cpu ( vreg loc -- )
@@ -496,6 +497,11 @@ M: reg-class param-reg param-regs nth ;
 
 M: stack-params param-reg 2drop ;
 
+! Does this architecture support %load-double?
+HOOK: load-double? cpu ( -- ? )
+
+M: object load-double? f ;
+
 ! Can this value be an immediate operand for %add-imm, %sub-imm,
 ! or %mul-imm?
 HOOK: immediate-arithmetic? cpu ( n -- ? )
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 551693d5c7..edeb0d262f 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -47,7 +47,7 @@ CONSTANT: fp-scratch-reg 30
 M: ppc %load-immediate ( reg n -- ) swap LOAD ;
 
 M: ppc %load-reference ( reg obj -- )
-    [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
+    [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-literal ] bi* ;
 
 M: ppc %alien-global ( register symbol dll -- )
     [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 00422dcf03..c567c1e1f0 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -12,9 +12,6 @@ cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
 FROM: layouts => cell ;
 IN: cpu.x86.32
 
-M: x86.32 immediate-comparand? ( n -- ? )
-    [ call-next-method ] [ word? ] bi or ;
-
 M: x86.32 machine-registers
     {
         { int-regs { EAX ECX EDX EBP EBX } }
@@ -27,6 +24,14 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 frame-reg EBP ;
 M: x86.32 temp-reg ECX ;
 
+M: x86.32 immediate-comparand? ( n -- ? )
+    [ call-next-method ] [ word? ] bi or ;
+
+M: x86.32 load-double? ( -- ? ) t ;
+
+M: x86.32 %load-double ( dst val -- )
+    [ 0 [] MOVSD ] dip rc-absolute rel-float ;
+
 M: x86.32 %mov-vm-ptr ( reg -- )
     0 MOV 0 rc-absolute-cell rel-vm ;
 
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index bab90c0f09..7bb33dec9a 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -66,7 +66,7 @@ HOOK: pic-tail-reg cpu ( -- reg )
 
 M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
 
-M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
+M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-literal ;
 
 HOOK: ds-reg cpu ( -- reg )
 HOOK: rs-reg cpu ( -- reg )
@@ -493,7 +493,7 @@ M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 
 :: (%boolean) ( dst temp insn -- )
     dst \ f type-number MOV
-    temp 0 MOV \ t rc-absolute-cell rel-immediate
+    temp 0 MOV \ t rc-absolute-cell rel-literal
     dst temp insn execute ; inline
 
 : %boolean ( dst cc temp -- )
@@ -514,7 +514,7 @@ M:: x86 %compare ( dst src1 src2 cc temp -- )
     [ register? ] [ 0 = ] [ { cc= cc/= } member? ] tri* and and ;
 
 : (%compare-tagged) ( src1 src2 -- )
-    [ HEX: ffffffff CMP ] dip rc-absolute rel-immediate ;
+    [ HEX: ffffffff CMP ] dip rc-absolute rel-literal ;
 
 : (%compare-imm) ( src1 src2 cc -- )
     {
diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp
index de103cda12..2e7b8d4f09 100755
--- a/vm/code_blocks.cpp
+++ b/vm/code_blocks.cpp
@@ -265,6 +265,9 @@ struct initial_code_block_visitor {
 		case RT_LITERAL:
 			op.store_value(next_literal());
 			break;
+		case RT_FLOAT:
+			op.store_float(next_literal());
+			break;
 		case RT_ENTRY_POINT:
 			op.store_value(parent->compute_entry_point_address(next_literal()));
 			break;
diff --git a/vm/compaction.cpp b/vm/compaction.cpp
index 5e52c70b0c..34398e3d88 100644
--- a/vm/compaction.cpp
+++ b/vm/compaction.cpp
@@ -111,6 +111,9 @@ struct code_block_compaction_relocation_visitor {
 		case RT_LITERAL:
 			op.store_value(slot_forwarder.visit_pointer(op.load_value(old_offset)));
 			break;
+		case RT_FLOAT:
+			op.store_float(slot_forwarder.visit_pointer(op.load_float(old_offset)));
+			break;
 		case RT_ENTRY_POINT:
 		case RT_ENTRY_POINT_PIC:
 		case RT_ENTRY_POINT_PIC_TAIL:
diff --git a/vm/image.cpp b/vm/image.cpp
index ccce96a952..4dfdc4242e 100755
--- a/vm/image.cpp
+++ b/vm/image.cpp
@@ -185,6 +185,9 @@ struct code_block_fixup_relocation_visitor {
 		case RT_LITERAL:
 			op.store_value(data_visitor.visit_pointer(op.load_value(old_offset)));
 			break;
+		case RT_FLOAT:
+			op.store_float(data_visitor.visit_pointer(op.load_float(old_offset)));
+			break;
 		case RT_ENTRY_POINT:
 		case RT_ENTRY_POINT_PIC:
 		case RT_ENTRY_POINT_PIC_TAIL:
diff --git a/vm/instruction_operands.cpp b/vm/instruction_operands.cpp
index b11db279a5..af7d363aef 100644
--- a/vm/instruction_operands.cpp
+++ b/vm/instruction_operands.cpp
@@ -62,6 +62,16 @@ fixnum instruction_operand::load_value()
 	return load_value(pointer);
 }
 
+cell instruction_operand::load_float()
+{
+	return (cell)load_value() - boxed_float_offset;
+}
+
+cell instruction_operand::load_float(cell pointer)
+{
+	return (cell)load_value(pointer) - boxed_float_offset;
+}
+
 code_block *instruction_operand::load_code_block(cell relative_to)
 {
 	return ((code_block *)load_value(relative_to) - 1);
@@ -135,6 +145,11 @@ void instruction_operand::store_value(fixnum absolute_value)
 	}
 }
 
+void instruction_operand::store_float(cell value)
+{
+	store_value((fixnum)value + boxed_float_offset);
+}
+
 void instruction_operand::store_code_block(code_block *compiled)
 {
 	store_value((cell)compiled->entry_point());
diff --git a/vm/instruction_operands.hpp b/vm/instruction_operands.hpp
index 5dda411c8b..5c120c2ec7 100644
--- a/vm/instruction_operands.hpp
+++ b/vm/instruction_operands.hpp
@@ -30,6 +30,9 @@ enum relocation_type {
 	type since its used in a situation where relocation arguments cannot
 	be passed in, and so RT_DLSYM is inappropriate (Windows only) */
 	RT_EXCEPTION_HANDLER,
+	/* pointer to a float's payload */
+	RT_FLOAT,
+
 };
 
 enum relocation_class {
@@ -112,6 +115,7 @@ struct relocation_entry {
 		case RT_CARDS_OFFSET:
 		case RT_DECKS_OFFSET:
 		case RT_EXCEPTION_HANDLER:
+		case RT_FLOAT:
 			return 0;
 		default:
 			critical_error("Bad rel type",rel_type());
@@ -152,12 +156,15 @@ struct instruction_operand {
 	fixnum load_value_masked(cell mask, cell bits, cell shift);
 	fixnum load_value(cell relative_to);
 	fixnum load_value();
+	cell load_float(cell relative_to);
+	cell load_float();
 	code_block *load_code_block(cell relative_to);
 	code_block *load_code_block();
 
 	void store_value_2_2(fixnum value);
 	void store_value_masked(fixnum value, cell mask, cell shift);
 	void store_value(fixnum value);
+	void store_float(cell value);
 	void store_code_block(code_block *compiled);
 };
 
diff --git a/vm/layouts.hpp b/vm/layouts.hpp
index 9b574e554d..3e51d1fa4d 100644
--- a/vm/layouts.hpp
+++ b/vm/layouts.hpp
@@ -246,6 +246,8 @@ struct wrapper : public object {
 	cell object;
 };
 
+const fixnum boxed_float_offset = 8 - FLOAT_TYPE;
+
 /* Assembly code makes assumptions about the layout of this struct */
 struct boxed_float : object {
 	static const cell type_number = FLOAT_TYPE;
diff --git a/vm/slot_visitor.hpp b/vm/slot_visitor.hpp
index d4dd44bed1..cb2db1c705 100644
--- a/vm/slot_visitor.hpp
+++ b/vm/slot_visitor.hpp
@@ -192,8 +192,17 @@ struct literal_references_visitor {
 
 	void operator()(instruction_operand op)
 	{
-		if(op.rel_type() == RT_LITERAL)
+		switch(op.rel_type())
+		{
+		case RT_LITERAL:
 			op.store_value(visitor->visit_pointer(op.load_value()));
+			break;
+		case RT_FLOAT:
+			op.store_float(visitor->visit_pointer(op.load_float()));
+			break;
+		default:
+			break;
+		}
 	}
 };
 

From 1624903ae16c40d0e374d162edfd113b67d05dd5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 19 Apr 2010 00:46:03 -0500
Subject: [PATCH 014/158] Split up cuda vocab some more, make CUDA-LIBRARY:
 work

---
 extra/cuda/cuda.factor                        | 320 ++----------------
 .../cuda/demos/hello-world/hello-world.factor |  23 +-
 extra/cuda/demos/prefix-sum/prefix-sum.factor |   9 +-
 extra/cuda/memory/authors.txt                 |   1 +
 extra/cuda/memory/memory.factor               |  74 ++++
 extra/cuda/syntax/syntax.factor               |  11 +-
 extra/cuda/utils/authors.txt                  |   1 +
 extra/cuda/utils/utils.factor                 | 204 +++++++++++
 8 files changed, 316 insertions(+), 327 deletions(-)
 create mode 100644 extra/cuda/memory/authors.txt
 create mode 100644 extra/cuda/memory/memory.factor
 create mode 100644 extra/cuda/utils/authors.txt
 create mode 100644 extra/cuda/utils/utils.factor

diff --git a/extra/cuda/cuda.factor b/extra/cuda/cuda.factor
index d8b6f2e2ce..94e10a96dd 100644
--- a/extra/cuda/cuda.factor
+++ b/extra/cuda/cuda.factor
@@ -2,324 +2,42 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.data alien.parser alien.strings
 alien.syntax arrays assocs byte-arrays classes.struct
-combinators continuations cuda.ffi destructors fry io
-io.backend io.encodings.string io.encodings.utf8 kernel lexer
-locals macros math math.parser namespaces nested-comments
-opengl.gl.extensions parser prettyprint quotations sequences
-words ;
+combinators continuations cuda.ffi cuda.memory cuda.utils
+destructors fry io io.backend io.encodings.string
+io.encodings.utf8 kernel lexer locals macros math math.parser
+namespaces nested-comments opengl.gl.extensions parser
+prettyprint quotations sequences words ;
 QUALIFIED-WITH: alien.c-types a
 IN: cuda
 
-SYMBOL: cuda-device
-SYMBOL: cuda-context
-SYMBOL: cuda-module
-SYMBOL: cuda-function
-SYMBOL: cuda-launcher
-SYMBOL: cuda-memory-hashtable
-
-SYMBOL: cuda-libraries
-cuda-libraries [ H{ } clone ] initialize
-
-SYMBOL: cuda-functions
-
-TUPLE: cuda-library name path ;
-
-: <cuda-library> ( name path -- obj )
-    \ cuda-library new
-        swap >>path
-        swap >>name ;
-
-: add-cuda-library ( name path -- )
-    normalize-path <cuda-library>
-    dup name>> cuda-libraries get set-at ;
-
-: cuda-library ( name -- cuda-library )
-    cuda-libraries get at ;
-
-ERROR: throw-cuda-error n ;
-
-: cuda-error ( n -- )
-    dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error ] if ;
-
-: cuda-version ( -- n )
-    a:int <c-object> [ cuDriverGetVersion cuda-error ] keep a:*int ;
-
-: init-cuda ( -- )
-    0 cuInit cuda-error ;
-
 TUPLE: launcher
 { device integer initial: 0 }
-{ device-flags initial: 0 }
-path ;
+{ device-flags initial: 0 } ;
 
 TUPLE: function-launcher
-dim-block
-dim-grid
-shared-size
-stream ;
+dim-block dim-grid shared-size stream ;
 
 : with-cuda-context ( flags device quot -- )
+    H{ } clone cuda-modules set-global
     H{ } clone cuda-functions set
-    [
-        [ CUcontext <c-object> ] 2dip
-        [ cuCtxCreate cuda-error ] 3keep 2drop a:*void*
-    ] dip 
+    [ create-context ] dip 
     [ '[ _ @ ] ]
-    [ drop '[ _ cuCtxDestroy cuda-error ] ] 2bi
+    [ drop '[ _ destroy-context ] ] 2bi
     [ ] cleanup ; inline
 
-: with-cuda-module ( path quot -- )
-    [
-        normalize-path
-        [ CUmodule <c-object> ] dip
-        [ cuModuleLoad cuda-error ] 2keep drop a:*void*
-    ] dip
-    [ '[ _ @ ] ]
-    [ drop '[ _ cuModuleUnload cuda-error ] ] 2bi
-    [ ] cleanup ; inline
-
-: with-cuda-program ( flags device path quot -- )
+: with-cuda-program ( flags device quot -- )
     [ dup cuda-device set ] 2dip
-    '[
-        cuda-context set
-        _ [
-            cuda-module set
-            _ call
-        ] with-cuda-module
-    ] with-cuda-context ; inline
+    '[ cuda-context set _ call ] with-cuda-context ; inline
 
 : with-cuda ( launcher quot -- )
-    [
-        init-cuda
-        H{ } clone cuda-memory-hashtable
-    ] 2dip '[
+    init-cuda
+    [ H{ } clone cuda-memory-hashtable ] 2dip '[
         _ 
         [ cuda-launcher set ]
-        [ [ device>> ] [ device-flags>> ] [ path>> ] tri ] bi
+        [ [ device>> ] [ device-flags>> ] bi ] bi
         _ with-cuda-program
     ] with-variable ; inline
 
-<PRIVATE
-
-: #cuda-devices ( -- n )
-    a:int <c-object> [ cuDeviceGetCount cuda-error ] keep a:*int ;
-
-: n>cuda-device ( n -- device )
-    [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop a:*int ;
-
-: enumerate-cuda-devices ( -- devices )
-    #cuda-devices iota [ n>cuda-device ] map ;
-
-: cuda-device-properties ( device -- properties )
-    [ CUdevprop <c-object> ] dip
-    [ cuDeviceGetProperties cuda-error ] 2keep drop
-    CUdevprop memory>struct ;
-
-PRIVATE>
-
-: cuda-devices ( -- assoc )
-    enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
-
-: cuda-device-name ( n -- string )
-    [ 256 [ <byte-array> ] keep ] dip
-    [ cuDeviceGetName cuda-error ]
-    [ 2drop utf8 alien>string ] 3bi ;
-
-: cuda-device-capability ( n -- pair )
-    [ a:int <c-object> a:int <c-object> ] dip
-    [ cuDeviceComputeCapability cuda-error ]
-    [ drop [ a:*int ] bi@ ] 3bi 2array ;
-
-: cuda-device-memory ( n -- bytes )
-    [ a:uint <c-object> ] dip
-    [ cuDeviceTotalMem cuda-error ]
-    [ drop a:*uint ] 2bi ;
-
-: get-function-ptr* ( module string -- function )
-    [ CUfunction <c-object> ] 2dip
-    [ cuModuleGetFunction cuda-error ] 3keep 2drop a:*void* ;
-
-: get-function-ptr ( string -- function )
-    [ cuda-module get ] dip get-function-ptr* ;
-
-: with-cuda-function ( string quot -- )
-    [
-        get-function-ptr* cuda-function set
-    ] dip call ; inline
-
-: cached-cuda-function ( string -- alien )
-    cuda-functions get [ get-function-ptr ] cache ;
-
-: launch-function* ( function -- ) cuLaunch cuda-error ;
-
-: launch-function ( -- ) cuda-function get cuLaunch cuda-error ;
-
-: launch-function-grid* ( function width height -- )
-    cuLaunchGrid cuda-error ;
-
-: launch-function-grid ( width height -- )
-    [ cuda-function get ] 2dip
-    cuLaunchGrid cuda-error ;
-
-TUPLE: cuda-memory < disposable ptr length ;
-
-: <cuda-memory> ( ptr length -- obj )
-    cuda-memory new-disposable
-        swap >>length
-        swap >>ptr ;
-
-: add-cuda-memory ( obj -- obj )
-    dup dup ptr>> cuda-memory-hashtable get set-at ;
-
-: delete-cuda-memory ( obj -- )
-    cuda-memory-hashtable delete-at ;
-
-ERROR: invalid-cuda-memory ptr ;
-
-: cuda-memory-length ( cuda-memory -- n )
-    ptr>> cuda-memory-hashtable get ?at [
-        length>>
-    ] [
-        invalid-cuda-memory
-    ] if ;
-
-M: cuda-memory byte-length length>> ;
-
-: cuda-malloc ( n -- ptr )
-    [ CUdeviceptr <c-object> ] dip
-    [ cuMemAlloc cuda-error ] 2keep
-    [ a:*int ] dip <cuda-memory> add-cuda-memory ;
-
-: cuda-free* ( ptr -- )
-    cuMemFree cuda-error ;
-
-M: cuda-memory dispose ( ptr -- )
-    ptr>> cuda-free* ;
-
-: host>device ( dest-ptr src-ptr -- )
-    [ ptr>> ] dip dup length cuMemcpyHtoD cuda-error ;
-
-:: device>host ( ptr -- seq )
-    ptr byte-length <byte-array>
-    [ ptr [ ptr>> ] [ byte-length ] bi cuMemcpyDtoH cuda-error ] keep ;
-
-: memcpy-device>device ( dest-ptr src-ptr count -- )
-    cuMemcpyDtoD cuda-error ;
-
-: memcpy-device>array ( dest-array dest-index src-ptr count -- )
-    cuMemcpyDtoA cuda-error ;
-
-: memcpy-array>device ( dest-ptr src-array src-index count -- )
-    cuMemcpyAtoD cuda-error ;
-
-: memcpy-array>host ( dest-ptr src-array src-index count -- )
-    cuMemcpyAtoH cuda-error ;
-
-: memcpy-host>array ( dest-array dest-index src-ptr count -- )
-    cuMemcpyHtoA cuda-error ;
-
-: memcpy-array>array ( dest-array dest-index src-array src-ptr count -- )
-    cuMemcpyAtoA cuda-error ;
-
-: cuda-int* ( function offset value -- )
-    cuParamSeti cuda-error ;
-
-: cuda-int ( offset value -- )
-    [ cuda-function get ] 2dip cuda-int* ;
-
-: cuda-float* ( function offset value -- )
-    cuParamSetf cuda-error ;
-
-: cuda-float ( offset value -- )
-    [ cuda-function get ] 2dip cuda-float* ;
-
-: cuda-vector* ( function offset ptr n -- )
-    cuParamSetv cuda-error ;
-
-: cuda-vector ( offset ptr n -- )
-    [ cuda-function get ] 3dip cuda-vector* ;
-
-: param-size* ( function n -- )
-    cuParamSetSize cuda-error ;
-
-: param-size ( n -- )
-    [ cuda-function get ] dip param-size* ;
-
-: malloc-device-string ( string -- n )
-    utf8 encode
-    [ length cuda-malloc ] keep
-    [ host>device ] [ drop ] 2bi ;
-
-ERROR: bad-cuda-parameter parameter ;
-
-:: set-parameters ( seq -- )
-    cuda-function get :> function
-    0 :> offset!
-    seq [
-        [ offset ] dip
-        {
-            { [ dup cuda-memory? ] [ ptr>> cuda-int ] }
-            { [ dup float? ] [ cuda-float ] }
-            { [ dup integer? ] [ cuda-int ] }
-            [ bad-cuda-parameter ]
-        } cond
-        offset 4 + offset!
-    ] each
-    offset param-size ;
-
-: cuda-device-attribute ( attribute dev -- n )
-    [ a:int <c-object> ] 2dip
-    [ cuDeviceGetAttribute cuda-error ]
-    [ 2drop a:*int ] 3bi ;
-
-: function-block-shape* ( function x y z -- )
-    cuFuncSetBlockShape cuda-error ;
-
-: function-block-shape ( x y z -- )
-    [ cuda-function get ] 3dip
-    cuFuncSetBlockShape cuda-error ;
-
-: function-shared-size* ( function n -- )
-    cuFuncSetSharedSize cuda-error ;
-
-: function-shared-size ( n -- )
-    [ cuda-function get ] dip
-    cuFuncSetSharedSize cuda-error ;
-
-: launch ( -- )
-    cuda-launcher get {
-        [ block-shape>> first3 function-block-shape ]
-        [ shared-size>> function-shared-size ]
-        [
-            grid>> [
-                launch-function
-            ] [
-                first2 launch-function-grid
-            ] if-empty
-        ]
-    } cleave ;
-
-: cuda-device. ( n -- )
-    {
-        [ "Device: " write number>string print ]
-        [ "Name: " write cuda-device-name print ]
-        [ "Memory: " write cuda-device-memory number>string print ]
-        [
-            "Capability: " write
-            cuda-device-capability [ number>string ] map " " join print
-        ]
-        [ "Properties: " write cuda-device-properties . ]
-        [
-            "CU_DEVICE_ATTRIBUTE_GPU_OVERLAP: " write
-            CU_DEVICE_ATTRIBUTE_GPU_OVERLAP swap
-            cuda-device-attribute number>string print
-        ]
-    } cleave ;
-
-: cuda. ( -- )
-    "CUDA Version: " write cuda-version number>string print nl
-    #cuda-devices iota [ nl ] [ cuda-device. ] interleave ;
-
 : c-type>cuda-setter ( c-type -- n cuda-type )
     {
         { [ dup a:int = ] [ drop 4 [ cuda-int* ] ] }
@@ -353,13 +71,13 @@ MACRO: cuda-arguments ( c-types -- quot: ( args... function -- ) )
     swap '[ _ param-size* ] suffix
     '[ _ cleave ] ;
 
-: define-cuda-word ( word string arguments -- )
+: define-cuda-word ( word module-name function-name arguments -- )
     [
         '[
-            _ get-function-ptr
+            _ _ cached-function
             [ nip _ cuda-arguments ]
             [ run-function-launcher ] 2bi
         ]
     ]
-    [ nip \ function-launcher suffix a:void function-effect ]
-    2bi define-declared ;
+    [ 2nip \ function-launcher suffix a:void function-effect ]
+    3bi define-declared ;
diff --git a/extra/cuda/demos/hello-world/hello-world.factor b/extra/cuda/demos/hello-world/hello-world.factor
index 540c4b9148..8855ce6fea 100644
--- a/extra/cuda/demos/hello-world/hello-world.factor
+++ b/extra/cuda/demos/hello-world/hello-world.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.strings cuda cuda.syntax destructors
-io.encodings.utf8 kernel locals math prettyprint sequences ;
+USING: alien.c-types alien.strings cuda cuda.memory cuda.syntax
+destructors io io.encodings.utf8 kernel locals math sequences ;
 IN: cuda.demos.hello-world
 
 CUDA-LIBRARY: hello vocab:cuda/demos/hello-world/hello.ptx
@@ -9,22 +9,13 @@ CUDA-LIBRARY: hello vocab:cuda/demos/hello-world/hello.ptx
 CUDA-FUNCTION: helloWorld ( char* string-ptr ) ;
 
 :: cuda-hello-world ( -- )
-    T{ launcher
-        { device 0 }
-        { path "vocab:cuda/demos/hello-world/hello.ptx" }
-    } [
-        "Hello World!" [ - ] map-index malloc-device-string &dispose dup :> str
+    T{ launcher { device 0 } } [
+        "Hello World!" [ - ] map-index malloc-device-string
+        &dispose dup :> str
 
-        T{ function-launcher
-            { dim-block { 6 1 1 } }
-            { dim-grid { 2 1 } }
-            { shared-size 0 }
-        }
-        helloWorld
+        { 6 1 1 } { 2 1 } 1 3<<< helloWorld
 
-        ! <<< { 6 1 1 } { 2 1 } 1 >>> helloWorld
-
-        str device>host utf8 alien>string .
+        str device>host utf8 alien>string print
     ] with-cuda ;
 
 MAIN: cuda-hello-world
diff --git a/extra/cuda/demos/prefix-sum/prefix-sum.factor b/extra/cuda/demos/prefix-sum/prefix-sum.factor
index 2cd8eba166..c7e59b515a 100644
--- a/extra/cuda/demos/prefix-sum/prefix-sum.factor
+++ b/extra/cuda/demos/prefix-sum/prefix-sum.factor
@@ -8,14 +8,9 @@ CUDA-LIBRARY: prefix-sum vocab:cuda/demos/prefix-sum/prefix-sum.ptx
 CUDA-FUNCTION: prefix_sum_block ( uint* in, uint* out, uint n ) ;
 
 :: cuda-prefix-sum ( -- )
-    T{ launcher
-        { device 0 }
-        { path "vocab:cuda/demos/prefix-sum/prefix-sum.ptx" }
-    } [
-
-        
+    T{ launcher { device 0 } }
+    [
         ! { 1 1 1 } { 2 1 } 0 3<<< prefix_sum_block
-
     ] with-cuda ;
 
 MAIN: cuda-prefix-sum
diff --git a/extra/cuda/memory/authors.txt b/extra/cuda/memory/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/cuda/memory/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/cuda/memory/memory.factor b/extra/cuda/memory/memory.factor
new file mode 100644
index 0000000000..c3dfe56a53
--- /dev/null
+++ b/extra/cuda/memory/memory.factor
@@ -0,0 +1,74 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.data assocs byte-arrays cuda.ffi
+cuda.utils destructors io.encodings.string io.encodings.utf8
+kernel locals namespaces sequences ;
+QUALIFIED-WITH: alien.c-types a
+IN: cuda.memory
+
+SYMBOL: cuda-memory-hashtable
+
+TUPLE: cuda-memory < disposable ptr length ;
+
+: <cuda-memory> ( ptr length -- obj )
+    cuda-memory new-disposable
+        swap >>length
+        swap >>ptr ;
+
+: add-cuda-memory ( obj -- obj )
+    dup dup ptr>> cuda-memory-hashtable get set-at ;
+
+: delete-cuda-memory ( obj -- )
+    cuda-memory-hashtable delete-at ;
+
+ERROR: invalid-cuda-memory ptr ;
+
+: cuda-memory-length ( cuda-memory -- n )
+    ptr>> cuda-memory-hashtable get ?at [
+        length>>
+    ] [
+        invalid-cuda-memory
+    ] if ;
+
+M: cuda-memory byte-length length>> ;
+
+: cuda-malloc ( n -- ptr )
+    [ CUdeviceptr <c-object> ] dip
+    [ cuMemAlloc cuda-error ] 2keep
+    [ a:*int ] dip <cuda-memory> add-cuda-memory ;
+
+: cuda-free* ( ptr -- )
+    cuMemFree cuda-error ;
+
+M: cuda-memory dispose ( ptr -- )
+    ptr>> cuda-free* ;
+
+: memcpy-device>device ( dest-ptr src-ptr count -- )
+    cuMemcpyDtoD cuda-error ;
+
+: memcpy-device>array ( dest-array dest-index src-ptr count -- )
+    cuMemcpyDtoA cuda-error ;
+
+: memcpy-array>device ( dest-ptr src-array src-index count -- )
+    cuMemcpyAtoD cuda-error ;
+
+: memcpy-array>host ( dest-ptr src-array src-index count -- )
+    cuMemcpyAtoH cuda-error ;
+
+: memcpy-host>array ( dest-array dest-index src-ptr count -- )
+    cuMemcpyHtoA cuda-error ;
+
+: memcpy-array>array ( dest-array dest-index src-array src-ptr count -- )
+    cuMemcpyAtoA cuda-error ;
+
+: host>device ( dest-ptr src-ptr -- )
+    [ ptr>> ] dip dup length cuMemcpyHtoD cuda-error ;
+
+:: device>host ( ptr -- seq )
+    ptr byte-length <byte-array>
+    [ ptr [ ptr>> ] [ byte-length ] bi cuMemcpyDtoH cuda-error ] keep ;
+
+: malloc-device-string ( string -- n )
+    utf8 encode
+    [ length cuda-malloc ] keep
+    [ host>device ] [ drop ] 2bi ;
diff --git a/extra/cuda/syntax/syntax.factor b/extra/cuda/syntax/syntax.factor
index b8df30f61c..1cd5edb9d4 100644
--- a/extra/cuda/syntax/syntax.factor
+++ b/extra/cuda/syntax/syntax.factor
@@ -1,12 +1,17 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.parser cuda kernel lexer parser ;
+USING: alien.parser cuda cuda.utils io.backend kernel lexer
+namespaces parser ;
 IN: cuda.syntax
 
-SYNTAX: CUDA-LIBRARY: scan scan add-cuda-library ;
+SYNTAX: CUDA-LIBRARY:
+    scan scan normalize-path
+    [ add-cuda-library ]
+    [ drop current-cuda-library set-global ] 2bi ;
 
 SYNTAX: CUDA-FUNCTION:
-    scan [ create-in ] [ ] bi ";" scan-c-args drop define-cuda-word ;
+    scan [ create-in current-cuda-library get ] [ ] bi
+    ";" scan-c-args drop define-cuda-word ;
 
 : 3<<< ( dim-block dim-grid shared-size -- function-launcher )
     f function-launcher boa ;
diff --git a/extra/cuda/utils/authors.txt b/extra/cuda/utils/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/cuda/utils/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/cuda/utils/utils.factor b/extra/cuda/utils/utils.factor
new file mode 100644
index 0000000000..b10f42e8d2
--- /dev/null
+++ b/extra/cuda/utils/utils.factor
@@ -0,0 +1,204 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.data alien.strings arrays assocs
+byte-arrays classes.struct combinators cuda.ffi io io.backend
+io.encodings.utf8 kernel math.parser namespaces prettyprint
+sequences ;
+QUALIFIED-WITH: alien.c-types a
+IN: cuda.utils
+
+SYMBOL: cuda-device
+SYMBOL: cuda-context
+SYMBOL: cuda-module
+SYMBOL: cuda-function
+SYMBOL: cuda-launcher
+
+SYMBOL: cuda-modules
+SYMBOL: cuda-functions
+
+ERROR: throw-cuda-error n ;
+
+: cuda-error ( n -- )
+    dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error ] if ;
+
+: init-cuda ( -- )
+    0 cuInit cuda-error ;
+
+: cuda-version ( -- n )
+    a:int <c-object> [ cuDriverGetVersion cuda-error ] keep a:*int ;
+
+: #cuda-devices ( -- n )
+    a:int <c-object> [ cuDeviceGetCount cuda-error ] keep a:*int ;
+
+: n>cuda-device ( n -- device )
+    [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop a:*int ;
+
+: enumerate-cuda-devices ( -- devices )
+    #cuda-devices iota [ n>cuda-device ] map ;
+
+: cuda-device-properties ( device -- properties )
+    [ CUdevprop <c-object> ] dip
+    [ cuDeviceGetProperties cuda-error ] 2keep drop
+    CUdevprop memory>struct ;
+
+: cuda-devices ( -- assoc )
+    enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
+
+: cuda-device-name ( n -- string )
+    [ 256 [ <byte-array> ] keep ] dip
+    [ cuDeviceGetName cuda-error ]
+    [ 2drop utf8 alien>string ] 3bi ;
+
+: cuda-device-capability ( n -- pair )
+    [ a:int <c-object> a:int <c-object> ] dip
+    [ cuDeviceComputeCapability cuda-error ]
+    [ drop [ a:*int ] bi@ ] 3bi 2array ;
+
+: cuda-device-memory ( n -- bytes )
+    [ a:uint <c-object> ] dip
+    [ cuDeviceTotalMem cuda-error ]
+    [ drop a:*uint ] 2bi ;
+
+: get-function-ptr* ( module string -- function )
+    [ CUfunction <c-object> ] 2dip
+    [ cuModuleGetFunction cuda-error ] 3keep 2drop a:*void* ;
+
+: get-function-ptr ( string -- function )
+    [ cuda-module get ] dip get-function-ptr* ;
+
+: with-cuda-function ( string quot -- )
+    [
+        get-function-ptr* cuda-function set
+    ] dip call ; inline
+
+: create-context ( flags device -- context )
+    [ CUcontext <c-object> ] 2dip
+    [ cuCtxCreate cuda-error ] 3keep 2drop a:*void* ;
+
+: destroy-context ( context -- ) cuCtxDestroy cuda-error ;
+
+SYMBOL: cuda-libraries
+cuda-libraries [ H{ } clone ] initialize
+
+SYMBOL: current-cuda-library
+
+TUPLE: cuda-library name path handle ;
+
+: <cuda-library> ( name path -- obj )
+    \ cuda-library new
+        swap >>path
+        swap >>name ;
+
+: add-cuda-library ( name path -- )
+    normalize-path <cuda-library>
+    dup name>> cuda-libraries get-global set-at ;
+
+: ?delete-at ( key assoc -- old/key ? )
+    2dup delete-at* [ 2nip t ] [ 2drop f ] if ; inline
+
+ERROR: no-cuda-library name ;
+
+: load-module ( path -- module )
+    [ CUmodule <c-object> ] dip
+    [ cuModuleLoad cuda-error ] 2keep drop a:*void* ;
+
+: unload-module ( module -- )
+    cuModuleUnload cuda-error ;
+
+: load-cuda-library ( library -- handle )
+    path>> load-module ;
+
+: lookup-cuda-library ( name -- cuda-library )
+    cuda-libraries get ?at [ no-cuda-library ] unless ;
+
+: remove-cuda-library ( name -- library )
+    cuda-libraries get ?delete-at [ no-cuda-library ] unless ;
+
+: unload-cuda-library ( name -- )
+    remove-cuda-library handle>> unload-module ;
+
+
+: cached-module ( module-name -- alien )
+    lookup-cuda-library
+    cuda-modules get-global [ load-cuda-library ] cache ;
+
+: cached-function ( module-name function-name -- alien )
+    [ cached-module ] dip
+    2array cuda-functions get [ first2 get-function-ptr* ] cache ;
+
+: launch-function* ( function -- ) cuLaunch cuda-error ;
+
+: launch-function ( -- ) cuda-function get cuLaunch cuda-error ;
+
+: cuda-int* ( function offset value -- )
+    cuParamSeti cuda-error ;
+
+: cuda-int ( offset value -- )
+    [ cuda-function get ] 2dip cuda-int* ;
+
+: cuda-float* ( function offset value -- )
+    cuParamSetf cuda-error ;
+
+: cuda-float ( offset value -- )
+    [ cuda-function get ] 2dip cuda-float* ;
+
+: cuda-vector* ( function offset ptr n -- )
+    cuParamSetv cuda-error ;
+
+: cuda-vector ( offset ptr n -- )
+    [ cuda-function get ] 3dip cuda-vector* ;
+
+: param-size* ( function n -- )
+    cuParamSetSize cuda-error ;
+
+: param-size ( n -- )
+    [ cuda-function get ] dip param-size* ;
+
+: launch-function-grid* ( function width height -- )
+    cuLaunchGrid cuda-error ;
+
+: launch-function-grid ( width height -- )
+    [ cuda-function get ] 2dip
+    cuLaunchGrid cuda-error ;
+
+ERROR: bad-cuda-parameter parameter ;
+
+: cuda-device-attribute ( attribute dev -- n )
+    [ a:int <c-object> ] 2dip
+    [ cuDeviceGetAttribute cuda-error ]
+    [ 2drop a:*int ] 3bi ;
+
+: function-block-shape* ( function x y z -- )
+    cuFuncSetBlockShape cuda-error ;
+
+: function-block-shape ( x y z -- )
+    [ cuda-function get ] 3dip
+    cuFuncSetBlockShape cuda-error ;
+
+: function-shared-size* ( function n -- )
+    cuFuncSetSharedSize cuda-error ;
+
+: function-shared-size ( n -- )
+    [ cuda-function get ] dip
+    cuFuncSetSharedSize cuda-error ;
+
+: cuda-device. ( n -- )
+    {
+        [ "Device: " write number>string print ]
+        [ "Name: " write cuda-device-name print ]
+        [ "Memory: " write cuda-device-memory number>string print ]
+        [
+            "Capability: " write
+            cuda-device-capability [ number>string ] map " " join print
+        ]
+        [ "Properties: " write cuda-device-properties . ]
+        [
+            "CU_DEVICE_ATTRIBUTE_GPU_OVERLAP: " write
+            CU_DEVICE_ATTRIBUTE_GPU_OVERLAP swap
+            cuda-device-attribute number>string print
+        ]
+    } cleave ;
+
+: cuda. ( -- )
+    "CUDA Version: " write cuda-version number>string print nl
+    #cuda-devices iota [ nl ] [ cuda-device. ] interleave ;

From d143aa64b246777ab5c59328fe1f356099f801b4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 18 Apr 2010 22:36:52 -0500
Subject: [PATCH 015/158] compiler.tree.propagation.transforms: open-code
 >fixnum when input is already a fixnum or f

---
 .../propagation/transforms/transforms.factor  | 21 ++++++++++++-------
 1 file changed, 14 insertions(+), 7 deletions(-)

diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index 4f0eea9cbb..f8d43e37c4 100644
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -1,12 +1,13 @@
 ! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel sequences words fry generic accessors
-classes.tuple classes classes.algebra definitions
-stack-checker.dependencies quotations classes.tuple.private math
-math.partial-dispatch math.private math.intervals sets.private
-math.floats.private math.integers.private layouts math.order
-vectors hashtables combinators effects generalizations assocs
-sets combinators.short-circuit sequences.private locals growable
+USING: alien.c-types kernel sequences words fry generic
+generic.single accessors classes.tuple classes classes.algebra
+definitions stack-checker.dependencies quotations
+classes.tuple.private math math.partial-dispatch math.private
+math.intervals sets.private math.floats.private
+math.integers.private layouts math.order vectors hashtables
+combinators effects generalizations assocs sets
+combinators.short-circuit sequences.private locals growable
 stack-checker namespaces compiler.tree.propagation.info ;
 FROM: math => float ;
 FROM: sets => set ;
@@ -299,6 +300,12 @@ M\ set intersect [ intersect-quot ] 1 define-partial-eval
     [ \ push def>> ] [ f ] if
 ] "custom-inlining" set-word-prop
 
+! Speeds up fasta benchmark
+\ >fixnum [
+    in-d>> first value-info class>> fixnum \ f class-or class<=
+    [ [ dup [ \ >fixnum no-method ] unless ] ] [ f ] if
+] "custom-inlining" set-word-prop
+
 ! We want to constant-fold calls to heap-size, and recompile those
 ! calls when a C type is redefined
 \ heap-size [

From 2eda6fc6aaf09c5905674b685ed81b27a8b38f86 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 19 Apr 2010 01:13:21 -0500
Subject: [PATCH 016/158] io.encodings: add a fast-path for ascii, utf8 and
 8-bit encodings when string only contains ASCII characters

---
 basis/alien/data/data.factor                 | 15 ++-------
 basis/biassocs/biassocs.factor               |  4 +--
 basis/bootstrap/compiler/compiler.factor     |  4 ++-
 basis/hints/hints.factor                     | 10 +++---
 basis/io/encodings/8-bit/8-bit.factor        | 32 +++++++++++---------
 basis/io/encodings/ascii/ascii.factor        | 31 +++++++++++--------
 basis/io/ports/ports.factor                  |  4 +--
 basis/io/streams/byte-array/fast/authors.txt |  1 +
 basis/io/streams/byte-array/fast/fast.factor | 15 +++++++++
 core/io/encodings/encodings.factor           | 13 ++++----
 core/io/encodings/utf8/utf8.factor           | 21 ++++++++-----
 core/strings/strings.factor                  |  3 +-
 12 files changed, 87 insertions(+), 66 deletions(-)
 create mode 100644 basis/io/streams/byte-array/fast/authors.txt
 create mode 100644 basis/io/streams/byte-array/fast/fast.factor

diff --git a/basis/alien/data/data.factor b/basis/alien/data/data.factor
index a0450d5122..af1ed24663 100644
--- a/basis/alien/data/data.factor
+++ b/basis/alien/data/data.factor
@@ -1,8 +1,7 @@
 ! (c)2009, 2010 Slava Pestov, Joe Groff bsd license
-USING: accessors alien alien.c-types alien.arrays alien.strings arrays
-byte-arrays cpu.architecture fry io io.encodings.binary
-io.files io.streams.memory kernel libc math sequences words
-byte-vectors ;
+USING: accessors alien alien.c-types alien.arrays alien.strings
+arrays byte-arrays cpu.architecture fry io io.encodings.binary
+io.files io.streams.memory kernel libc math sequences words ;
 IN: alien.data
 
 GENERIC: require-c-array ( c-type -- )
@@ -63,13 +62,6 @@ M: memory-stream stream-read
         swap memory>byte-array
     ] [ [ + ] change-index drop ] 2bi ;
 
-M: byte-vector stream-write
-    [ dup byte-length tail-slice ]
-    [ [ [ byte-length ] bi@ + ] keep lengthen ]
-    [ drop byte-length ]
-    2tri
-    [ >c-ptr swap >c-ptr ] dip memcpy ;
-
 M: value-type c-type-rep drop int-rep ;
 
 M: value-type c-type-getter
@@ -83,4 +75,3 @@ M: array c-type-boxer-quot
     unclip [ array-length ] dip [ <c-direct-array> ] 2curry ;
 
 M: array c-type-unboxer-quot drop [ >c-ptr ] ;
-
diff --git a/basis/biassocs/biassocs.factor b/basis/biassocs/biassocs.factor
index 7daa478f54..ab3157d400 100644
--- a/basis/biassocs/biassocs.factor
+++ b/basis/biassocs/biassocs.factor
@@ -13,9 +13,9 @@ TUPLE: biassoc from to ;
 
 M: biassoc assoc-size from>> assoc-size ;
 
-M: biassoc at* from>> at* ;
+M: biassoc at* from>> at* ; inline
 
-M: biassoc value-at* to>> at* ;
+M: biassoc value-at* to>> at* ; inline
 
 : once-at ( value key assoc -- )
     2dup key? [ 3drop ] [ set-at ] if ;
diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor
index 90562e9fc7..9cb9c125ab 100644
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@@ -35,7 +35,7 @@ gc
     [ optimized? not ] filter compile ;
 
 "debug-compiler" get [
-    
+
     nl
     "Compiling..." write flush
 
@@ -117,4 +117,6 @@ gc
 
     " done" print flush
 
+    "io.streams.byte-array.fast" require
+
 ] unless
diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index 558f7dd8a4..dc16cf8b24 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -2,10 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs byte-arrays byte-vectors classes
 combinators definitions effects fry generic generic.single
-generic.standard hashtables io.binary io.streams.string kernel
-kernel.private math math.integers.private math.parser
-namespaces parser sbufs sequences splitting splitting.private strings
-vectors words ;
+generic.standard hashtables io.binary io.encodings
+io.streams.string kernel kernel.private math
+math.integers.private math.parser namespaces parser sbufs
+sequences splitting splitting.private strings vectors words ;
 IN: hints
 
 GENERIC: specializer-predicate ( spec -- quot )
@@ -131,3 +131,5 @@ M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-pr
 M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
 
 \ bignum/f { { bignum bignum } { bignum fixnum } { fixnum bignum } { fixnum fixnum } } "specializer" set-word-prop
+
+\ encode-string { string object object } "specializer" set-word-prop
diff --git a/basis/io/encodings/8-bit/8-bit.factor b/basis/io/encodings/8-bit/8-bit.factor
index 7f92028c31..db269c319d 100644
--- a/basis/io/encodings/8-bit/8-bit.factor
+++ b/basis/io/encodings/8-bit/8-bit.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2008 Daniel Ehrenberg, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.parser arrays io.encodings sequences kernel assocs
-hashtables io.encodings.ascii generic parser classes.tuple words
-words.symbol io io.files splitting namespaces math
-compiler.units accessors classes.singleton classes.mixin
-io.encodings.iana fry simple-flat-file lexer ;
+USING: arrays assocs biassocs kernel io.encodings math.parser
+sequences hashtables io.encodings.ascii generic parser
+classes.tuple words words.symbol io io.files splitting
+namespaces math compiler.units accessors classes.singleton
+classes.mixin io.encodings.iana fry simple-flat-file lexer ;
 IN: io.encodings.8-bit
 
 <PRIVATE
@@ -15,20 +15,22 @@ IN: io.encodings.8-bit
 SYMBOL: 8-bit-encodings
 8-bit-encodings [ H{ } clone ] initialize
 
-TUPLE: 8-bit biassoc ;
+TUPLE: 8-bit { biassoc biassoc read-only } ;
 
-: encode-8-bit ( char stream assoc -- )
-    swapd value-at
-    [ swap stream-write1 ] [ encode-error ] if* ; inline
+: 8-bit-encode ( char 8-bit -- byte )
+    biassoc>> value-at [ encode-error ] unless* ; inline
 
-M: 8-bit encode-char biassoc>> encode-8-bit ;
+M: 8-bit encode-char
+    swap [ 8-bit-encode ] dip stream-write1 ;
 
-: decode-8-bit ( stream assoc -- char/f )
-    swap stream-read1
-    [ swap at [ replacement-char ] unless* ]
-    [ drop f ] if* ; inline
+M: 8-bit encode-string
+    swap [ '[ _ 8-bit-encode ] B{ } map-as ] dip stream-write ;
 
-M: 8-bit decode-char biassoc>> decode-8-bit ;
+M: 8-bit decode-char
+    swap stream-read1 dup
+    [ swap biassoc>> at [ replacement-char ] unless* ]
+    [ 2drop f ]
+    if ;
 
 MIXIN: 8-bit-encoding
 
diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor
index 00d3bc7509..2b5640489f 100644
--- a/basis/io/encodings/ascii/ascii.factor
+++ b/basis/io/encodings/ascii/ascii.factor
@@ -1,22 +1,27 @@
 ! Copyright (C) 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings kernel math io.encodings.private ;
+USING: accessors byte-arrays io io.encodings
+io.encodings.private kernel math sequences ;
 IN: io.encodings.ascii
 
-<PRIVATE
-: encode-if< ( char stream encoding max -- )
-    nip 1 - pick < [ encode-error ] [ stream-write1 ] if ; inline
-
-: decode-if< ( stream encoding max -- character )
-    nip swap stream-read1 dup
-    [ [ nip ] [ > ] 2bi [ >fixnum ] [ drop replacement-char ] if ]
-    [ 2drop f ] if ; inline
-PRIVATE>
-
 SINGLETON: ascii
 
 M: ascii encode-char
-    128 encode-if< ; inline
+    drop
+    over 127 <= [ stream-write1 ] [ encode-error ] if ; inline
+
+M: ascii encode-string
+    drop
+    [
+        dup aux>>
+        [ [ dup 127 <= [ encode-error ] unless ] B{ } map-as ]
+        [ >byte-array ]
+        if
+    ] dip
+    stream-write ;
 
 M: ascii decode-char
-    128 decode-if< ; inline
+    drop
+    stream-read1 dup [
+        dup 127 <= [ >fixnum ] [ drop replacement-char ] if
+    ] when ; inline
diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor
index 0927e7e480..cd0843a70b 100644
--- a/basis/io/ports/ports.factor
+++ b/basis/io/ports/ports.factor
@@ -114,7 +114,7 @@ M: output-port stream-write1
 
 : write-in-groups ( byte-array port -- )
     [ binary-object <direct-uchar-array> ] dip
-    [ buffer>> size>> <groups> ] [ '[ _ stream-write ] ] bi
+    [ buffer>> size>> <sliced-groups> ] [ '[ _ stream-write ] ] bi
     each ;
 
 M: output-port stream-write
@@ -198,5 +198,3 @@ io.encodings.private ;
 HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii } ;
 
 HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
-
-HINTS: encoder-write { object output-port utf8 } { object output-port ascii } ;
diff --git a/basis/io/streams/byte-array/fast/authors.txt b/basis/io/streams/byte-array/fast/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/io/streams/byte-array/fast/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/io/streams/byte-array/fast/fast.factor b/basis/io/streams/byte-array/fast/fast.factor
new file mode 100644
index 0000000000..e231335bfd
--- /dev/null
+++ b/basis/io/streams/byte-array/fast/fast.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien byte-vectors io kernel libc math sequences ;
+IN: io.streams.byte-array.fast
+
+! This is split off from io.streams.byte-array because it uses
+! memcpy, which is a non-core word that only works after the
+! optimizing compiler has been loaded.
+
+M: byte-vector stream-write
+    [ dup byte-length tail-slice ]
+    [ [ [ byte-length ] bi@ + ] keep lengthen ]
+    [ drop byte-length ]
+    2tri
+    [ >c-ptr swap >c-ptr ] dip memcpy ;
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 03e8723d20..1880859db1 100644
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Daniel Ehrenberg, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sbufs vectors namespaces growable
 strings io classes continuations destructors combinators
@@ -12,6 +12,10 @@ GENERIC: decode-char ( stream encoding -- char/f )
 
 GENERIC: encode-char ( char stream encoding -- )
 
+GENERIC: encode-string ( string stream encoding -- )
+
+M: object encode-string [ encode-char ] 2curry each ; inline
+
 GENERIC: <decoder> ( stream encoding -- newstream )
 
 CONSTANT: replacement-char HEX: fffd
@@ -134,13 +138,8 @@ M: encoder stream-element-type
 M: encoder stream-write1
     >encoder< encode-char ;
 
-GENERIC# encoder-write 2 ( string stream encoding -- )
-
-M: string encoder-write
-    [ encode-char ] 2curry each ;
-
 M: encoder stream-write
-    >encoder< encoder-write ;
+    >encoder< encode-string ;
 
 M: encoder dispose stream>> dispose ;
 
diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor
index 2911385c09..c78a86c072 100644
--- a/core/io/encodings/utf8/utf8.factor
+++ b/core/io/encodings/utf8/utf8.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2006, 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math math.order kernel sequences sbufs vectors growable io
-continuations namespaces io.encodings combinators strings ;
+USING: accessors byte-arrays math math.order kernel sequences
+sbufs vectors growable io continuations namespaces io.encodings
+combinators strings ;
 IN: io.encodings.utf8
 
 ! Decoding UTF-8
@@ -45,10 +46,10 @@ M: utf8 decode-char
 ! Encoding UTF-8
 
 : encoded ( stream char -- )
-    BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ;
+    BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ; inline
 
-: char>utf8 ( stream char -- )
-    {
+: char>utf8 ( char stream -- )
+    swap {
         { [ dup -7 shift zero? ] [ swap stream-write1 ] }
         { [ dup -11 shift zero? ] [
             2dup -6 shift BIN: 11000000 bitor swap stream-write1
@@ -65,10 +66,16 @@ M: utf8 decode-char
             2dup -6 shift encoded
             encoded
         ]
-    } cond ;
+    } cond ; inline
 
 M: utf8 encode-char
-    drop swap char>utf8 ;
+    drop char>utf8 ;
+
+M: utf8 encode-string
+    drop
+    over aux>>
+    [ [ char>utf8 ] curry each ]
+    [ [ >byte-array ] dip stream-write ] if ;
 
 PRIVATE>
 
diff --git a/core/strings/strings.factor b/core/strings/strings.factor
index 18af08b3f6..50d79a4d8a 100644
--- a/core/strings/strings.factor
+++ b/core/strings/strings.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math.private sequences kernel.private
-math sequences.private slots.private byte-arrays
-alien.accessors ;
+math sequences.private slots.private alien.accessors ;
 IN: strings
 
 <PRIVATE

From f0543e6bdd2d018bc1a64aca3adb7cb65377fbe4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 19 Apr 2010 01:13:49 -0500
Subject: [PATCH 017/158] benchmark.fasta: formatting fix

---
 extra/benchmark/fasta/fasta.factor | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor
index 8c06716ddb..f1ebc2aa9f 100644
--- a/extra/benchmark/fasta/fasta.factor
+++ b/extra/benchmark/fasta/fasta.factor
@@ -91,10 +91,13 @@ TYPED:: make-repeat-fasta ( k: fixnum len: fixnum alu: string -- k': fixnum )
             n 2 * ALU "Homo sapiens alu" "ONE" write-repeat-fasta
 
             initial-seed
+
             n 3 * homo-sapiens-chars homo-sapiens-floats
             "IUB ambiguity codes" "TWO" write-random-fasta
+
             n 5 * IUB-chars IUB-floats
             "Homo sapiens frequency" "THREE" write-random-fasta
+
             drop
         ] with-file-writer
     ] ;

From 6b2024055f5eda9be3560c0c7bfb90e37520e717 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 19 Apr 2010 01:21:21 -0500
Subject: [PATCH 018/158] Move some code to cuda.devices

---
 extra/cuda/devices/authors.txt    |  1 +
 extra/cuda/devices/devices.factor | 65 ++++++++++++++++++++++++++
 extra/cuda/utils/utils.factor     | 77 ++++---------------------------
 3 files changed, 74 insertions(+), 69 deletions(-)
 create mode 100644 extra/cuda/devices/authors.txt
 create mode 100644 extra/cuda/devices/devices.factor

diff --git a/extra/cuda/devices/authors.txt b/extra/cuda/devices/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/cuda/devices/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/cuda/devices/devices.factor b/extra/cuda/devices/devices.factor
new file mode 100644
index 0000000000..37e199e74e
--- /dev/null
+++ b/extra/cuda/devices/devices.factor
@@ -0,0 +1,65 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.data alien.strings arrays assocs
+byte-arrays classes.struct combinators cuda.ffi cuda.utils io
+io.encodings.utf8 kernel math.parser prettyprint sequences ;
+IN: cuda.devices
+
+: #cuda-devices ( -- n )
+    int <c-object> [ cuDeviceGetCount cuda-error ] keep *int ;
+
+: n>cuda-device ( n -- device )
+    [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ;
+
+: enumerate-cuda-devices ( -- devices )
+    #cuda-devices iota [ n>cuda-device ] map ;
+
+: cuda-device-properties ( device -- properties )
+    [ CUdevprop <c-object> ] dip
+    [ cuDeviceGetProperties cuda-error ] 2keep drop
+    CUdevprop memory>struct ;
+
+: cuda-devices ( -- assoc )
+    enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
+
+: cuda-device-name ( n -- string )
+    [ 256 [ <byte-array> ] keep ] dip
+    [ cuDeviceGetName cuda-error ]
+    [ 2drop utf8 alien>string ] 3bi ;
+
+: cuda-device-capability ( n -- pair )
+    [ int <c-object> int <c-object> ] dip
+    [ cuDeviceComputeCapability cuda-error ]
+    [ drop [ *int ] bi@ ] 3bi 2array ;
+
+: cuda-device-memory ( n -- bytes )
+    [ uint <c-object> ] dip
+    [ cuDeviceTotalMem cuda-error ]
+    [ drop *uint ] 2bi ;
+
+: cuda-device-attribute ( attribute dev -- n )
+    [ int <c-object> ] 2dip
+    [ cuDeviceGetAttribute cuda-error ]
+    [ 2drop *int ] 3bi ;
+
+: cuda-device. ( n -- )
+    {
+        [ "Device: " write number>string print ]
+        [ "Name: " write cuda-device-name print ]
+        [ "Memory: " write cuda-device-memory number>string print ]
+        [
+            "Capability: " write
+            cuda-device-capability [ number>string ] map " " join print
+        ]
+        [ "Properties: " write cuda-device-properties . ]
+        [
+            "CU_DEVICE_ATTRIBUTE_GPU_OVERLAP: " write
+            CU_DEVICE_ATTRIBUTE_GPU_OVERLAP swap
+            cuda-device-attribute number>string print
+        ]
+    } cleave ;
+
+: cuda. ( -- )
+    "CUDA Version: " write cuda-version number>string print nl
+    #cuda-devices iota [ nl ] [ cuda-device. ] interleave ;
+
diff --git a/extra/cuda/utils/utils.factor b/extra/cuda/utils/utils.factor
index b10f42e8d2..912b9e2e92 100644
--- a/extra/cuda/utils/utils.factor
+++ b/extra/cuda/utils/utils.factor
@@ -1,10 +1,9 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.data alien.strings arrays assocs
-byte-arrays classes.struct combinators cuda.ffi io io.backend
-io.encodings.utf8 kernel math.parser namespaces prettyprint
-sequences ;
-QUALIFIED-WITH: alien.c-types a
+USING: accessors alien.c-types alien.data alien.strings arrays
+assocs byte-arrays classes.struct combinators cuda.ffi io
+io.backend io.encodings.utf8 kernel math.parser namespaces
+prettyprint sequences ;
 IN: cuda.utils
 
 SYMBOL: cuda-device
@@ -25,43 +24,11 @@ ERROR: throw-cuda-error n ;
     0 cuInit cuda-error ;
 
 : cuda-version ( -- n )
-    a:int <c-object> [ cuDriverGetVersion cuda-error ] keep a:*int ;
-
-: #cuda-devices ( -- n )
-    a:int <c-object> [ cuDeviceGetCount cuda-error ] keep a:*int ;
-
-: n>cuda-device ( n -- device )
-    [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop a:*int ;
-
-: enumerate-cuda-devices ( -- devices )
-    #cuda-devices iota [ n>cuda-device ] map ;
-
-: cuda-device-properties ( device -- properties )
-    [ CUdevprop <c-object> ] dip
-    [ cuDeviceGetProperties cuda-error ] 2keep drop
-    CUdevprop memory>struct ;
-
-: cuda-devices ( -- assoc )
-    enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
-
-: cuda-device-name ( n -- string )
-    [ 256 [ <byte-array> ] keep ] dip
-    [ cuDeviceGetName cuda-error ]
-    [ 2drop utf8 alien>string ] 3bi ;
-
-: cuda-device-capability ( n -- pair )
-    [ a:int <c-object> a:int <c-object> ] dip
-    [ cuDeviceComputeCapability cuda-error ]
-    [ drop [ a:*int ] bi@ ] 3bi 2array ;
-
-: cuda-device-memory ( n -- bytes )
-    [ a:uint <c-object> ] dip
-    [ cuDeviceTotalMem cuda-error ]
-    [ drop a:*uint ] 2bi ;
+    int <c-object> [ cuDriverGetVersion cuda-error ] keep *int ;
 
 : get-function-ptr* ( module string -- function )
     [ CUfunction <c-object> ] 2dip
-    [ cuModuleGetFunction cuda-error ] 3keep 2drop a:*void* ;
+    [ cuModuleGetFunction cuda-error ] 3keep 2drop *void* ;
 
 : get-function-ptr ( string -- function )
     [ cuda-module get ] dip get-function-ptr* ;
@@ -73,7 +40,7 @@ ERROR: throw-cuda-error n ;
 
 : create-context ( flags device -- context )
     [ CUcontext <c-object> ] 2dip
-    [ cuCtxCreate cuda-error ] 3keep 2drop a:*void* ;
+    [ cuCtxCreate cuda-error ] 3keep 2drop *void* ;
 
 : destroy-context ( context -- ) cuCtxDestroy cuda-error ;
 
@@ -100,7 +67,7 @@ ERROR: no-cuda-library name ;
 
 : load-module ( path -- module )
     [ CUmodule <c-object> ] dip
-    [ cuModuleLoad cuda-error ] 2keep drop a:*void* ;
+    [ cuModuleLoad cuda-error ] 2keep drop *void* ;
 
 : unload-module ( module -- )
     cuModuleUnload cuda-error ;
@@ -161,13 +128,6 @@ ERROR: no-cuda-library name ;
     [ cuda-function get ] 2dip
     cuLaunchGrid cuda-error ;
 
-ERROR: bad-cuda-parameter parameter ;
-
-: cuda-device-attribute ( attribute dev -- n )
-    [ a:int <c-object> ] 2dip
-    [ cuDeviceGetAttribute cuda-error ]
-    [ 2drop a:*int ] 3bi ;
-
 : function-block-shape* ( function x y z -- )
     cuFuncSetBlockShape cuda-error ;
 
@@ -181,24 +141,3 @@ ERROR: bad-cuda-parameter parameter ;
 : function-shared-size ( n -- )
     [ cuda-function get ] dip
     cuFuncSetSharedSize cuda-error ;
-
-: cuda-device. ( n -- )
-    {
-        [ "Device: " write number>string print ]
-        [ "Name: " write cuda-device-name print ]
-        [ "Memory: " write cuda-device-memory number>string print ]
-        [
-            "Capability: " write
-            cuda-device-capability [ number>string ] map " " join print
-        ]
-        [ "Properties: " write cuda-device-properties . ]
-        [
-            "CU_DEVICE_ATTRIBUTE_GPU_OVERLAP: " write
-            CU_DEVICE_ATTRIBUTE_GPU_OVERLAP swap
-            cuda-device-attribute number>string print
-        ]
-    } cleave ;
-
-: cuda. ( -- )
-    "CUDA Version: " write cuda-version number>string print nl
-    #cuda-devices iota [ nl ] [ cuda-device. ] interleave ;

From d88aeb80d962a88827406f89e99b23917a078d60 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 19 Apr 2010 01:38:59 -0500
Subject: [PATCH 019/158] cpu.ppc: fix breakage caused by ##compare-imm change

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

diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index edeb0d262f..8adae2ae99 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -492,7 +492,7 @@ M: ppc %epilogue ( n -- )
     } case ;
 
 : (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
-: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline
+: (%compare-imm) ( src1 src2 -- ) [ 0 ] [ ] [ \ f type-number or ] tri* CMPI ; inline
 : (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
 : (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
 

From 717dd1b10ea31d19ebadee83f8d9cdb147dd85ac Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 19 Apr 2010 00:40:10 -0700
Subject: [PATCH 020/158] cuda.ptx: unit tests for instruction serialization

---
 extra/cuda/ptx/ptx-tests.factor | 977 ++++++++++++++++++++++++++++++++
 extra/cuda/ptx/ptx.factor       |  28 +-
 2 files changed, 995 insertions(+), 10 deletions(-)

diff --git a/extra/cuda/ptx/ptx-tests.factor b/extra/cuda/ptx/ptx-tests.factor
index 877bc82811..28391a5f58 100644
--- a/extra/cuda/ptx/ptx-tests.factor
+++ b/extra/cuda/ptx/ptx-tests.factor
@@ -112,3 +112,980 @@ IN: cuda.ptx.tests
         } }
     } ptx>string
 ] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	abs.s32 a, b;
+	@p abs.s32 a, b;
+	@!p abs.s32 a, b;
+foo:	abs.s32 a, b;
+	abs.ftz.f32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ abs { type .s32 } { dest "a" } { a "b" } }
+            T{ abs
+                { predicate T{ ptx-predicate { variable "p" } } }
+                { type .s32 } { dest "a" } { a "b" }
+            }
+            T{ abs
+                { predicate T{ ptx-predicate { negated? t } { variable "p" } } }
+                { type .s32 } { dest "a" } { a "b" }
+            }
+            T{ abs
+                { label "foo" }
+                { type .s32 } { dest "a" } { a "b" }
+            }
+            T{ abs { type .f32 } { dest "a" } { a "b" } { ftz? t } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	add.s32 a, b, c;
+	add.cc.s32 a, b, c;
+	add.sat.s32 a, b, c;
+	add.ftz.f32 a, b, c;
+	add.ftz.sat.f32 a, b, c;
+	add.rz.sat.f32 a, b, c;
+	add.rz.ftz.sat.f32 a, b, c;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ add { type .s32 } { dest "a" } { a "b" } { b "c" } }
+            T{ add { cc? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+            T{ add { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+            T{ add { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ add { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ add { round .rz } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ add { round .rz } { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	addc.s32 a, b, c;
+	addc.cc.s32 a, b, c;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ addc { type .s32 } { dest "a" } { a "b" } { b "c" } }
+            T{ addc { cc? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	and.b32 a, b, c;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ and { type .b32 } { dest "a" } { a "b" } { b "c" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	atom.and.u32 a, [b], c;
+	atom.global.or.u32 a, [b], c;
+	atom.shared.cas.u32 a, [b], c, d;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ atom { op .and } { type .u32 } { dest "a" } { a "[b]" } { b "c" } }
+            T{ atom { storage-space .global } { op .or } { type .u32 } { dest "a" } { a "[b]" } { b "c" } }
+            T{ atom { storage-space .shared } { op .cas } { type .u32 } { dest "a" } { a "[b]" } { b "c" } { c "d" } }
+
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	bar.arrive a, b;
+	bar.red.popc.u32 a, b, d;
+	bar.red.popc.u32 a, b, !d;
+	bar.red.popc.u32 a, b, c, !d;
+	bar.sync a;
+	bar.sync a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ bar.arrive { a "a" } { b "b" } }
+            T{ bar.red { op .popc } { type .u32 } { dest "a" } { a "b" } { c "d" } }
+            T{ bar.red { op .popc } { type .u32 } { dest "a" } { a "b" } { c "!d" } }
+            T{ bar.red { op .popc } { type .u32 } { dest "a" } { a "b" } { b "c" } { c "!d" } }
+            T{ bar.sync { a "a" } }
+            T{ bar.sync { a "a" } { b "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	bfe.u32 a, b, c, d;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ bfe { type .u32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	bfi.u32 a, b, c, d, e;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ bfi { type .u32 } { dest "a" } { a "b" } { b "c" } { c "d" } { d "e" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	bfind.u32 a, b;
+	bfind.shiftamt.u32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ bfind { type .u32 } { dest "a" } { a "b" } }
+            T{ bfind { type .u32 } { shiftamt? t } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	bra foo;
+	bra.uni bar;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ bra { target "foo" } }
+            T{ bra { uni? t } { target "bar" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	brev.b32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ brev { type .b32 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	brkpt;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ brkpt }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	call foo;
+	call.uni foo;
+	call (a), foo;
+	call (a), foo, (b);
+	call (a), foo, (b, c);
+	call (a), foo, (b, c, d);
+	call foo, (b, c, d);
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ call { target "foo" } }
+            T{ call { uni? t } { target "foo" } }
+            T{ call { return "a" } { target "foo" } }
+            T{ call { return "a" } { target "foo" } { params { "b" } } }
+            T{ call { return "a" } { target "foo" } { params { "b" "c" } } }
+            T{ call { return "a" } { target "foo" } { params { "b" "c" "d" } } }
+            T{ call { target "foo" } { params { "b" "c" "d" } } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	clz.b32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ clz { type .b32 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	cnot.b32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ cnot { type .b32 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	copysign.f64 a, b, c;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ copysign { type .f64 } { dest "a" } { a "b" } { b "c" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	cos.approx.f32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ cos { round .approx } { type .f32 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	cvt.f32.s32 a, b;
+	cvt.s32.f32 a, b;
+	cvt.rp.f32.f64 a, b;
+	cvt.rpi.s32.f32 a, b;
+	cvt.ftz.f32.f64 a, b;
+	cvt.sat.f32.f64 a, b;
+	cvt.ftz.sat.f32.f64 a, b;
+	cvt.rp.ftz.sat.f32.f64 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ cvt { dest-type .f32 } { type .s32 } { dest "a" } { a "b" } }
+            T{ cvt { dest-type .s32 } { type .f32 } { dest "a" } { a "b" } }
+            T{ cvt { round .rp } { dest-type .f32 } { type .f64 } { dest "a" } { a "b" } }
+            T{ cvt { round .rpi } { dest-type .s32 } { type .f32 } { dest "a" } { a "b" } }
+            T{ cvt { ftz? t } { dest-type .f32 } { type .f64 } { dest "a" } { a "b" } }
+            T{ cvt { sat? t } { dest-type .f32 } { type .f64 } { dest "a" } { a "b" } }
+            T{ cvt { ftz? t } { sat? t } { dest-type .f32 } { type .f64 } { dest "a" } { a "b" } }
+            T{ cvt { round .rp } { ftz? t } { sat? t } { dest-type .f32 } { type .f64 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	cvta.global.u64 a, b;
+	cvta.shared.u64 a, b;
+	cvta.to.shared.u64 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ cvta { storage-space .global } { type .u64 } { dest "a" } { a "b" } }
+            T{ cvta { storage-space .shared } { type .u64 } { dest "a" } { a "b" } }
+            T{ cvta { to? t } { storage-space .shared } { type .u64 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	div.u32 a, b, c;
+	div.approx.f32 a, b, c;
+	div.approx.ftz.f32 a, b, c;
+	div.full.f32 a, b, c;
+	div.full.ftz.f32 a, b, c;
+	div.f32 a, b, c;
+	div.rz.f32 a, b, c;
+	div.ftz.f32 a, b, c;
+	div.rz.ftz.f32 a, b, c;
+	div.f64 a, b, c;
+	div.rz.f64 a, b, c;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ div { type .u32 } { dest "a" } { a "b" } { b "c" } }
+            T{ div { round .approx } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ div { round .approx } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ div { round .full } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ div { round .full } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ div { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ div { round .rz } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ div { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ div { round .rz } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ div { type .f64 } { dest "a" } { a "b" } { b "c" } }
+            T{ div { round .rz } { type .f64 } { dest "a" } { a "b" } { b "c" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	ex2.approx.f32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ ex2 { round .approx } { type .f32 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	exit;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ exit }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	fma.f32 a, b, c, d;
+	fma.sat.f32 a, b, c, d;
+	fma.ftz.f32 a, b, c, d;
+	fma.ftz.sat.f32 a, b, c, d;
+	fma.rz.sat.f32 a, b, c, d;
+	fma.rz.ftz.sat.f32 a, b, c, d;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ fma { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ fma { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ fma { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ fma { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ fma { round .rz } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ fma { round .rz } { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	isspacep.shared a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ isspacep { storage-space .shared } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	ld.u32 a, [b];
+	ld.v2.u32 a, [b];
+	ld.v4.u32 a, [b];
+	ld.v4.u32 {a, b, c, d}, [e];
+	ld.lu.u32 a, [b];
+	ld.const.lu.u32 a, [b];
+	ld.volatile.const[5].u32 a, [b];
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ ld { type .u32 } { dest "a" } { a "[b]" } }
+            T{ ld { type T{ .v2 { of .u32 } } } { dest "a" } { a "[b]" } }
+            T{ ld { type T{ .v4 { of .u32 } } } { dest "a" } { a "[b]" } }
+            T{ ld { type T{ .v4 { of .u32 } } } { dest "{a, b, c, d}" } { a "[e]" } }
+            T{ ld { cache-op .lu } { type .u32 } { dest "a" } { a "[b]" } }
+            T{ ld { storage-space T{ .const } } { cache-op .lu } { type .u32 } { dest "a" } { a "[b]" } }
+            T{ ld { volatile? t } { storage-space T{ .const { bank 5 } } } { type .u32 } { dest "a" } { a "[b]" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	ldu.u32 a, [b];
+	ldu.v2.u32 a, [b];
+	ldu.v4.u32 a, [b];
+	ldu.v4.u32 {a, b, c, d}, [e];
+	ldu.lu.u32 a, [b];
+	ldu.const.lu.u32 a, [b];
+	ldu.volatile.const[5].u32 a, [b];
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ ldu { type .u32 } { dest "a" } { a "[b]" } }
+            T{ ldu { type T{ .v2 { of .u32 } } } { dest "a" } { a "[b]" } }
+            T{ ldu { type T{ .v4 { of .u32 } } } { dest "a" } { a "[b]" } }
+            T{ ldu { type T{ .v4 { of .u32 } } } { dest "{a, b, c, d}" } { a "[e]" } }
+            T{ ldu { cache-op .lu } { type .u32 } { dest "a" } { a "[b]" } }
+            T{ ldu { storage-space T{ .const } } { cache-op .lu } { type .u32 } { dest "a" } { a "[b]" } }
+            T{ ldu { volatile? t } { storage-space T{ .const { bank 5 } } } { type .u32 } { dest "a" } { a "[b]" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	lg2.approx.f32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ lg2 { round .approx } { type .f32 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	mad.s32 a, b, c, d;
+	mad.lo.s32 a, b, c, d;
+	mad.sat.s32 a, b, c, d;
+	mad.hi.sat.s32 a, b, c, d;
+	mad.ftz.f32 a, b, c, d;
+	mad.ftz.sat.f32 a, b, c, d;
+	mad.rz.sat.f32 a, b, c, d;
+	mad.rz.ftz.sat.f32 a, b, c, d;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ mad { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ mad { mode .lo } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ mad { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ mad { mode .hi } { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ mad { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ mad { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ mad { round .rz } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ mad { round .rz } { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	mad24.s32 a, b, c, d;
+	mad24.lo.s32 a, b, c, d;
+	mad24.sat.s32 a, b, c, d;
+	mad24.hi.sat.s32 a, b, c, d;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ mad24 { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ mad24 { mode .lo } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ mad24 { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ mad24 { mode .hi } { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	neg.s32 a, b;
+	neg.f32 a, b;
+	neg.ftz.f32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ neg { type .s32 } { dest "a" } { a "b" } }
+            T{ neg { type .f32 } { dest "a" } { a "b" } }
+            T{ neg { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	not.b32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ not { type .b32 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	or.b32 a, b, c;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ or { type .b32 } { dest "a" } { a "b" } { b "c" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	pmevent a;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ pmevent { a "a" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	popc.b64 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ popc { type .b64 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	prefetch.L1 [a];
+	prefetch.local.L2 [a];
+	prefetchu.L1 [a];
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ prefetch { level .L1 } { a "[a]" } }
+            T{ prefetch { storage-space .local } { level .L2 } { a "[a]" } }
+            T{ prefetchu { level .L1 } { a "[a]" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	prmt.b32 a, b, c, d;
+	prmt.b32.f4e a, b, c, d;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ prmt { type .b32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ prmt { type .b32 } { mode .f4e } { dest "a" } { a "b" } { b "c" } { c "d" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	rcp.approx.f32 a, b;
+	rcp.approx.ftz.f32 a, b;
+	rcp.f32 a, b;
+	rcp.rz.f32 a, b;
+	rcp.ftz.f32 a, b;
+	rcp.rz.ftz.f32 a, b;
+	rcp.f64 a, b;
+	rcp.rz.f64 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ rcp { round .approx } { type .f32 } { dest "a" } { a "b" } }
+            T{ rcp { round .approx } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+            T{ rcp { type .f32 } { dest "a" } { a "b" } }
+            T{ rcp { round .rz } { type .f32 } { dest "a" } { a "b" } }
+            T{ rcp { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+            T{ rcp { round .rz } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+            T{ rcp { type .f64 } { dest "a" } { a "b" } }
+            T{ rcp { round .rz } { type .f64 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	red.and.u32 [a], b;
+	red.global.and.u32 [a], b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ red { op .and } { type .u32 } { dest "[a]" } { a "b" } }
+            T{ red { storage-space .global } { op .and } { type .u32 } { dest "[a]" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	rsqrt.approx.f32 a, b;
+	rsqrt.approx.ftz.f32 a, b;
+	rsqrt.approx.f64 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ rsqrt { round .approx } { type .f32 } { dest "a" } { a "b" } }
+            T{ rsqrt { round .approx } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+            T{ rsqrt { round .approx } { type .f64 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	rsqrt.approx.f32 a, b;
+	rsqrt.approx.ftz.f32 a, b;
+	rsqrt.approx.f64 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ rsqrt { round .approx } { type .f32 } { dest "a" } { a "b" } }
+            T{ rsqrt { round .approx } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+            T{ rsqrt { round .approx } { type .f64 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	sad.u32 a, b, c, d;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ sad { type .u32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	selp.u32 a, b, c, d;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ selp { type .u32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	set.gt.u32.s32 a, b, c;
+	set.gt.ftz.u32.f32 a, b, c;
+	set.gt.and.ftz.u32.f32 a, b, c, d;
+	set.gt.and.ftz.u32.f32 a, b, c, !d;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ set { cmp-op .gt } { dest-type .u32 } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+            T{ set { cmp-op .gt } { ftz? t } { dest-type .u32 } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ set { cmp-op .gt } { bool-op .and } { ftz? t } { dest-type .u32 } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ set { cmp-op .gt } { bool-op .and } { ftz? t } { dest-type .u32 } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "!d" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	setp.gt.s32 a, b, c;
+	setp.gt.s32 a|z, b, c;
+	setp.gt.ftz.f32 a, b, c;
+	setp.gt.and.ftz.f32 a, b, c, d;
+	setp.gt.and.ftz.f32 a, b, c, !d;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ setp { cmp-op .gt } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+            T{ setp { cmp-op .gt } { type .s32 } { dest "a" } { |dest "z" } { a "b" } { b "c" } }
+            T{ setp { cmp-op .gt } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ setp { cmp-op .gt } { bool-op .and } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ setp { cmp-op .gt } { bool-op .and } { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "!d" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	shl.b32 a, b, c;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ shl { type .b32 } { dest "a" } { a "b" } { b "c" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	shr.b32 a, b, c;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ shr { type .b32 } { dest "a" } { a "b" } { b "c" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	sin.approx.f32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ sin { round .approx } { type .f32 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	slct.f32.s32 a, b, c, d;
+	slct.ftz.f32.s32 a, b, c, d;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ slct { dest-type .f32 } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+            T{ slct { ftz? t } { dest-type .f32 } { type .s32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	sqrt.approx.f32 a, b;
+	sqrt.approx.ftz.f32 a, b;
+	sqrt.f32 a, b;
+	sqrt.rz.f32 a, b;
+	sqrt.ftz.f32 a, b;
+	sqrt.rz.ftz.f32 a, b;
+	sqrt.f64 a, b;
+	sqrt.rz.f64 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ sqrt { round .approx } { type .f32 } { dest "a" } { a "b" } }
+            T{ sqrt { round .approx } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+            T{ sqrt { type .f32 } { dest "a" } { a "b" } }
+            T{ sqrt { round .rz } { type .f32 } { dest "a" } { a "b" } }
+            T{ sqrt { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+            T{ sqrt { round .rz } { ftz? t } { type .f32 } { dest "a" } { a "b" } }
+            T{ sqrt { type .f64 } { dest "a" } { a "b" } }
+            T{ sqrt { round .rz } { type .f64 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	st.u32 [a], b;
+	st.v2.u32 [a], b;
+	st.v4.u32 [a], b;
+	st.v4.u32 [a], {b, c, d, e};
+	st.lu.u32 [a], b;
+	st.local.lu.u32 [a], b;
+	st.volatile.local.u32 [a], b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ st { type .u32 } { dest "[a]" } { a "b" } }
+            T{ st { type T{ .v2 { of .u32 } } } { dest "[a]" } { a "b" } }
+            T{ st { type T{ .v4 { of .u32 } } } { dest "[a]" } { a "b" } }
+            T{ st { type T{ .v4 { of .u32 } } } { dest "[a]" } { a "{b, c, d, e}" } }
+            T{ st { cache-op .lu } { type .u32 } { dest "[a]" } { a "b" } }
+            T{ st { storage-space .local } { cache-op .lu } { type .u32 } { dest "[a]" } { a "b" } }
+            T{ st { volatile? t } { storage-space .local } { type .u32 } { dest "[a]" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	sub.s32 a, b, c;
+	sub.cc.s32 a, b, c;
+	sub.sat.s32 a, b, c;
+	sub.ftz.f32 a, b, c;
+	sub.ftz.sat.f32 a, b, c;
+	sub.rz.sat.f32 a, b, c;
+	sub.rz.ftz.sat.f32 a, b, c;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ sub { type .s32 } { dest "a" } { a "b" } { b "c" } }
+            T{ sub { cc? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+            T{ sub { sat? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+            T{ sub { ftz? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ sub { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ sub { round .rz } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+            T{ sub { round .rz } { ftz? t } { sat? t } { type .f32 } { dest "a" } { a "b" } { b "c" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	subc.s32 a, b, c;
+	subc.cc.s32 a, b, c;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ subc { type .s32 } { dest "a" } { a "b" } { b "c" } }
+            T{ subc { cc? t } { type .s32 } { dest "a" } { a "b" } { b "c" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	testp.finite.f32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ testp { op .finite } { type .f32 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	trap;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ trap }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	vote.all.pred a, b;
+	vote.all.pred a, !b;
+	vote.ballot.b32 a, b;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ vote { mode .all } { type .pred } { dest "a" } { a "b" } }
+            T{ vote { mode .all } { type .pred } { dest "a" } { a "!b" } }
+            T{ vote { mode .ballot } { type .b32 } { dest "a" } { a "b" } }
+        } }
+    } ptx>string
+] unit-test
+
+[ """	.version 2.0
+	.target sm_20
+	xor.b32 a, b, c;
+""" ] [
+    T{ ptx
+        { version "2.0" }
+        { target T{ ptx-target { arch sm_20 } } }
+        { body {
+            T{ xor { type .b32 } { dest "a" } { a "b" } { b "c" } }
+        } }
+    } ptx>string
+] unit-test
+
diff --git a/extra/cuda/ptx/ptx.factor b/extra/cuda/ptx/ptx.factor
index 8a30659640..4618f8b5b6 100644
--- a/extra/cuda/ptx/ptx.factor
+++ b/extra/cuda/ptx/ptx.factor
@@ -242,7 +242,7 @@ TUPLE: cnot      < ptx-2op-instruction ;
 TUPLE: copysign  < ptx-3op-instruction ;
 TUPLE: cos       <{ ptx-2op-instruction ptx-float-env } ;
 TUPLE: cvt       < ptx-2op-instruction
-    { rounding-mode ?ptx-rounding-mode }
+    { round ?ptx-rounding-mode }
     { ftz? boolean }
     { sat? boolean }
     { dest-type ptx-type } ;
@@ -254,7 +254,7 @@ TUPLE: ex2       <{ ptx-2op-instruction ptx-float-env } ;
 TUPLE: exit      < ptx-instruction ;
 TUPLE: fma       <{ ptx-mad-instruction ptx-float-env } ;
 TUPLE: isspacep  < ptx-instruction
-    { storage-space ?ptx-storage-space }
+    { storage-space ptx-storage-space }
     { dest string }
     { a string } ;
 TUPLE: ld        < ptx-ldst-instruction ;
@@ -547,7 +547,7 @@ M: bar.red (write-ptx-element)
     dup b>> [ ", " write write ] when*
     ", " write c>> write ;
 M: bar.sync (write-ptx-element)
-    "bar.arrive " write-insn
+    "bar.sync " write-insn
     dup a>> write
     dup b>> [ ", " write write ] when*
     drop ;
@@ -563,15 +563,16 @@ M: bfind (write-ptx-element)
     write-2op ;
 M: bra (write-ptx-element)
     "bra" write-insn
-    dup write-uni
-    " " write target>> write ;
+    dup write-uni " " write
+    target>> write ;
 M: brev (write-ptx-element)
     "brev" write-insn
     write-2op ;
 M: brkpt (write-ptx-element)
     "brkpt" write-insn drop ;
 M: call (write-ptx-element)
-    "call" write-insn " " write
+    "call" write-insn
+    dup write-uni " " write
     dup return>> [ "(" write write "), " write ] when*
     dup target>> write
     dup params>> [ ", (" write ", " join write ")" write ] unless-empty
@@ -591,7 +592,7 @@ M: cos (write-ptx-element)
     write-2op ;
 M: cvt (write-ptx-element)
     "cvt" write-insn
-    dup rounding-mode>> (write-ptx-element)
+    dup round>> (write-ptx-element)
     dup write-ftz
     dup write-sat
     dup dest-type>> (write-ptx-element)
@@ -685,12 +686,17 @@ M: prefetchu (write-ptx-element)
     " " write a>> write ;
 M: prmt (write-ptx-element)
     "prmt" write-insn
-    dup mode>> (write-ptx-element)
-    write-4op ;
+    dup type>> (write-ptx-element)
+    dup mode>> (write-ptx-element) " " write
+    dup dest>> write ", " write
+    dup a>> write ", " write
+    dup b>> write ", " write
+    dup c>> write
+    drop ;
 M: rcp (write-ptx-element)
     "rcp" write-insn
     dup write-float-env
-    write-3op ;
+    write-2op ;
 M: red (write-ptx-element)
     "red" write-insn
     dup storage-space>> (write-ptx-element)
@@ -758,6 +764,8 @@ M: testp (write-ptx-element)
     "testp" write-insn
     dup op>> (write-ptx-element)
     write-2op ;
+M: trap (write-ptx-element)
+    "trap" write-insn drop ;
 M: vote (write-ptx-element)
     "vote" write-insn
     dup mode>> (write-ptx-element)

From c9dc95b1031c9a2170ca96e06b7bf6f3d5d70f93 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 19 Apr 2010 17:09:06 -0500
Subject: [PATCH 021/158] Add a bare-bones javascriptcore.ffi binding

---
 .../core-foundation/authors.txt               |   1 +
 .../core-foundation/core-foundation.factor    |  11 +
 extra/javascriptcore/ffi/authors.txt          |   1 +
 extra/javascriptcore/ffi/ffi.factor           | 256 ++++++++++++++++++
 4 files changed, 269 insertions(+)
 create mode 100644 extra/javascriptcore/core-foundation/authors.txt
 create mode 100644 extra/javascriptcore/core-foundation/core-foundation.factor
 create mode 100644 extra/javascriptcore/ffi/authors.txt
 create mode 100644 extra/javascriptcore/ffi/ffi.factor

diff --git a/extra/javascriptcore/core-foundation/authors.txt b/extra/javascriptcore/core-foundation/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/javascriptcore/core-foundation/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/javascriptcore/core-foundation/core-foundation.factor b/extra/javascriptcore/core-foundation/core-foundation.factor
new file mode 100644
index 0000000000..9dfc93b101
--- /dev/null
+++ b/extra/javascriptcore/core-foundation/core-foundation.factor
@@ -0,0 +1,11 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax core-foundation core-foundation.strings
+javascriptcore.ffi ;
+IN: javascriptcore.core-foundation
+
+FUNCTION: JSStringRef JSStringCreateWithCFString ( CFStringRef string ) ;
+
+FUNCTION: CFStringRef JSStringCopyCFString ( CFAllocatorRef alloc, JSStringRef string ) ;
+
+
diff --git a/extra/javascriptcore/ffi/authors.txt b/extra/javascriptcore/ffi/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/javascriptcore/ffi/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/javascriptcore/ffi/ffi.factor b/extra/javascriptcore/ffi/ffi.factor
new file mode 100644
index 0000000000..b0458d3cf6
--- /dev/null
+++ b/extra/javascriptcore/ffi/ffi.factor
@@ -0,0 +1,256 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax classes.struct ;
+IN: javascriptcore.ffi
+
+TYPEDEF: void* JSContextGroupRef
+TYPEDEF: void* JSContextRef
+TYPEDEF: void* JSGlobalContextRef
+TYPEDEF: void* JSStringRef
+TYPEDEF: void* JSClassRef
+TYPEDEF: void* JSPropertyNameArrayRef
+TYPEDEF: void* JSPropertyNameAccumulatorRef
+TYPEDEF: void* JSValueRef
+TYPEDEF: void* JSObjectRef
+TYPEDEF: void* JSObjectInitializeCallback
+TYPEDEF: void* JSObjectFinalizeCallback
+TYPEDEF: void* JSObjectHasPropertyCallback
+TYPEDEF: void* JSObjectGetPropertyCallback
+TYPEDEF: void* JSObjectSetPropertyCallback
+TYPEDEF: void* JSObjectDeletePropertyCallback
+TYPEDEF: void* JSObjectGetPropertyNamesCallback
+TYPEDEF: void* JSObjectCallAsFunctionCallback
+TYPEDEF: void* JSObjectCallAsConstructorCallback
+TYPEDEF: void* JSObjectHasInstanceCallback
+TYPEDEF: void* JSObjectConvertToTypeCallback
+TYPEDEF: uint unsigned
+
+C-ENUM: JSPropertyAttributes
+    { kJSPropertyAttributeNone       0 }
+    { kJSPropertyAttributeReadOnly   2 }
+    { kJSPropertyAttributeDontEnum   4 }
+    { kJSPropertyAttributeDontDelete 8 } ;
+
+C-ENUM: JSClassAttributes
+    { kJSClassAttributeNone 0 }
+    { kJSClassAttributeNoAutomaticPrototype 2 } ;
+
+C-ENUM: JSType
+    kJSTypeUndefined,
+    kJSTypeNull,
+    kJSTypeBoolean,
+    kJSTypeNumber,
+    kJSTypeString,
+    kJSTypeObject ;
+
+STRUCT: JSStaticValue
+    { name c-string }
+    { getProperty JSObjectGetPropertyCallback }
+    { setProperty JSObjectSetPropertyCallback }
+    { attributes JSPropertyAttributes } ;
+
+STRUCT: JSStaticFunction
+    { name c-string }
+    { callAsFunction JSObjectCallAsFunctionCallback } ;
+
+STRUCT: JSClassDefinition
+    { version int }
+    { attributes JSClassAttributes }
+    { className c-string }
+    { parentClass JSClassRef }
+    { staticValues JSStaticValue* }
+    { staticFunctions JSStaticFunction* }
+    { initialize JSObjectInitializeCallback }
+    { finalize JSObjectFinalizeCallback }
+    { hasProperty JSObjectHasPropertyCallback }
+    { getProperty JSObjectGetPropertyCallback }
+    { setProperty JSObjectSetPropertyCallback }
+    { deleteProperty JSObjectDeletePropertyCallback }
+    { getPropertyNames JSObjectGetPropertyNamesCallback }
+    { callAsFunction JSObjectCallAsFunctionCallback }
+    { callAsConstructor JSObjectCallAsConstructorCallback }
+    { hasInstance JSObjectHasInstanceCallback }
+    { convertToType JSObjectConvertToTypeCallback } ;
+
+ALIAS: kJSClassDefinitionEmpty JSClassDefinition
+
+FUNCTION: JSValueRef JSEvaluateScript (
+    JSContextRef ctx,
+    JSStringRef script,
+    JSObjectRef thisObject,
+    JSStringRef sourceURL,
+    int startingLineNumber,
+    JSValueRef* exception ) ;
+
+FUNCTION: bool JSCheckScriptSyntax (
+    JSContextRef ctx,
+    JSStringRef script,
+    JSStringRef sourceURL,
+    int startingLineNumber,
+    JSValueRef* exception ) ;
+
+FUNCTION: void JSGarbageCollect
+    ( JSContextRef ctx ) ;
+
+FUNCTION: JSContextGroupRef JSContextGroupCreate
+    ( ) ;
+
+FUNCTION: JSContextGroupRef JSContextGroupRetain
+    ( JSContextGroupRef group ) ;
+
+FUNCTION: void JSContextGroupRelease
+    ( JSContextGroupRef group ) ;
+
+FUNCTION: JSGlobalContextRef JSGlobalContextCreate
+    ( JSClassRef globalObjectClass ) ; 
+
+FUNCTION: JSGlobalContextRef JSGlobalContextCreateInGroup (
+    JSContextGroupRef group,
+    JSClassRef globalObjectClass ) ;
+
+FUNCTION: JSGlobalContextRef JSGlobalContextRetain
+    ( JSGlobalContextRef ctx ) ;
+
+FUNCTION: void JSGlobalContextRelease
+    ( JSGlobalContextRef ctx ) ;
+
+FUNCTION: JSObjectRef JSContextGetGlobalObject
+    ( JSContextRef ctx ) ;
+
+FUNCTION: JSContextGroupRef JSContextGetGroup
+    ( JSContextRef ctx ) ;
+
+FUNCTION: JSClassRef JSClassCreate
+    ( JSClassDefinition* definition ) ;
+
+FUNCTION: JSClassRef JSClassRetain
+    ( JSClassRef jsClass ) ;
+
+FUNCTION: void JSClassRelease
+    ( JSClassRef jsClass ) ;
+
+FUNCTION: JSObjectRef JSObjectMake
+    ( JSContextRef ctx,
+      JSClassRef jsClass, void* data ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeFunctionWithCallback ( JSContextRef ctx, JSStringRef name, JSObjectCallAsFunctionCallback callAsFunction ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeConstructor ( JSContextRef ctx, JSClassRef jsClass, JSObjectCallAsConstructorCallback callAsConstructor ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeArray ( JSContextRef ctx, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeDate ( JSContextRef ctx, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeError ( JSContextRef ctx, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeRegExp ( JSContextRef ctx, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: JSObjectRef JSObjectMakeFunction ( JSContextRef ctx, JSStringRef name, unsigned parameterCount, JSStringRef parameterNames[], JSStringRef body, JSStringRef sourceURL, int startingLineNumber, JSValueRef* exception ) ;
+
+FUNCTION: JSValueRef JSObjectGetPrototype ( JSContextRef ctx, JSObjectRef object ) ;
+
+FUNCTION: void JSObjectSetPrototype ( JSContextRef ctx, JSObjectRef object, JSValueRef value ) ;
+
+FUNCTION: bool JSObjectHasProperty ( JSContextRef ctx, JSObjectRef object, JSStringRef propertyName ) ;
+
+FUNCTION: JSValueRef JSObjectGetProperty ( JSContextRef ctx, JSObjectRef object, JSStringRef propertyName, JSValueRef* exception ) ;
+
+FUNCTION: void JSObjectSetProperty ( JSContextRef ctx, JSObjectRef object, JSStringRef propertyName, JSValueRef value, JSPropertyAttributes attributes, JSValueRef* exception ) ;
+
+FUNCTION: bool JSObjectDeleteProperty ( JSContextRef ctx, JSObjectRef object, JSStringRef propertyName, JSValueRef* exception ) ;
+
+FUNCTION: JSValueRef JSObjectGetPropertyAtIndex ( JSContextRef ctx, JSObjectRef object, unsigned propertyIndex, JSValueRef* exception ) ;
+
+FUNCTION: void JSObjectSetPropertyAtIndex ( JSContextRef ctx, JSObjectRef object, unsigned propertyIndex, JSValueRef value, JSValueRef* exception ) ;
+
+FUNCTION: void* JSObjectGetPrivate ( JSObjectRef object ) ;
+
+FUNCTION: bool JSObjectSetPrivate ( JSObjectRef object, void* data ) ;
+
+FUNCTION: bool JSObjectIsFunction ( JSContextRef ctx, JSObjectRef object ) ;
+
+FUNCTION: JSValueRef JSObjectCallAsFunction ( JSContextRef ctx, JSObjectRef object, JSObjectRef thisObject, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: bool JSObjectIsConstructor ( JSContextRef ctx, JSObjectRef object ) ;
+
+FUNCTION: JSObjectRef JSObjectCallAsConstructor ( JSContextRef ctx, JSObjectRef object, size_t argumentCount, JSValueRef arguments[], JSValueRef* exception ) ;
+
+FUNCTION: JSPropertyNameArrayRef JSObjectCopyPropertyNames ( JSContextRef ctx, JSObjectRef object ) ;
+
+FUNCTION: JSPropertyNameArrayRef JSPropertyNameArrayRetain ( JSPropertyNameArrayRef array ) ;
+
+FUNCTION: void JSPropertyNameArrayRelease ( JSPropertyNameArrayRef array ) ;
+
+FUNCTION: size_t JSPropertyNameArrayGetCount ( JSPropertyNameArrayRef array ) ;
+
+FUNCTION: JSStringRef JSPropertyNameArrayGetNameAtIndex ( JSPropertyNameArrayRef array, size_t index ) ;
+
+FUNCTION: void JSPropertyNameAccumulatorAddName ( JSPropertyNameAccumulatorRef accumulator, JSStringRef propertyName ) ;
+
+! char[utf16n] for strings
+TYPEDEF: ushort JSChar
+
+FUNCTION: JSStringRef JSStringCreateWithCharacters ( JSChar* chars, size_t numChars ) ;
+
+FUNCTION: JSStringRef JSStringCreateWithUTF8CString ( char* string ) ;
+
+FUNCTION: JSStringRef JSStringRetain ( JSStringRef string ) ;
+
+FUNCTION: void JSStringRelease ( JSStringRef string ) ;
+
+FUNCTION: size_t JSStringGetLength ( JSStringRef string ) ;
+
+FUNCTION: JSChar* JSStringGetCharactersPtr ( JSStringRef string ) ;
+
+FUNCTION: size_t JSStringGetMaximumUTF8CStringSize ( JSStringRef string ) ;
+
+FUNCTION: size_t JSStringGetUTF8CString ( JSStringRef string, char* buffer, size_t bufferSize ) ;
+
+FUNCTION: bool JSStringIsEqual ( JSStringRef a, JSStringRef b ) ;
+
+FUNCTION: bool JSStringIsEqualToUTF8CString ( JSStringRef a, char* b ) ;
+
+FUNCTION: JSType JSValueGetType ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsUndefined ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsNull ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsBoolean ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsNumber ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsString ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsObject ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: bool JSValueIsObjectOfClass ( JSContextRef ctx, JSValueRef value, JSClassRef jsClass ) ;
+
+FUNCTION: bool JSValueIsEqual ( JSContextRef ctx, JSValueRef a, JSValueRef b, JSValueRef* exception ) ;
+
+FUNCTION: bool JSValueIsStrictEqual ( JSContextRef ctx, JSValueRef a, JSValueRef b ) ;
+
+FUNCTION: bool JSValueIsInstanceOfConstructor ( JSContextRef ctx, JSValueRef value, JSObjectRef constructor, JSValueRef* exception ) ;
+
+FUNCTION: JSValueRef JSValueMakeUndefined ( JSContextRef ctx ) ;
+
+FUNCTION: JSValueRef JSValueMakeNull ( JSContextRef ctx ) ;
+
+FUNCTION: JSValueRef JSValueMakeBoolean ( JSContextRef ctx, bool boolean ) ;
+
+FUNCTION: JSValueRef JSValueMakeNumber ( JSContextRef ctx, double number ) ;
+
+FUNCTION: JSValueRef JSValueMakeString ( JSContextRef ctx, JSStringRef string ) ;
+
+FUNCTION: bool JSValueToBoolean ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: double JSValueToNumber ( JSContextRef ctx, JSValueRef value, JSValueRef* exception ) ;
+
+FUNCTION: JSStringRef JSValueToStringCopy ( JSContextRef ctx, JSValueRef value, JSValueRef* exception ) ;
+
+FUNCTION: JSObjectRef JSValueToObject ( JSContextRef ctx, JSValueRef value, JSValueRef* exception ) ;
+
+FUNCTION: void JSValueProtect ( JSContextRef ctx, JSValueRef value ) ;
+
+FUNCTION: void JSValueUnprotect ( JSContextRef ctx, JSValueRef value ) ;
+

From 6bd0c02b343bbcb3c39bf814b9f7c286b35429fd Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 19 Apr 2010 17:12:52 -0500
Subject: [PATCH 022/158] Only load core-foundation vocab on macosx

---
 extra/javascriptcore/core-foundation/platforms.txt | 1 +
 1 file changed, 1 insertion(+)
 create mode 100644 extra/javascriptcore/core-foundation/platforms.txt

diff --git a/extra/javascriptcore/core-foundation/platforms.txt b/extra/javascriptcore/core-foundation/platforms.txt
new file mode 100644
index 0000000000..6e806f449e
--- /dev/null
+++ b/extra/javascriptcore/core-foundation/platforms.txt
@@ -0,0 +1 @@
+macosx

From 5249ebfdf20a46efc029b7208bc81829acc6c5bc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 19 Apr 2010 18:03:44 -0500
Subject: [PATCH 023/158] Use the javascriptcore library in javascriptcore
 bindings..

---
 extra/javascriptcore/ffi/ffi.factor | 20 +++++++++++++++-----
 1 file changed, 15 insertions(+), 5 deletions(-)

diff --git a/extra/javascriptcore/ffi/ffi.factor b/extra/javascriptcore/ffi/ffi.factor
index b0458d3cf6..844e169eed 100644
--- a/extra/javascriptcore/ffi/ffi.factor
+++ b/extra/javascriptcore/ffi/ffi.factor
@@ -1,8 +1,19 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax classes.struct ;
+USING: alien alien.c-types alien.libraries alien.syntax
+classes.struct combinators io.encodings.utf8 system ;
 IN: javascriptcore.ffi
 
+<<
+"javascriptcore" {
+        { [ os macosx? ] [ "/System/Library/Frameworks/JavaScriptCore.framework/Versions/Current/JavaScriptCore" ] }
+        ! { [ os winnt? ]  [ "javascriptcore.dll" ] }
+        ! { [ os unix? ]  [ "libsqlite3.so" ] }
+    } cond cdecl add-library
+>>
+
+LIBRARY: javascriptcore
+
 TYPEDEF: void* JSContextGroupRef
 TYPEDEF: void* JSContextRef
 TYPEDEF: void* JSGlobalContextRef
@@ -24,6 +35,8 @@ TYPEDEF: void* JSObjectCallAsConstructorCallback
 TYPEDEF: void* JSObjectHasInstanceCallback
 TYPEDEF: void* JSObjectConvertToTypeCallback
 TYPEDEF: uint unsigned
+TYPEDEF: ushort JSChar
+! char[utf16n] for strings
 
 C-ENUM: JSPropertyAttributes
     { kJSPropertyAttributeNone       0 }
@@ -187,12 +200,9 @@ FUNCTION: JSStringRef JSPropertyNameArrayGetNameAtIndex ( JSPropertyNameArrayRef
 
 FUNCTION: void JSPropertyNameAccumulatorAddName ( JSPropertyNameAccumulatorRef accumulator, JSStringRef propertyName ) ;
 
-! char[utf16n] for strings
-TYPEDEF: ushort JSChar
-
 FUNCTION: JSStringRef JSStringCreateWithCharacters ( JSChar* chars, size_t numChars ) ;
 
-FUNCTION: JSStringRef JSStringCreateWithUTF8CString ( char* string ) ;
+FUNCTION: JSStringRef JSStringCreateWithUTF8CString ( c-string[utf8] string ) ;
 
 FUNCTION: JSStringRef JSStringRetain ( JSStringRef string ) ;
 

From 1a6a8d4c93d52622ca942552a7140d9c440a9b63 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 19 Apr 2010 20:07:39 -0500
Subject: [PATCH 024/158] Add a with-javascriptcore combinator to set the
 callstack bounds before calling javascriptcore ffi functions

---
 extra/javascriptcore/authors.txt           |  1 +
 extra/javascriptcore/ffi/hack/authors.txt  |  1 +
 extra/javascriptcore/ffi/hack/hack.factor  | 29 ++++++++++++++++++++++
 extra/javascriptcore/javascriptcore.factor |  8 ++++++
 4 files changed, 39 insertions(+)
 create mode 100644 extra/javascriptcore/authors.txt
 create mode 100644 extra/javascriptcore/ffi/hack/authors.txt
 create mode 100644 extra/javascriptcore/ffi/hack/hack.factor
 create mode 100644 extra/javascriptcore/javascriptcore.factor

diff --git a/extra/javascriptcore/authors.txt b/extra/javascriptcore/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/javascriptcore/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/javascriptcore/ffi/hack/authors.txt b/extra/javascriptcore/ffi/hack/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/javascriptcore/ffi/hack/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/javascriptcore/ffi/hack/hack.factor b/extra/javascriptcore/ffi/hack/hack.factor
new file mode 100644
index 0000000000..1866a24e22
--- /dev/null
+++ b/extra/javascriptcore/ffi/hack/hack.factor
@@ -0,0 +1,29 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors alien.syntax kernel kernel.private
+math system ;
+IN: javascriptcore.ffi.hack
+
+HOOK: set-callstack-bounds os ( -- )
+
+HOOK: macosx-callstack-start-offset cpu ( -- address )
+HOOK: macosx-callstack-size-offset cpu ( -- address )
+
+M: ppc macosx-callstack-start-offset HEX: 188 ;
+M: ppc macosx-callstack-size-offset HEX: 18c ;
+
+M: x86.32 macosx-callstack-start-offset HEX: c48 ;
+M: x86.32 macosx-callstack-size-offset HEX: c4c ;
+
+M: x86.64 macosx-callstack-start-offset HEX: 1860 ;
+M: x86.64 macosx-callstack-size-offset HEX: 1868 ;
+
+M: object set-callstack-bounds ;
+
+FUNCTION: void* pthread_self ( ) ;
+
+M: macosx set-callstack-bounds
+    callstack-bounds over [ alien-address ] bi@ -
+    pthread_self
+    [ macosx-callstack-size-offset set-alien-unsigned-cell ]
+    [ macosx-callstack-start-offset set-alien-cell ] bi ;
diff --git a/extra/javascriptcore/javascriptcore.factor b/extra/javascriptcore/javascriptcore.factor
new file mode 100644
index 0000000000..773a559d2d
--- /dev/null
+++ b/extra/javascriptcore/javascriptcore.factor
@@ -0,0 +1,8 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: javascriptcore.ffi.hack kernel ;
+IN: javascriptcore
+
+: with-javascriptcore ( quot -- )
+    set-callstack-bounds
+    call ; inline

From 366ce2896fb33fad5f52c39ef88041c08ef5bd8e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 19 Apr 2010 20:08:15 -0500
Subject: [PATCH 025/158] Add callstack-bounds primitive to vm/ for use with
 javascriptcore library

---
 basis/stack-checker/known-words/known-words.factor | 1 +
 core/bootstrap/primitives.factor                   | 1 +
 vm/callstack.cpp                                   | 6 ++++++
 vm/primitives.hpp                                  | 1 +
 vm/vm.hpp                                          | 1 +
 5 files changed, 10 insertions(+)

diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 1fa9a94677..c0d4b6c543 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -349,6 +349,7 @@ M: bad-executable summary
 \ both-fixnums? { object object } { object } define-primitive
 \ byte-array>bignum { byte-array } { bignum } define-primitive \ byte-array>bignum make-foldable
 \ callstack { } { callstack } define-primitive \ callstack make-flushable
+\ callstack-bounds { } { alien alien } define-primitive \ callstack-bounds make-flushable
 \ callstack-for { c-ptr } { callstack } define-primitive \ callstack make-flushable
 \ callstack>array { callstack } { array } define-primitive \ callstack>array make-flushable
 \ check-datastack { array integer integer } { object } define-primitive \ check-datastack make-flushable
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index c466b0c1f8..27699725f1 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -451,6 +451,7 @@ tuple
     { "retainstack" "kernel" "primitive_retainstack" (( -- array )) }
     { "(identity-hashcode)" "kernel.private" "primitive_identity_hashcode" (( obj -- code )) }
     { "become" "kernel.private" "primitive_become" (( old new -- )) }
+    { "callstack-bounds" "kernel.private" "primitive_callstack_bounds" (( -- start end )) }
     { "check-datastack" "kernel.private" "primitive_check_datastack" (( array in# out# -- ? )) }
     { "compute-identity-hashcode" "kernel.private" "primitive_compute_identity_hashcode" (( obj -- )) }
     { "context-object" "kernel.private" "primitive_context_object" (( n -- obj )) }
diff --git a/vm/callstack.cpp b/vm/callstack.cpp
index eae976219f..bb716cbc6d 100755
--- a/vm/callstack.cpp
+++ b/vm/callstack.cpp
@@ -214,4 +214,10 @@ void factor_vm::primitive_set_innermost_stack_frame_quot()
 	FRAME_RETURN_ADDRESS(inner,this) = (char *)quot->entry_point + offset;
 }
 
+void factor_vm::primitive_callstack_bounds()
+{
+	ctx->push(allot_alien((void*)ctx->callstack_seg->start));
+	ctx->push(allot_alien((void*)ctx->callstack_seg->end));
+}
+
 }
diff --git a/vm/primitives.hpp b/vm/primitives.hpp
index e98cf508b6..a2bf912749 100644
--- a/vm/primitives.hpp
+++ b/vm/primitives.hpp
@@ -35,6 +35,7 @@ namespace factor
 	_(byte_array_to_bignum) \
 	_(callback) \
 	_(callstack) \
+	_(callstack_bounds) \
 	_(callstack_for) \
 	_(callstack_to_array) \
 	_(check_datastack) \
diff --git a/vm/vm.hpp b/vm/vm.hpp
index dd1d48cf03..d9bd17fa51 100755
--- a/vm/vm.hpp
+++ b/vm/vm.hpp
@@ -606,6 +606,7 @@ struct factor_vm
 	void primitive_innermost_stack_frame_executing();
 	void primitive_innermost_stack_frame_scan();
 	void primitive_set_innermost_stack_frame_quot();
+	void primitive_callstack_bounds();
 	template<typename Iterator> void iterate_callstack(context *ctx, Iterator &iterator);
 
 	// alien

From ebd6594ef5767bc613ad45062706d007ad53aa9f Mon Sep 17 00:00:00 2001
From: Erik Charlebois <erikcharlebois@gmail.com>
Date: Thu, 15 Apr 2010 01:21:55 -0700
Subject: [PATCH 026/158] Resources file for fluids and using vocab: instead of
 resource: for file paths.

---
 extra/fluids/fluids.factor | 4 ++--
 extra/fluids/resources.txt | 2 ++
 2 files changed, 4 insertions(+), 2 deletions(-)
 create mode 100644 extra/fluids/resources.txt

diff --git a/extra/fluids/fluids.factor b/extra/fluids/fluids.factor
index f383534658..f2d02b22a3 100644
--- a/extra/fluids/fluids.factor
+++ b/extra/fluids/fluids.factor
@@ -78,8 +78,8 @@ M: fluids-world begin-game-world
     dup fluid set
     init-gpu
     initial-particles clone >>particles
-    "resource:extra/fluids/particle2.pgm" make-texture >>texture
-    "resource:extra/fluids/colors.ppm" make-texture >>ramp
+    "vocab:fluids/particle2.pgm" make-texture >>texture
+    "vocab:fluids/colors.ppm" make-texture >>ramp
     drop ;
 
 M: fluids-world end-game-world
diff --git a/extra/fluids/resources.txt b/extra/fluids/resources.txt
new file mode 100644
index 0000000000..f37e69289d
--- /dev/null
+++ b/extra/fluids/resources.txt
@@ -0,0 +1,2 @@
+particle2.pgm
+colors.ppm

From 8d5b270fbd00bdab58019fb85097625acab0ae22 Mon Sep 17 00:00:00 2001
From: Erik Charlebois <erikcharlebois@gmail.com>
Date: Fri, 16 Apr 2010 18:24:30 -0700
Subject: [PATCH 027/158] DWARF ffi constants

---
 extra/dwarf/dwarf.factor | 791 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 791 insertions(+)
 create mode 100644 extra/dwarf/dwarf.factor

diff --git a/extra/dwarf/dwarf.factor b/extra/dwarf/dwarf.factor
new file mode 100644
index 0000000000..f6c6c46b23
--- /dev/null
+++ b/extra/dwarf/dwarf.factor
@@ -0,0 +1,791 @@
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: dwarf
+
+CONSTANT: DW_TAG_array_type               HEX: 01
+CONSTANT: DW_TAG_class_type               HEX: 02
+CONSTANT: DW_TAG_entry_point              HEX: 03
+CONSTANT: DW_TAG_enumeration_type         HEX: 04
+CONSTANT: DW_TAG_formal_parameter         HEX: 05
+CONSTANT: DW_TAG_imported_declaration     HEX: 08
+CONSTANT: DW_TAG_label                    HEX: 0a
+CONSTANT: DW_TAG_lexical_block            HEX: 0b
+CONSTANT: DW_TAG_member                   HEX: 0d
+CONSTANT: DW_TAG_pointer_type             HEX: 0f
+CONSTANT: DW_TAG_reference_type           HEX: 10
+CONSTANT: DW_TAG_compile_unit             HEX: 11
+CONSTANT: DW_TAG_string_type              HEX: 12
+CONSTANT: DW_TAG_structure_type           HEX: 13
+CONSTANT: DW_TAG_subroutine_type          HEX: 15
+CONSTANT: DW_TAG_typedef                  HEX: 16
+CONSTANT: DW_TAG_union_type               HEX: 17
+CONSTANT: DW_TAG_unspecified_parameters   HEX: 18
+CONSTANT: DW_TAG_variant                  HEX: 19
+CONSTANT: DW_TAG_common_block             HEX: 1a
+CONSTANT: DW_TAG_common_inclusion         HEX: 1b
+CONSTANT: DW_TAG_inheritance              HEX: 1c
+CONSTANT: DW_TAG_inlined_subroutine       HEX: 1d
+CONSTANT: DW_TAG_module                   HEX: 1e
+CONSTANT: DW_TAG_ptr_to_member_type       HEX: 1f
+CONSTANT: DW_TAG_set_type                 HEX: 20
+CONSTANT: DW_TAG_subrange_type            HEX: 21
+CONSTANT: DW_TAG_with_stmt                HEX: 22
+CONSTANT: DW_TAG_access_declaration       HEX: 23
+CONSTANT: DW_TAG_base_type                HEX: 24
+CONSTANT: DW_TAG_catch_block              HEX: 25
+CONSTANT: DW_TAG_const_type               HEX: 26
+CONSTANT: DW_TAG_constant                 HEX: 27
+CONSTANT: DW_TAG_enumerator               HEX: 28
+CONSTANT: DW_TAG_file_type                HEX: 29
+CONSTANT: DW_TAG_friend                   HEX: 2a
+CONSTANT: DW_TAG_namelist                 HEX: 2b
+CONSTANT: DW_TAG_namelist_item            HEX: 2c
+CONSTANT: DW_TAG_packed_type              HEX: 2d
+CONSTANT: DW_TAG_subprogram               HEX: 2e
+CONSTANT: DW_TAG_template_type_parameter  HEX: 2f
+CONSTANT: DW_TAG_template_value_parameter HEX: 30
+CONSTANT: DW_TAG_thrown_type              HEX: 31
+CONSTANT: DW_TAG_try_block                HEX: 32
+CONSTANT: DW_TAG_variant_part             HEX: 33
+CONSTANT: DW_TAG_variable                 HEX: 34
+CONSTANT: DW_TAG_volatile_type            HEX: 35
+CONSTANT: DW_TAG_dwarf_procedure          HEX: 36
+CONSTANT: DW_TAG_restrict_type            HEX: 37
+CONSTANT: DW_TAG_interface_type           HEX: 38
+CONSTANT: DW_TAG_namespace                HEX: 39
+CONSTANT: DW_TAG_imported_module          HEX: 3a
+CONSTANT: DW_TAG_unspecified_type         HEX: 3b
+CONSTANT: DW_TAG_partial_unit             HEX: 3c
+CONSTANT: DW_TAG_imported_unit            HEX: 3d
+CONSTANT: DW_TAG_condition                HEX: 3f
+CONSTANT: DW_TAG_shared_type              HEX: 40
+CONSTANT: DW_TAG_type_unit                HEX: 41
+CONSTANT: DW_TAG_rvalue_reference_type    HEX: 42
+CONSTANT: DW_TAG_template_alias           HEX: 43
+
+CONSTANT: DW_TAG_lo_user                  HEX: 4080
+
+CONSTANT: DW_TAG_MIPS_loop                HEX: 4081
+CONSTANT: DW_TAG_HP_array_descriptor      HEX: 4090
+CONSTANT: DW_TAG_format_label             HEX: 4101
+CONSTANT: DW_TAG_function_template        HEX: 4102
+CONSTANT: DW_TAG_class_template           HEX: 4103
+CONSTANT: DW_TAG_GNU_BINCL                HEX: 4104
+CONSTANT: DW_TAG_GNU_EINCL                HEX: 4105
+CONSTANT: DW_TAG_GNU_template_template_parameter  HEX: 4106
+CONSTANT: DW_TAG_GNU_template_parameter_pack      HEX: 4107
+CONSTANT: DW_TAG_GNU_formal_parameter_pack        HEX: 4108
+CONSTANT: DW_TAG_ALTIUM_circ_type         HEX: 5101
+CONSTANT: DW_TAG_ALTIUM_mwa_circ_type     HEX: 5102
+CONSTANT: DW_TAG_ALTIUM_rev_carry_type    HEX: 5103
+CONSTANT: DW_TAG_ALTIUM_rom               HEX: 5111
+CONSTANT: DW_TAG_upc_shared_type          HEX: 8765
+CONSTANT: DW_TAG_upc_strict_type          HEX: 8766
+CONSTANT: DW_TAG_upc_relaxed_type         HEX: 8767
+CONSTANT: DW_TAG_PGI_kanji_type           HEX: a000
+CONSTANT: DW_TAG_PGI_interface_block      HEX: a020
+CONSTANT: DW_TAG_SUN_function_template    HEX: 4201
+CONSTANT: DW_TAG_SUN_class_template       HEX: 4202
+CONSTANT: DW_TAG_SUN_struct_template      HEX: 4203
+CONSTANT: DW_TAG_SUN_union_template       HEX: 4204
+CONSTANT: DW_TAG_SUN_indirect_inheritance HEX: 4205
+CONSTANT: DW_TAG_SUN_codeflags            HEX: 4206
+CONSTANT: DW_TAG_SUN_memop_info           HEX: 4207
+CONSTANT: DW_TAG_SUN_omp_child_func       HEX: 4208
+CONSTANT: DW_TAG_SUN_rtti_descriptor      HEX: 4209
+CONSTANT: DW_TAG_SUN_dtor_info            HEX: 420a
+CONSTANT: DW_TAG_SUN_dtor                 HEX: 420b
+CONSTANT: DW_TAG_SUN_f90_interface        HEX: 420c
+CONSTANT: DW_TAG_SUN_fortran_vax_structure HEX: 420d
+CONSTANT: DW_TAG_SUN_hi                   HEX: 42ff
+    
+CONSTANT: DW_TAG_hi_user                  HEX: ffff
+
+CONSTANT: DW_children_no  0
+CONSTANT: DW_children_yes 1
+
+CONSTANT: DW_FORM_addr                    HEX: 01
+CONSTANT: DW_FORM_block2                  HEX: 03
+CONSTANT: DW_FORM_block4                  HEX: 04
+CONSTANT: DW_FORM_data2                   HEX: 05
+CONSTANT: DW_FORM_data4                   HEX: 06
+CONSTANT: DW_FORM_data8                   HEX: 07
+CONSTANT: DW_FORM_string                  HEX: 08
+CONSTANT: DW_FORM_block                   HEX: 09
+CONSTANT: DW_FORM_block1                  HEX: 0a
+CONSTANT: DW_FORM_data1                   HEX: 0b
+CONSTANT: DW_FORM_flag                    HEX: 0c
+CONSTANT: DW_FORM_sdata                   HEX: 0d
+CONSTANT: DW_FORM_strp                    HEX: 0e
+CONSTANT: DW_FORM_udata                   HEX: 0f
+CONSTANT: DW_FORM_ref_addr                HEX: 10
+CONSTANT: DW_FORM_ref1                    HEX: 11
+CONSTANT: DW_FORM_ref2                    HEX: 12
+CONSTANT: DW_FORM_ref4                    HEX: 13
+CONSTANT: DW_FORM_ref8                    HEX: 14
+CONSTANT: DW_FORM_ref_udata               HEX: 15
+CONSTANT: DW_FORM_indirect                HEX: 16
+CONSTANT: DW_FORM_sec_offset              HEX: 17
+CONSTANT: DW_FORM_exprloc                 HEX: 18
+CONSTANT: DW_FORM_flag_present            HEX: 19
+CONSTANT: DW_FORM_ref_sig8                HEX: 20
+
+CONSTANT: DW_AT_sibling                           HEX: 01
+CONSTANT: DW_AT_location                          HEX: 02
+CONSTANT: DW_AT_name                              HEX: 03
+CONSTANT: DW_AT_ordering                          HEX: 09
+CONSTANT: DW_AT_subscr_data                       HEX: 0a
+CONSTANT: DW_AT_byte_size                         HEX: 0b
+CONSTANT: DW_AT_bit_offset                        HEX: 0c
+CONSTANT: DW_AT_bit_size                          HEX: 0d
+CONSTANT: DW_AT_element_list                      HEX: 0f
+CONSTANT: DW_AT_stmt_list                         HEX: 10
+CONSTANT: DW_AT_low_pc                            HEX: 11
+CONSTANT: DW_AT_high_pc                           HEX: 12
+CONSTANT: DW_AT_language                          HEX: 13
+CONSTANT: DW_AT_member                            HEX: 14
+CONSTANT: DW_AT_discr                             HEX: 15
+CONSTANT: DW_AT_discr_value                       HEX: 16
+CONSTANT: DW_AT_visibility                        HEX: 17
+CONSTANT: DW_AT_import                            HEX: 18
+CONSTANT: DW_AT_string_length                     HEX: 19
+CONSTANT: DW_AT_common_reference                  HEX: 1a
+CONSTANT: DW_AT_comp_dir                          HEX: 1b
+CONSTANT: DW_AT_const_value                       HEX: 1c
+CONSTANT: DW_AT_containing_type                   HEX: 1d
+CONSTANT: DW_AT_default_value                     HEX: 1e
+CONSTANT: DW_AT_inline                            HEX: 20
+CONSTANT: DW_AT_is_optional                       HEX: 21
+CONSTANT: DW_AT_lower_bound                       HEX: 22
+CONSTANT: DW_AT_producer                          HEX: 25
+CONSTANT: DW_AT_prototyped                        HEX: 27
+CONSTANT: DW_AT_return_addr                       HEX: 2a
+CONSTANT: DW_AT_start_scope                       HEX: 2c
+CONSTANT: DW_AT_bit_stride                        HEX: 2e
+CONSTANT: DW_AT_upper_bound                       HEX: 2f
+CONSTANT: DW_AT_abstract_origin                   HEX: 31
+CONSTANT: DW_AT_accessibility                     HEX: 32
+CONSTANT: DW_AT_address_class                     HEX: 33
+CONSTANT: DW_AT_artificial                        HEX: 34
+CONSTANT: DW_AT_base_types                        HEX: 35
+CONSTANT: DW_AT_calling_convention                HEX: 36
+CONSTANT: DW_AT_count                             HEX: 37
+CONSTANT: DW_AT_data_member_location              HEX: 38
+CONSTANT: DW_AT_decl_column                       HEX: 39
+CONSTANT: DW_AT_decl_file                         HEX: 3a
+CONSTANT: DW_AT_decl_line                         HEX: 3b
+CONSTANT: DW_AT_declaration                       HEX: 3c
+CONSTANT: DW_AT_discr_list                        HEX: 3d
+CONSTANT: DW_AT_encoding                          HEX: 3e
+CONSTANT: DW_AT_external                          HEX: 3f
+CONSTANT: DW_AT_frame_base                        HEX: 40
+CONSTANT: DW_AT_friend                            HEX: 41
+CONSTANT: DW_AT_identifier_case                   HEX: 42
+CONSTANT: DW_AT_macro_info                        HEX: 43
+CONSTANT: DW_AT_namelist_item                     HEX: 44
+CONSTANT: DW_AT_priority                          HEX: 45
+CONSTANT: DW_AT_segment                           HEX: 46
+CONSTANT: DW_AT_specification                     HEX: 47
+CONSTANT: DW_AT_static_link                       HEX: 48
+CONSTANT: DW_AT_type                              HEX: 49
+CONSTANT: DW_AT_use_location                      HEX: 4a
+CONSTANT: DW_AT_variable_parameter                HEX: 4b
+CONSTANT: DW_AT_virtuality                        HEX: 4c
+CONSTANT: DW_AT_vtable_elem_location              HEX: 4d
+CONSTANT: DW_AT_allocated                         HEX: 4e
+CONSTANT: DW_AT_associated                        HEX: 4f
+CONSTANT: DW_AT_data_location                     HEX: 50
+CONSTANT: DW_AT_byte_stride                       HEX: 51
+CONSTANT: DW_AT_entry_pc                          HEX: 52
+CONSTANT: DW_AT_use_UTF8                          HEX: 53
+CONSTANT: DW_AT_extension                         HEX: 54
+CONSTANT: DW_AT_ranges                            HEX: 55
+CONSTANT: DW_AT_trampoline                        HEX: 56
+CONSTANT: DW_AT_call_column                       HEX: 57
+CONSTANT: DW_AT_call_file                         HEX: 58
+CONSTANT: DW_AT_call_line                         HEX: 59
+CONSTANT: DW_AT_description                       HEX: 5a
+CONSTANT: DW_AT_binary_scale                      HEX: 5b
+CONSTANT: DW_AT_decimal_scale                     HEX: 5c
+CONSTANT: DW_AT_small                             HEX: 5d
+CONSTANT: DW_AT_decimal_sign                      HEX: 5e
+CONSTANT: DW_AT_digit_count                       HEX: 5f
+CONSTANT: DW_AT_picture_string                    HEX: 60
+CONSTANT: DW_AT_mutable                           HEX: 61
+CONSTANT: DW_AT_threads_scaled                    HEX: 62
+CONSTANT: DW_AT_explicit                          HEX: 63
+CONSTANT: DW_AT_object_pointer                    HEX: 64
+CONSTANT: DW_AT_endianity                         HEX: 65
+CONSTANT: DW_AT_elemental                         HEX: 66
+CONSTANT: DW_AT_pure                              HEX: 67
+CONSTANT: DW_AT_recursive                         HEX: 68
+CONSTANT: DW_AT_signature                         HEX: 69
+CONSTANT: DW_AT_main_subprogram                   HEX: 6a
+CONSTANT: DW_AT_data_bit_offset                   HEX: 6b
+CONSTANT: DW_AT_const_expr                        HEX: 6c
+CONSTANT: DW_AT_enum_class                        HEX: 6d
+CONSTANT: DW_AT_linkage_name                      HEX: 6e
+
+CONSTANT: DW_AT_HP_block_index                    HEX: 2000
+
+CONSTANT: DW_AT_lo_user                           HEX: 2000
+
+CONSTANT: DW_AT_MIPS_fde                          HEX: 2001
+CONSTANT: DW_AT_MIPS_loop_begin                   HEX: 2002
+CONSTANT: DW_AT_MIPS_tail_loop_begin              HEX: 2003
+CONSTANT: DW_AT_MIPS_epilog_begin                 HEX: 2004
+CONSTANT: DW_AT_MIPS_loop_unroll_factor           HEX: 2005
+CONSTANT: DW_AT_MIPS_software_pipeline_depth      HEX: 2006
+CONSTANT: DW_AT_MIPS_linkage_name                 HEX: 2007
+CONSTANT: DW_AT_MIPS_stride                       HEX: 2008
+CONSTANT: DW_AT_MIPS_abstract_name                HEX: 2009
+CONSTANT: DW_AT_MIPS_clone_origin                 HEX: 200a
+CONSTANT: DW_AT_MIPS_has_inlines                  HEX: 200b
+CONSTANT: DW_AT_MIPS_stride_byte                  HEX: 200c
+CONSTANT: DW_AT_MIPS_stride_elem                  HEX: 200d
+CONSTANT: DW_AT_MIPS_ptr_dopetype                 HEX: 200e
+CONSTANT: DW_AT_MIPS_allocatable_dopetype         HEX: 200f
+CONSTANT: DW_AT_MIPS_assumed_shape_dopetype       HEX: 2010
+CONSTANT: DW_AT_MIPS_assumed_size                 HEX: 2011
+
+CONSTANT: DW_AT_HP_unmodifiable                   HEX: 2001
+CONSTANT: DW_AT_HP_actuals_stmt_list              HEX: 2010
+CONSTANT: DW_AT_HP_proc_per_section               HEX: 2011
+CONSTANT: DW_AT_HP_raw_data_ptr                   HEX: 2012
+CONSTANT: DW_AT_HP_pass_by_reference              HEX: 2013
+CONSTANT: DW_AT_HP_opt_level                      HEX: 2014
+CONSTANT: DW_AT_HP_prof_version_id                HEX: 2015
+CONSTANT: DW_AT_HP_opt_flags                      HEX: 2016
+CONSTANT: DW_AT_HP_cold_region_low_pc             HEX: 2017
+CONSTANT: DW_AT_HP_cold_region_high_pc            HEX: 2018
+CONSTANT: DW_AT_HP_all_variables_modifiable       HEX: 2019
+CONSTANT: DW_AT_HP_linkage_name                   HEX: 201a
+CONSTANT: DW_AT_HP_prof_flags                     HEX: 201b
+
+CONSTANT: DW_AT_CPQ_discontig_ranges              HEX: 2001
+CONSTANT: DW_AT_CPQ_semantic_events               HEX: 2002
+CONSTANT: DW_AT_CPQ_split_lifetimes_var           HEX: 2003
+CONSTANT: DW_AT_CPQ_split_lifetimes_rtn           HEX: 2004
+CONSTANT: DW_AT_CPQ_prologue_length               HEX: 2005
+
+CONSTANT: DW_AT_INTEL_other_endian                HEX: 2026
+
+CONSTANT: DW_AT_sf_names                          HEX: 2101
+CONSTANT: DW_AT_src_info                          HEX: 2102
+CONSTANT: DW_AT_mac_info                          HEX: 2103
+CONSTANT: DW_AT_src_coords                        HEX: 2104
+CONSTANT: DW_AT_body_begin                        HEX: 2105
+CONSTANT: DW_AT_body_end                          HEX: 2106
+CONSTANT: DW_AT_GNU_vector                        HEX: 2107
+CONSTANT: DW_AT_GNU_template_name                 HEX: 2108
+
+CONSTANT: DW_AT_ALTIUM_loclist    HEX: 2300         
+
+CONSTANT: DW_AT_SUN_template                      HEX: 2201
+CONSTANT: DW_AT_VMS_rtnbeg_pd_address             HEX: 2201
+CONSTANT: DW_AT_SUN_alignment                     HEX: 2202
+CONSTANT: DW_AT_SUN_vtable                        HEX: 2203
+CONSTANT: DW_AT_SUN_count_guarantee               HEX: 2204
+CONSTANT: DW_AT_SUN_command_line                  HEX: 2205
+CONSTANT: DW_AT_SUN_vbase                         HEX: 2206
+CONSTANT: DW_AT_SUN_compile_options               HEX: 2207
+CONSTANT: DW_AT_SUN_language                      HEX: 2208
+CONSTANT: DW_AT_SUN_browser_file                  HEX: 2209
+CONSTANT: DW_AT_SUN_vtable_abi                    HEX: 2210
+CONSTANT: DW_AT_SUN_func_offsets                  HEX: 2211
+CONSTANT: DW_AT_SUN_cf_kind                       HEX: 2212
+CONSTANT: DW_AT_SUN_vtable_index                  HEX: 2213
+CONSTANT: DW_AT_SUN_omp_tpriv_addr                HEX: 2214
+CONSTANT: DW_AT_SUN_omp_child_func                HEX: 2215
+CONSTANT: DW_AT_SUN_func_offset                   HEX: 2216
+CONSTANT: DW_AT_SUN_memop_type_ref                HEX: 2217
+CONSTANT: DW_AT_SUN_profile_id                    HEX: 2218
+CONSTANT: DW_AT_SUN_memop_signature               HEX: 2219
+CONSTANT: DW_AT_SUN_obj_dir                       HEX: 2220
+CONSTANT: DW_AT_SUN_obj_file                      HEX: 2221
+CONSTANT: DW_AT_SUN_original_name                 HEX: 2222
+CONSTANT: DW_AT_SUN_hwcprof_signature             HEX: 2223
+CONSTANT: DW_AT_SUN_amd64_parmdump                HEX: 2224
+CONSTANT: DW_AT_SUN_part_link_name                HEX: 2225
+CONSTANT: DW_AT_SUN_link_name                     HEX: 2226
+CONSTANT: DW_AT_SUN_pass_with_const               HEX: 2227
+CONSTANT: DW_AT_SUN_return_with_const             HEX: 2228
+CONSTANT: DW_AT_SUN_import_by_name                HEX: 2229
+CONSTANT: DW_AT_SUN_f90_pointer                   HEX: 222a
+CONSTANT: DW_AT_SUN_pass_by_ref                   HEX: 222b
+CONSTANT: DW_AT_SUN_f90_allocatable               HEX: 222c
+CONSTANT: DW_AT_SUN_f90_assumed_shape_array       HEX: 222d
+CONSTANT: DW_AT_SUN_c_vla                         HEX: 222e
+CONSTANT: DW_AT_SUN_return_value_ptr              HEX: 2230
+CONSTANT: DW_AT_SUN_dtor_start                    HEX: 2231
+CONSTANT: DW_AT_SUN_dtor_length                   HEX: 2232
+CONSTANT: DW_AT_SUN_dtor_state_initial            HEX: 2233
+CONSTANT: DW_AT_SUN_dtor_state_final              HEX: 2234
+CONSTANT: DW_AT_SUN_dtor_state_deltas             HEX: 2235
+CONSTANT: DW_AT_SUN_import_by_lname               HEX: 2236
+CONSTANT: DW_AT_SUN_f90_use_only                  HEX: 2237
+CONSTANT: DW_AT_SUN_namelist_spec                 HEX: 2238
+CONSTANT: DW_AT_SUN_is_omp_child_func             HEX: 2239
+CONSTANT: DW_AT_SUN_fortran_main_alias            HEX: 223a
+CONSTANT: DW_AT_SUN_fortran_based                 HEX: 223b
+
+CONSTANT: DW_AT_upc_threads_scaled                HEX: 3210
+
+CONSTANT: DW_AT_PGI_lbase                         HEX: 3a00
+CONSTANT: DW_AT_PGI_soffset                       HEX: 3a01 
+CONSTANT: DW_AT_PGI_lstride                       HEX: 3a02 
+
+CONSTANT: DW_AT_APPLE_closure                     HEX: 3fe4
+CONSTANT: DW_AT_APPLE_major_runtime_vers          HEX: 3fe5
+CONSTANT: DW_AT_APPLE_runtime_class               HEX: 3fe6
+
+CONSTANT: DW_AT_hi_user                           HEX: 3fff
+
+CONSTANT: DW_OP_addr                      HEX: 03
+CONSTANT: DW_OP_deref                     HEX: 06
+CONSTANT: DW_OP_const1u                   HEX: 08
+CONSTANT: DW_OP_const1s                   HEX: 09
+CONSTANT: DW_OP_const2u                   HEX: 0a
+CONSTANT: DW_OP_const2s                   HEX: 0b
+CONSTANT: DW_OP_const4u                   HEX: 0c
+CONSTANT: DW_OP_const4s                   HEX: 0d
+CONSTANT: DW_OP_const8u                   HEX: 0e
+CONSTANT: DW_OP_const8s                   HEX: 0f
+CONSTANT: DW_OP_constu                    HEX: 10
+CONSTANT: DW_OP_consts                    HEX: 11
+CONSTANT: DW_OP_dup                       HEX: 12
+CONSTANT: DW_OP_drop                      HEX: 13
+CONSTANT: DW_OP_over                      HEX: 14
+CONSTANT: DW_OP_pick                      HEX: 15
+CONSTANT: DW_OP_swap                      HEX: 16
+CONSTANT: DW_OP_rot                       HEX: 17
+CONSTANT: DW_OP_xderef                    HEX: 18
+CONSTANT: DW_OP_abs                       HEX: 19
+CONSTANT: DW_OP_and                       HEX: 1a
+CONSTANT: DW_OP_div                       HEX: 1b
+CONSTANT: DW_OP_minus                     HEX: 1c
+CONSTANT: DW_OP_mod                       HEX: 1d
+CONSTANT: DW_OP_mul                       HEX: 1e
+CONSTANT: DW_OP_neg                       HEX: 1f
+CONSTANT: DW_OP_not                       HEX: 20
+CONSTANT: DW_OP_or                        HEX: 21
+CONSTANT: DW_OP_plus                      HEX: 22
+CONSTANT: DW_OP_plus_uconst               HEX: 23
+CONSTANT: DW_OP_shl                       HEX: 24
+CONSTANT: DW_OP_shr                       HEX: 25
+CONSTANT: DW_OP_shra                      HEX: 26
+CONSTANT: DW_OP_xor                       HEX: 27
+CONSTANT: DW_OP_bra                       HEX: 28
+CONSTANT: DW_OP_eq                        HEX: 29
+CONSTANT: DW_OP_ge                        HEX: 2a
+CONSTANT: DW_OP_gt                        HEX: 2b
+CONSTANT: DW_OP_le                        HEX: 2c
+CONSTANT: DW_OP_lt                        HEX: 2d
+CONSTANT: DW_OP_ne                        HEX: 2e
+CONSTANT: DW_OP_skip                      HEX: 2f
+CONSTANT: DW_OP_lit0                      HEX: 30
+CONSTANT: DW_OP_lit1                      HEX: 31
+CONSTANT: DW_OP_lit2                      HEX: 32
+CONSTANT: DW_OP_lit3                      HEX: 33
+CONSTANT: DW_OP_lit4                      HEX: 34
+CONSTANT: DW_OP_lit5                      HEX: 35
+CONSTANT: DW_OP_lit6                      HEX: 36
+CONSTANT: DW_OP_lit7                      HEX: 37
+CONSTANT: DW_OP_lit8                      HEX: 38
+CONSTANT: DW_OP_lit9                      HEX: 39
+CONSTANT: DW_OP_lit10                     HEX: 3a
+CONSTANT: DW_OP_lit11                     HEX: 3b
+CONSTANT: DW_OP_lit12                     HEX: 3c
+CONSTANT: DW_OP_lit13                     HEX: 3d
+CONSTANT: DW_OP_lit14                     HEX: 3e
+CONSTANT: DW_OP_lit15                     HEX: 3f
+CONSTANT: DW_OP_lit16                     HEX: 40
+CONSTANT: DW_OP_lit17                     HEX: 41
+CONSTANT: DW_OP_lit18                     HEX: 42
+CONSTANT: DW_OP_lit19                     HEX: 43
+CONSTANT: DW_OP_lit20                     HEX: 44
+CONSTANT: DW_OP_lit21                     HEX: 45
+CONSTANT: DW_OP_lit22                     HEX: 46
+CONSTANT: DW_OP_lit23                     HEX: 47
+CONSTANT: DW_OP_lit24                     HEX: 48
+CONSTANT: DW_OP_lit25                     HEX: 49
+CONSTANT: DW_OP_lit26                     HEX: 4a
+CONSTANT: DW_OP_lit27                     HEX: 4b
+CONSTANT: DW_OP_lit28                     HEX: 4c
+CONSTANT: DW_OP_lit29                     HEX: 4d
+CONSTANT: DW_OP_lit30                     HEX: 4e
+CONSTANT: DW_OP_lit31                     HEX: 4f
+CONSTANT: DW_OP_reg0                      HEX: 50
+CONSTANT: DW_OP_reg1                      HEX: 51
+CONSTANT: DW_OP_reg2                      HEX: 52
+CONSTANT: DW_OP_reg3                      HEX: 53
+CONSTANT: DW_OP_reg4                      HEX: 54
+CONSTANT: DW_OP_reg5                      HEX: 55
+CONSTANT: DW_OP_reg6                      HEX: 56
+CONSTANT: DW_OP_reg7                      HEX: 57
+CONSTANT: DW_OP_reg8                      HEX: 58
+CONSTANT: DW_OP_reg9                      HEX: 59
+CONSTANT: DW_OP_reg10                     HEX: 5a
+CONSTANT: DW_OP_reg11                     HEX: 5b
+CONSTANT: DW_OP_reg12                     HEX: 5c
+CONSTANT: DW_OP_reg13                     HEX: 5d
+CONSTANT: DW_OP_reg14                     HEX: 5e
+CONSTANT: DW_OP_reg15                     HEX: 5f
+CONSTANT: DW_OP_reg16                     HEX: 60
+CONSTANT: DW_OP_reg17                     HEX: 61
+CONSTANT: DW_OP_reg18                     HEX: 62
+CONSTANT: DW_OP_reg19                     HEX: 63
+CONSTANT: DW_OP_reg20                     HEX: 64
+CONSTANT: DW_OP_reg21                     HEX: 65
+CONSTANT: DW_OP_reg22                     HEX: 66
+CONSTANT: DW_OP_reg23                     HEX: 67
+CONSTANT: DW_OP_reg24                     HEX: 68
+CONSTANT: DW_OP_reg25                     HEX: 69
+CONSTANT: DW_OP_reg26                     HEX: 6a
+CONSTANT: DW_OP_reg27                     HEX: 6b
+CONSTANT: DW_OP_reg28                     HEX: 6c
+CONSTANT: DW_OP_reg29                     HEX: 6d
+CONSTANT: DW_OP_reg30                     HEX: 6e
+CONSTANT: DW_OP_reg31                     HEX: 6f
+CONSTANT: DW_OP_breg0                     HEX: 70
+CONSTANT: DW_OP_breg1                     HEX: 71
+CONSTANT: DW_OP_breg2                     HEX: 72
+CONSTANT: DW_OP_breg3                     HEX: 73
+CONSTANT: DW_OP_breg4                     HEX: 74
+CONSTANT: DW_OP_breg5                     HEX: 75
+CONSTANT: DW_OP_breg6                     HEX: 76
+CONSTANT: DW_OP_breg7                     HEX: 77
+CONSTANT: DW_OP_breg8                     HEX: 78
+CONSTANT: DW_OP_breg9                     HEX: 79
+CONSTANT: DW_OP_breg10                    HEX: 7a
+CONSTANT: DW_OP_breg11                    HEX: 7b
+CONSTANT: DW_OP_breg12                    HEX: 7c
+CONSTANT: DW_OP_breg13                    HEX: 7d
+CONSTANT: DW_OP_breg14                    HEX: 7e
+CONSTANT: DW_OP_breg15                    HEX: 7f
+CONSTANT: DW_OP_breg16                    HEX: 80
+CONSTANT: DW_OP_breg17                    HEX: 81
+CONSTANT: DW_OP_breg18                    HEX: 82
+CONSTANT: DW_OP_breg19                    HEX: 83
+CONSTANT: DW_OP_breg20                    HEX: 84
+CONSTANT: DW_OP_breg21                    HEX: 85
+CONSTANT: DW_OP_breg22                    HEX: 86
+CONSTANT: DW_OP_breg23                    HEX: 87
+CONSTANT: DW_OP_breg24                    HEX: 88
+CONSTANT: DW_OP_breg25                    HEX: 89
+CONSTANT: DW_OP_breg26                    HEX: 8a
+CONSTANT: DW_OP_breg27                    HEX: 8b
+CONSTANT: DW_OP_breg28                    HEX: 8c
+CONSTANT: DW_OP_breg29                    HEX: 8d
+CONSTANT: DW_OP_breg30                    HEX: 8e
+CONSTANT: DW_OP_breg31                    HEX: 8f
+CONSTANT: DW_OP_regx                      HEX: 90
+CONSTANT: DW_OP_fbreg                     HEX: 91
+CONSTANT: DW_OP_bregx                     HEX: 92
+CONSTANT: DW_OP_piece                     HEX: 93
+CONSTANT: DW_OP_deref_size                HEX: 94
+CONSTANT: DW_OP_xderef_size               HEX: 95
+CONSTANT: DW_OP_nop                       HEX: 96
+CONSTANT: DW_OP_push_object_address       HEX: 97
+CONSTANT: DW_OP_call2                     HEX: 98
+CONSTANT: DW_OP_call4                     HEX: 99
+CONSTANT: DW_OP_call_ref                  HEX: 9a
+CONSTANT: DW_OP_form_tls_address          HEX: 9b
+CONSTANT: DW_OP_call_frame_cfa            HEX: 9c
+CONSTANT: DW_OP_bit_piece                 HEX: 9d
+CONSTANT: DW_OP_implicit_value            HEX: 9e
+CONSTANT: DW_OP_stack_value               HEX: 9f
+
+
+CONSTANT: DW_OP_lo_user                   HEX: e0
+CONSTANT: DW_OP_GNU_push_tls_address      HEX: e0
+CONSTANT: DW_OP_HP_unknown                HEX: e0
+CONSTANT: DW_OP_HP_is_value               HEX: e1
+CONSTANT: DW_OP_HP_fltconst4              HEX: e2
+CONSTANT: DW_OP_HP_fltconst8              HEX: e3
+CONSTANT: DW_OP_HP_mod_range              HEX: e4
+CONSTANT: DW_OP_HP_unmod_range            HEX: e5
+CONSTANT: DW_OP_HP_tls                    HEX: e6
+CONSTANT: DW_OP_INTEL_bit_piece           HEX: e8
+CONSTANT: DW_OP_APPLE_uninit              HEX: f0
+CONSTANT: DW_OP_hi_user                   HEX: ff
+
+CONSTANT: DW_ATE_address                  HEX: 1
+CONSTANT: DW_ATE_boolean                  HEX: 2
+CONSTANT: DW_ATE_complex_float            HEX: 3
+CONSTANT: DW_ATE_float                    HEX: 4
+CONSTANT: DW_ATE_signed                   HEX: 5
+CONSTANT: DW_ATE_signed_char              HEX: 6
+CONSTANT: DW_ATE_unsigned                 HEX: 7
+CONSTANT: DW_ATE_unsigned_char            HEX: 8
+CONSTANT: DW_ATE_imaginary_float          HEX: 9
+CONSTANT: DW_ATE_packed_decimal           HEX: a
+CONSTANT: DW_ATE_numeric_string           HEX: b
+CONSTANT: DW_ATE_edited                   HEX: c
+CONSTANT: DW_ATE_signed_fixed             HEX: d
+CONSTANT: DW_ATE_unsigned_fixed           HEX: e
+CONSTANT: DW_ATE_decimal_float            HEX: f
+
+CONSTANT: DW_ATE_lo_user                HEX: 80
+CONSTANT: DW_ATE_ALTIUM_fract           HEX: 80
+CONSTANT: DW_ATE_ALTIUM_accum           HEX: 81
+CONSTANT: DW_ATE_HP_float80             HEX: 80
+CONSTANT: DW_ATE_HP_complex_float80     HEX: 81
+CONSTANT: DW_ATE_HP_float128            HEX: 82
+CONSTANT: DW_ATE_HP_complex_float128    HEX: 83
+CONSTANT: DW_ATE_HP_floathpintel        HEX: 84
+CONSTANT: DW_ATE_HP_imaginary_float80   HEX: 85
+CONSTANT: DW_ATE_HP_imaginary_float128  HEX: 86
+CONSTANT: DW_ATE_SUN_interval_float     HEX: 91
+CONSTANT: DW_ATE_SUN_imaginary_float    HEX: 92
+CONSTANT: DW_ATE_hi_user                HEX: ff
+
+CONSTANT: DW_DS_unsigned                  HEX: 01
+CONSTANT: DW_DS_leading_overpunch         HEX: 02
+CONSTANT: DW_DS_trailing_overpunch        HEX: 03
+CONSTANT: DW_DS_leading_separate          HEX: 04
+CONSTANT: DW_DS_trailing_separate         HEX: 05
+
+CONSTANT: DW_END_default                  HEX: 00
+CONSTANT: DW_END_big                      HEX: 01
+CONSTANT: DW_END_little                   HEX: 02
+CONSTANT: DW_END_lo_user                  HEX: 40
+CONSTANT: DW_END_hi_user                  HEX: ff
+
+CONSTANT: DW_ATCF_lo_user                 HEX: 40
+CONSTANT: DW_ATCF_SUN_mop_bitfield        HEX: 41
+CONSTANT: DW_ATCF_SUN_mop_spill           HEX: 42
+CONSTANT: DW_ATCF_SUN_mop_scopy           HEX: 43
+CONSTANT: DW_ATCF_SUN_func_start          HEX: 44
+CONSTANT: DW_ATCF_SUN_end_ctors           HEX: 45
+CONSTANT: DW_ATCF_SUN_branch_target       HEX: 46
+CONSTANT: DW_ATCF_SUN_mop_stack_probe     HEX: 47
+CONSTANT: DW_ATCF_SUN_func_epilog         HEX: 48
+CONSTANT: DW_ATCF_hi_user                 HEX: ff
+
+CONSTANT: DW_ACCESS_public                HEX: 01
+CONSTANT: DW_ACCESS_protected             HEX: 02
+CONSTANT: DW_ACCESS_private               HEX: 03
+
+CONSTANT: DW_VIS_local                    HEX: 01
+CONSTANT: DW_VIS_exported                 HEX: 02
+CONSTANT: DW_VIS_qualified                HEX: 03
+
+CONSTANT: DW_VIRTUALITY_none              HEX: 00
+CONSTANT: DW_VIRTUALITY_virtual           HEX: 01
+CONSTANT: DW_VIRTUALITY_pure_virtual      HEX: 02
+
+CONSTANT: DW_LANG_C89                     HEX: 0001
+CONSTANT: DW_LANG_C                       HEX: 0002
+CONSTANT: DW_LANG_Ada83                   HEX: 0003
+CONSTANT: DW_LANG_C_plus_plus             HEX: 0004
+CONSTANT: DW_LANG_Cobol74                 HEX: 0005
+CONSTANT: DW_LANG_Cobol85                 HEX: 0006
+CONSTANT: DW_LANG_Fortran77               HEX: 0007
+CONSTANT: DW_LANG_Fortran90               HEX: 0008
+CONSTANT: DW_LANG_Pascal83                HEX: 0009
+CONSTANT: DW_LANG_Modula2                 HEX: 000a
+CONSTANT: DW_LANG_Java                    HEX: 000b
+CONSTANT: DW_LANG_C99                     HEX: 000c
+CONSTANT: DW_LANG_Ada95                   HEX: 000d
+CONSTANT: DW_LANG_Fortran95               HEX: 000e
+CONSTANT: DW_LANG_PLI                     HEX: 000f
+CONSTANT: DW_LANG_ObjC                    HEX: 0010
+CONSTANT: DW_LANG_ObjC_plus_plus          HEX: 0011
+CONSTANT: DW_LANG_UPC                     HEX: 0012
+CONSTANT: DW_LANG_D                       HEX: 0013
+CONSTANT: DW_LANG_Python                  HEX: 0014
+CONSTANT: DW_LANG_lo_user                 HEX: 8000
+CONSTANT: DW_LANG_Mips_Assembler          HEX: 8001
+CONSTANT: DW_LANG_Upc                     HEX: 8765
+CONSTANT: DW_LANG_ALTIUM_Assembler        HEX: 9101 
+CONSTANT: DW_LANG_SUN_Assembler           HEX: 9001
+CONSTANT: DW_LANG_hi_user                 HEX: ffff
+
+CONSTANT: DW_ID_case_sensitive            HEX: 00
+CONSTANT: DW_ID_up_case                   HEX: 01
+CONSTANT: DW_ID_down_case                 HEX: 02
+CONSTANT: DW_ID_case_insensitive          HEX: 03
+
+CONSTANT: DW_CC_normal                    HEX: 01
+CONSTANT: DW_CC_program                   HEX: 02
+CONSTANT: DW_CC_nocall                    HEX: 03
+
+CONSTANT: DW_CC_lo_user                   HEX: 40
+CONSTANT: DW_CC_ALTIUM_interrupt          HEX: 65 
+CONSTANT: DW_CC_ALTIUM_near_system_stack  HEX: 66 
+CONSTANT: DW_CC_ALTIUM_near_user_stack    HEX: 67 
+CONSTANT: DW_CC_ALTIUM_huge_user_stack    HEX: 68 
+CONSTANT: DW_CC_hi_user                   HEX: ff
+
+CONSTANT: DW_INL_not_inlined              HEX: 00
+CONSTANT: DW_INL_inlined                  HEX: 01
+CONSTANT: DW_INL_declared_not_inlined     HEX: 02
+CONSTANT: DW_INL_declared_inlined         HEX: 03
+
+CONSTANT: DW_ORD_row_major                HEX: 00
+CONSTANT: DW_ORD_col_major                HEX: 01
+
+CONSTANT: DW_DSC_label                    HEX: 00
+CONSTANT: DW_DSC_range                    HEX: 01
+
+CONSTANT: DW_LNS_copy                     HEX: 01
+CONSTANT: DW_LNS_advance_pc               HEX: 02
+CONSTANT: DW_LNS_advance_line             HEX: 03
+CONSTANT: DW_LNS_set_file                 HEX: 04
+CONSTANT: DW_LNS_set_column               HEX: 05
+CONSTANT: DW_LNS_negate_stmt              HEX: 06
+CONSTANT: DW_LNS_set_basic_block          HEX: 07
+CONSTANT: DW_LNS_const_add_pc             HEX: 08
+CONSTANT: DW_LNS_fixed_advance_pc         HEX: 09
+CONSTANT: DW_LNS_set_prologue_end         HEX: 0a
+CONSTANT: DW_LNS_set_epilogue_begin       HEX: 0b
+CONSTANT: DW_LNS_set_isa                  HEX: 0c
+
+CONSTANT: DW_LNE_end_sequence             HEX: 01
+CONSTANT: DW_LNE_set_address              HEX: 02
+CONSTANT: DW_LNE_define_file              HEX: 03
+CONSTANT: DW_LNE_set_discriminator        HEX: 04 
+
+CONSTANT: DW_LNE_HP_negate_is_UV_update       HEX: 11
+CONSTANT: DW_LNE_HP_push_context              HEX: 12
+CONSTANT: DW_LNE_HP_pop_context               HEX: 13
+CONSTANT: DW_LNE_HP_set_file_line_column      HEX: 14
+CONSTANT: DW_LNE_HP_set_routine_name          HEX: 15
+CONSTANT: DW_LNE_HP_set_sequence              HEX: 16
+CONSTANT: DW_LNE_HP_negate_post_semantics     HEX: 17
+CONSTANT: DW_LNE_HP_negate_function_exit      HEX: 18
+CONSTANT: DW_LNE_HP_negate_front_end_logical  HEX: 19
+CONSTANT: DW_LNE_HP_define_proc               HEX: 20
+
+CONSTANT: DW_LNE_lo_user                  HEX: 80
+CONSTANT: DW_LNE_hi_user                  HEX: ff
+
+CONSTANT: DW_MACINFO_define               HEX: 01
+CONSTANT: DW_MACINFO_undef                HEX: 02
+CONSTANT: DW_MACINFO_start_file           HEX: 03
+CONSTANT: DW_MACINFO_end_file             HEX: 04
+CONSTANT: DW_MACINFO_vendor_ext           HEX: ff
+
+CONSTANT: DW_CFA_advance_loc        HEX: 40
+CONSTANT: DW_CFA_offset             HEX: 80
+CONSTANT: DW_CFA_restore            HEX: c0
+CONSTANT: DW_CFA_extended           HEX: 00
+
+CONSTANT: DW_CFA_nop              HEX: 00
+CONSTANT: DW_CFA_set_loc          HEX: 01
+CONSTANT: DW_CFA_advance_loc1     HEX: 02
+CONSTANT: DW_CFA_advance_loc2     HEX: 03
+CONSTANT: DW_CFA_advance_loc4     HEX: 04
+CONSTANT: DW_CFA_offset_extended  HEX: 05
+CONSTANT: DW_CFA_restore_extended HEX: 06
+CONSTANT: DW_CFA_undefined        HEX: 07
+CONSTANT: DW_CFA_same_value       HEX: 08
+CONSTANT: DW_CFA_register         HEX: 09
+CONSTANT: DW_CFA_remember_state   HEX: 0a
+CONSTANT: DW_CFA_restore_state    HEX: 0b
+CONSTANT: DW_CFA_def_cfa          HEX: 0c
+CONSTANT: DW_CFA_def_cfa_register HEX: 0d
+CONSTANT: DW_CFA_def_cfa_offset   HEX: 0e
+CONSTANT: DW_CFA_def_cfa_expression HEX: 0f
+CONSTANT: DW_CFA_expression       HEX: 10
+CONSTANT: DW_CFA_offset_extended_sf HEX: 11
+CONSTANT: DW_CFA_def_cfa_sf       HEX: 12
+CONSTANT: DW_CFA_def_cfa_offset_sf HEX: 13
+CONSTANT: DW_CFA_val_offset        HEX: 14
+CONSTANT: DW_CFA_val_offset_sf     HEX: 15
+CONSTANT: DW_CFA_val_expression    HEX: 16
+
+CONSTANT: DW_CFA_lo_user           HEX: 1c
+CONSTANT: DW_CFA_MIPS_advance_loc8 HEX: 1d
+CONSTANT: DW_CFA_GNU_window_save   HEX: 2d
+CONSTANT: DW_CFA_GNU_args_size     HEX: 2e
+CONSTANT: DW_CFA_GNU_negative_offset_extended  HEX: 2f
+CONSTANT: DW_CFA_high_user         HEX: 3f
+
+CONSTANT: DW_EH_PE_absptr   HEX: 00
+CONSTANT: DW_EH_PE_uleb128  HEX: 01
+CONSTANT: DW_EH_PE_udata2   HEX: 02
+CONSTANT: DW_EH_PE_udata4   HEX: 03
+CONSTANT: DW_EH_PE_udata8   HEX: 04
+CONSTANT: DW_EH_PE_sleb128  HEX: 09
+CONSTANT: DW_EH_PE_sdata2   HEX: 0A
+CONSTANT: DW_EH_PE_sdata4   HEX: 0B
+CONSTANT: DW_EH_PE_sdata8   HEX: 0C
+CONSTANT: DW_EH_PE_pcrel    HEX: 10
+CONSTANT: DW_EH_PE_textrel  HEX: 20
+CONSTANT: DW_EH_PE_datarel  HEX: 30
+CONSTANT: DW_EH_PE_funcrel  HEX: 40
+CONSTANT: DW_EH_PE_aligned  HEX: 50
+CONSTANT: DW_EH_PE_omit     HEX: ff
+
+CONSTANT: DW_FRAME_CFA_COL 0  
+
+CONSTANT: DW_FRAME_REG1   1
+CONSTANT: DW_FRAME_REG2   2
+CONSTANT: DW_FRAME_REG3   3
+CONSTANT: DW_FRAME_REG4   4
+CONSTANT: DW_FRAME_REG5   5
+CONSTANT: DW_FRAME_REG6   6
+CONSTANT: DW_FRAME_REG7   7
+CONSTANT: DW_FRAME_REG8   8
+CONSTANT: DW_FRAME_REG9   9
+CONSTANT: DW_FRAME_REG10  10
+CONSTANT: DW_FRAME_REG11  11
+CONSTANT: DW_FRAME_REG12  12
+CONSTANT: DW_FRAME_REG13  13
+CONSTANT: DW_FRAME_REG14  14
+CONSTANT: DW_FRAME_REG15  15
+CONSTANT: DW_FRAME_REG16  16
+CONSTANT: DW_FRAME_REG17  17
+CONSTANT: DW_FRAME_REG18  18
+CONSTANT: DW_FRAME_REG19  19
+CONSTANT: DW_FRAME_REG20  20
+CONSTANT: DW_FRAME_REG21  21
+CONSTANT: DW_FRAME_REG22  22
+CONSTANT: DW_FRAME_REG23  23
+CONSTANT: DW_FRAME_REG24  24
+CONSTANT: DW_FRAME_REG25  25
+CONSTANT: DW_FRAME_REG26  26
+CONSTANT: DW_FRAME_REG27  27
+CONSTANT: DW_FRAME_REG28  28
+CONSTANT: DW_FRAME_REG29  29
+CONSTANT: DW_FRAME_REG30  30
+CONSTANT: DW_FRAME_REG31  31
+CONSTANT: DW_FRAME_FREG0  32
+CONSTANT: DW_FRAME_FREG1  33
+CONSTANT: DW_FRAME_FREG2  34
+CONSTANT: DW_FRAME_FREG3  35
+CONSTANT: DW_FRAME_FREG4  36
+CONSTANT: DW_FRAME_FREG5  37
+CONSTANT: DW_FRAME_FREG6  38
+CONSTANT: DW_FRAME_FREG7  39
+CONSTANT: DW_FRAME_FREG8  40
+CONSTANT: DW_FRAME_FREG9  41
+CONSTANT: DW_FRAME_FREG10 42
+CONSTANT: DW_FRAME_FREG11 43
+CONSTANT: DW_FRAME_FREG12 44
+CONSTANT: DW_FRAME_FREG13 45
+CONSTANT: DW_FRAME_FREG14 46
+CONSTANT: DW_FRAME_FREG15 47
+CONSTANT: DW_FRAME_FREG16 48
+CONSTANT: DW_FRAME_FREG17 49
+CONSTANT: DW_FRAME_FREG18 50
+CONSTANT: DW_FRAME_FREG19 51
+CONSTANT: DW_FRAME_FREG20 52
+CONSTANT: DW_FRAME_FREG21 53
+CONSTANT: DW_FRAME_FREG22 54
+CONSTANT: DW_FRAME_FREG23 55
+CONSTANT: DW_FRAME_FREG24 56
+CONSTANT: DW_FRAME_FREG25 57
+CONSTANT: DW_FRAME_FREG26 58
+CONSTANT: DW_FRAME_FREG27 59
+CONSTANT: DW_FRAME_FREG28 60
+CONSTANT: DW_FRAME_FREG29 61
+CONSTANT: DW_FRAME_FREG30 62
+CONSTANT: DW_FRAME_FREG31 63
+
+CONSTANT: DW_CHILDREN_no        HEX: 00
+CONSTANT: DW_CHILDREN_yes       HEX: 01
+CONSTANT: DW_ADDR_none          HEX: 00

From dd4e5052538b6d859dead3857ad371d51f9841ae Mon Sep 17 00:00:00 2001
From: Erik Charlebois <erikcharlebois@gmail.com>
Date: Sat, 17 Apr 2010 16:29:23 -0700
Subject: [PATCH 028/158] Dwarf authors file

---
 extra/dwarf/authors.txt | 1 +
 1 file changed, 1 insertion(+)
 create mode 100644 extra/dwarf/authors.txt

diff --git a/extra/dwarf/authors.txt b/extra/dwarf/authors.txt
new file mode 100644
index 0000000000..6f03a12101
--- /dev/null
+++ b/extra/dwarf/authors.txt
@@ -0,0 +1 @@
+Erik Charlebois

From f572b56f8eed62d5bf62a282d0ff6d5abc283978 Mon Sep 17 00:00:00 2001
From: Erik Charlebois <erikcharlebois@gmail.com>
Date: Sat, 17 Apr 2010 17:37:09 -0700
Subject: [PATCH 029/158] Lua FFI bindings

---
 extra/lua/authors.txt |   1 +
 extra/lua/lua.factor  | 313 ++++++++++++++++++++++++++++++++++++++++++
 extra/lua/summary.txt |   1 +
 3 files changed, 315 insertions(+)
 create mode 100644 extra/lua/authors.txt
 create mode 100644 extra/lua/lua.factor
 create mode 100644 extra/lua/summary.txt

diff --git a/extra/lua/authors.txt b/extra/lua/authors.txt
new file mode 100644
index 0000000000..6f03a12101
--- /dev/null
+++ b/extra/lua/authors.txt
@@ -0,0 +1 @@
+Erik Charlebois
diff --git a/extra/lua/lua.factor b/extra/lua/lua.factor
new file mode 100644
index 0000000000..730979e68e
--- /dev/null
+++ b/extra/lua/lua.factor
@@ -0,0 +1,313 @@
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.accessors alien.c-types alien.libraries
+alien.syntax classes.struct combinators io.encodings.ascii kernel
+literals locals math system ;
+IN: lua
+
+<< "liblua5.1" {
+        { [ os windows? ] [ "lua5.1.dll" ] }
+        { [ os macosx? ] [ "liblua5.1.dylib"  ] }
+        { [ os unix? ] [ "liblua5.1.so" ] }
+    } cond cdecl add-library >>
+LIBRARY: liblua5.1
+    
+! luaconf.h
+TYPEDEF: double LUA_NUMBER
+TYPEDEF: ptrdiff_t LUA_INTEGER
+
+CONSTANT: LUA_IDSIZE 60
+
+! This is normally the BUFSIZ value of the given platform.
+CONSTANT: LUAL_BUFFERSIZE $[
+    {
+        { [ os windows? ] [ 512 ] }
+        { [ os macosx? ] [ 1024 ] }
+        { [ os unix? ] [ 8192 ] }
+    } cond ] 
+
+! lua.h
+CONSTANT: LUA_SIGNATURE B{ 27 76 117 97 }
+CONSTANT: LUA_MULTRET -1
+
+CONSTANT: LUA_REGISTRYINDEX -10000
+CONSTANT: LUA_ENVIRONINDEX  -10001
+CONSTANT: LUA_GLOBALSINDEX  -10002
+
+: lua_upvalueindex ( i -- i ) [ LUA_GLOBALSINDEX ] dip - ; inline
+
+CONSTANT: LUA_YIELD     1
+CONSTANT: LUA_ERRRUN    2
+CONSTANT: LUA_ERRSYNTAX 3
+CONSTANT: LUA_ERRMEM    4
+CONSTANT: LUA_ERRERR    5
+
+C-TYPE: lua_State
+
+CALLBACK: int lua_CFunction ( lua_State* L ) ;
+CALLBACK: char* lua_Reader ( lua_State* L, void* ud, size_t* sz ) ;
+CALLBACK: int lua_Writer ( lua_State* L, void* p, size_t sz, void* ud ) ;
+CALLBACK: void* lua_Alloc ( void* ud, void* ptr, size_t osize, size_t nsize ) ;
+
+CONSTANT: LUA_TNONE           -1
+CONSTANT: LUA_TNIL            0
+CONSTANT: LUA_TBOOLEAN        1
+CONSTANT: LUA_TLIGHTUSERDATA  2
+CONSTANT: LUA_TNUMBER         3
+CONSTANT: LUA_TSTRING         4
+CONSTANT: LUA_TTABLE          5
+CONSTANT: LUA_TFUNCTION       6
+CONSTANT: LUA_TUSERDATA       7
+CONSTANT: LUA_TTHREAD         8
+
+CONSTANT: LUA_MINSTACK 20
+
+TYPEDEF: LUA_NUMBER lua_Number
+TYPEDEF: LUA_INTEGER lua_Integer
+
+FUNCTION: lua_State* lua_newstate ( lua_Alloc f, void* ud ) ;
+FUNCTION: void lua_close ( lua_State* L ) ;
+FUNCTION: lua_State* lua_newthread ( lua_State* L ) ;
+
+FUNCTION: lua_CFunction lua_atpanic ( lua_State* L, lua_CFunction panicf ) ;
+
+FUNCTION: int lua_gettop ( lua_State* L ) ;
+FUNCTION: void lua_settop ( lua_State* L, int idx ) ;
+FUNCTION: void lua_pushvalue ( lua_State* L, int idx ) ;
+FUNCTION: void lua_remove ( lua_State* L, int idx ) ;
+FUNCTION: void lua_insert ( lua_State* L, int idx ) ;
+FUNCTION: void lua_replace ( lua_State* L, int idx ) ;
+FUNCTION: int lua_checkstack ( lua_State* L, int sz ) ;
+
+FUNCTION: void lua_xmove ( lua_State* from, lua_State* to, int n ) ;
+
+FUNCTION: int lua_isnumber ( lua_State* L, int idx ) ;
+FUNCTION: int lua_isstring ( lua_State* L, int idx ) ;
+FUNCTION: int lua_iscfunction ( lua_State* L, int idx ) ;
+FUNCTION: int lua_isuserdata ( lua_State* L, int idx ) ;
+FUNCTION: int lua_type ( lua_State* L, int idx ) ;
+FUNCTION: c-string[ascii] lua_typename ( lua_State* L, int tp ) ;
+
+FUNCTION: int lua_equal ( lua_State* L, int idx1, int idx2 ) ;
+FUNCTION: int lua_rawequal ( lua_State* L, int idx1, int idx2 ) ;
+FUNCTION: int lua_lessthan ( lua_State* L, int idx1, int idx2 ) ;
+
+FUNCTION: lua_Number lua_tonumber ( lua_State* L, int idx ) ;
+FUNCTION: lua_Integer lua_tointeger ( lua_State* L, int idx ) ;
+FUNCTION: int lua_toboolean ( lua_State* L, int idx ) ;
+FUNCTION: c-string[ascii] lua_tolstring ( lua_State* L, int idx, size_t* len ) ;
+FUNCTION: size_t lua_objlen ( lua_State* L, int idx ) ;
+FUNCTION: lua_CFunction lua_tocfunction ( lua_State* L, int idx ) ;
+FUNCTION: void* lua_touserdata ( lua_State* L, int idx ) ;
+FUNCTION: lua_State* lua_tothread ( lua_State* L, int idx ) ;
+FUNCTION: void* lua_topointer ( lua_State* L, int idx ) ;
+
+FUNCTION: void lua_pushnil ( lua_State* L ) ;
+FUNCTION: void lua_pushnumber ( lua_State* L, lua_Number n ) ;
+FUNCTION: void lua_pushinteger ( lua_State* L, lua_Integer n ) ;
+FUNCTION: void lua_pushlstring ( lua_State* L, char* s, size_t l ) ;
+FUNCTION: void lua_pushstring ( lua_State* L, c-string[ascii] ) ;
+! FUNCTION: c-string[ascii] lua_pushvfstring ( lua_State* L, c-string[ascii] fmt, va_list argp ) ;
+! FUNCTION: c-string[ascii] lua_pushfstring ( lua_State* L, c-string[ascii] fmt, ... ) ;
+FUNCTION: void lua_pushcclosure ( lua_State* L, lua_CFunction fn, int n ) ;
+FUNCTION: void lua_pushboolean ( lua_State* L, int b ) ;
+FUNCTION: void lua_pushlightuserdata ( lua_State* L, void* p ) ;
+FUNCTION: int lua_pushthread ( lua_State* L ) ;
+
+FUNCTION: void lua_gettable ( lua_State* L, int idx ) ;
+FUNCTION: void lua_getfield ( lua_State* L, int idx, c-string[ascii] k ) ;
+FUNCTION: void lua_rawget ( lua_State* L, int idx ) ;
+FUNCTION: void lua_rawgeti ( lua_State* L, int idx, int n ) ;
+FUNCTION: void lua_createtable ( lua_State* L, int narr, int nrec ) ;
+FUNCTION: void* lua_newuserdata ( lua_State* L, size_t sz ) ;
+FUNCTION: int lua_getmetatable ( lua_State* L, int objindex ) ;
+FUNCTION: void lua_getfenv ( lua_State* L, int idx ) ;
+
+FUNCTION: void lua_settable ( lua_State* L, int idx ) ;
+FUNCTION: void lua_setfield ( lua_State* L, int idx, c-string[ascii] k ) ;
+FUNCTION: void lua_rawset ( lua_State* L, int idx ) ;
+FUNCTION: void lua_rawseti ( lua_State* L, int idx, int n ) ;
+FUNCTION: int lua_setmetatable ( lua_State* L, int objindex ) ;
+FUNCTION: int lua_setfenv ( lua_State* L, int idx ) ;
+
+FUNCTION: void lua_call ( lua_State* L, int nargs, int nresults ) ;
+FUNCTION: int lua_pcall ( lua_State* L, int nargs, int nresults, int errfunc ) ;
+FUNCTION: int lua_cpcall ( lua_State* L, lua_CFunction func, void* ud ) ;
+FUNCTION: int lua_load ( lua_State* L, lua_Reader reader, void* dt, c-string[ascii] chunkname ) ;
+
+FUNCTION: int lua_dump ( lua_State* L, lua_Writer writer, void* data ) ;
+
+FUNCTION: int lua_yield ( lua_State* L, int nresults ) ;
+FUNCTION: int lua_resume ( lua_State* L, int narg ) ;
+FUNCTION: int lua_status ( lua_State* L ) ;
+
+CONSTANT: LUA_GCSTOP          0
+CONSTANT: LUA_GCRESTART       1
+CONSTANT: LUA_GCCOLLECT       2
+CONSTANT: LUA_GCCOUNT         3
+CONSTANT: LUA_GCCOUNTB        4
+CONSTANT: LUA_GCSTEP          5
+CONSTANT: LUA_GCSETPAUSE      6
+CONSTANT: LUA_GCSETSTEPMUL    7
+
+FUNCTION: int lua_gc ( lua_State* L, int what, int data ) ;
+
+FUNCTION: int lua_error ( lua_State* L ) ;
+FUNCTION: int lua_next ( lua_State* L, int idx ) ;
+FUNCTION: void lua_concat ( lua_State* L, int n ) ;
+FUNCTION: lua_Alloc lua_getallocf ( lua_State* L, void* *ud ) ;
+FUNCTION: void lua_setallocf ( lua_State* L, lua_Alloc f, void* ud ) ;
+
+TYPEDEF: lua_Reader lua_Chunkreader
+TYPEDEF: lua_Writer lua_Chunkwriter
+
+FUNCTION: void lua_setlevel ( lua_State* from, lua_State* to ) ;
+
+CONSTANT: LUA_HOOKCALL    0
+CONSTANT: LUA_HOOKRET     1
+CONSTANT: LUA_HOOKLINE    2
+CONSTANT: LUA_HOOKCOUNT   3
+CONSTANT: LUA_HOOKTAILRET 4
+
+: LUA_MASKCALL ( n -- n ) LUA_HOOKCALL shift ; inline
+: LUA_MASKRET ( n -- n ) LUA_HOOKRET shift ; inline
+: LUA_MASKLINE ( n -- n ) LUA_HOOKLINE shift ; inline
+: LUA_MASKCOUNT ( n -- n ) LUA_HOOKCOUNT shift ; inline
+
+C-TYPE: lua_Debug
+CALLBACK: void lua_Hook ( lua_State* L, lua_Debug* ar ) ;
+
+FUNCTION: int lua_getstack ( lua_State* L, int level, lua_Debug* ar ) ;
+FUNCTION: int lua_getinfo ( lua_State* L, c-string[ascii] what, lua_Debug* ar ) ;
+FUNCTION: c-string[ascii] lua_getlocal ( lua_State* L, lua_Debug* ar, int n ) ;
+FUNCTION: c-string[ascii] lua_setlocal ( lua_State* L, lua_Debug* ar, int n ) ;
+FUNCTION: c-string[ascii] lua_getupvalue ( lua_State* L, int funcindex, int n ) ;
+FUNCTION: c-string[ascii] lua_setupvalue ( lua_State* L, int funcindex, int n ) ;
+
+FUNCTION: int lua_sethook ( lua_State* L, lua_Hook func, int mask, int count ) ;
+FUNCTION: lua_Hook lua_gethook ( lua_State* L ) ;
+FUNCTION: int lua_gethookmask ( lua_State* L ) ;
+FUNCTION: int lua_gethookcount ( lua_State* L ) ;
+
+STRUCT: lua_Debug
+    { event           int              }
+    { name            char*            }
+    { namewhat        char*            }
+    { what            char*            }
+    { source          char*            }
+    { currentline     int              }
+    { nups            int              }
+    { linedefined     int              }
+    { lastlinedefined int              }
+    { short_src       char[LUA_IDSIZE] }
+    { i_ci            int              } ;
+
+! lauxlib.h
+
+: luaL_getn ( L i -- int ) lua_objlen ; inline
+: luaL_setn ( L i j -- ) 3drop ; inline
+ 
+CONSTANT: LUA_ERRFILE $[ $ LUA_ERRERR 1 + ]
+
+STRUCT: luaL_Reg
+    { name char*         }
+    { func lua_CFunction } ;
+
+FUNCTION: void luaI_openlib ( lua_State* L, c-string[ascii] libname, luaL_Reg* l, int nup ) ;
+FUNCTION: void luaL_register ( lua_State* L, c-string[ascii] libname, luaL_Reg* l ) ;
+FUNCTION: int luaL_getmetafield ( lua_State* L, int obj, c-string[ascii] e ) ;
+FUNCTION: int luaL_callmeta ( lua_State* L, int obj, c-string[ascii] e ) ;
+FUNCTION: int luaL_typerror ( lua_State* L, int narg, c-string[ascii] tname ) ;
+FUNCTION: int luaL_argerror ( lua_State* L, int numarg, c-string[ascii] extramsg ) ;
+FUNCTION: c-string[ascii] luaL_checklstring ( lua_State* L, int numArg, size_t* l ) ;
+FUNCTION: c-string[ascii] luaL_optlstring ( lua_State* L, int numArg, c-string[ascii] def, size_t* l ) ;
+FUNCTION: lua_Number luaL_checknumber ( lua_State* L, int numArg ) ;
+FUNCTION: lua_Number luaL_optnumber ( lua_State* L, int nArg, lua_Number def ) ;
+
+FUNCTION: lua_Integer luaL_checkinteger ( lua_State* L, int numArg ) ;
+FUNCTION: lua_Integer luaL_optinteger ( lua_State* L, int nArg, lua_Integer def ) ;
+
+FUNCTION: void luaL_checkstack ( lua_State* L, int sz, c-string[ascii] msg ) ;
+FUNCTION: void luaL_checktype ( lua_State* L, int narg, int t ) ;
+FUNCTION: void luaL_checkany ( lua_State* L, int narg ) ;
+
+FUNCTION: int luaL_newmetatable ( lua_State* L, c-string[ascii] tname ) ;
+FUNCTION: void* luaL_checkudata ( lua_State* L, int ud, c-string[ascii] tname ) ;
+
+FUNCTION: void luaL_where ( lua_State* L, int lvl ) ;
+! FUNCTION: int luaL_error ( lua_State* L, c-string[ascii] fmt,  ... ) ;
+FUNCTION: int luaL_checkoption ( lua_State* L, int narg, c-string[ascii] def, c-string[ascii] lst ) ;
+
+FUNCTION: int luaL_ref ( lua_State* L, int t ) ;
+FUNCTION: void luaL_unref ( lua_State* L, int t, int ref ) ;
+
+FUNCTION: int luaL_loadfile ( lua_State* L, c-string[ascii] filename ) ;
+FUNCTION: int luaL_loadbuffer ( lua_State* L, c-string[ascii] buff, size_t sz, c-string[ascii] name ) ;
+FUNCTION: int luaL_loadstring ( lua_State* L, c-string[ascii] s ) ;
+
+FUNCTION: lua_State* luaL_newstate ( ) ;
+FUNCTION: c-string[ascii] luaL_gsub ( lua_State* L, c-string[ascii] s, c-string[ascii] p, c-string[ascii] r ) ;
+FUNCTION: c-string[ascii] luaL_findtable ( lua_State* L, int idx, c-string[ascii] fname, int szhint ) ;
+
+: lua_pop ( L n -- ) neg 1 - lua_settop ; inline
+: lua_newtable ( L -- ) 0 0 lua_createtable ; inline
+: lua_pushcfunction ( L f -- ) 0 lua_pushcclosure ; inline
+: lua_setglobal ( L s -- ) [ LUA_GLOBALSINDEX ] dip lua_setfield ; inline
+: lua_register ( L n f -- ) pick swap lua_pushcfunction lua_setglobal ; inline
+: lua_strlen ( L i -- size_t ) lua_objlen ; inline
+: lua_isfunction ( L n -- ? ) lua_type LUA_TFUNCTION = ; inline
+: lua_istable ( L n -- ? ) lua_type LUA_TTABLE = ; inline
+: lua_islightuserdata ( L n -- ? ) lua_type LUA_TLIGHTUSERDATA = ; inline
+: lua_isnil ( L n -- ? ) lua_type LUA_TNIL = ; inline
+: lua_isboolean ( L n -- ? ) lua_type LUA_TBOOLEAN = ; inline
+: lua_isthread ( L n -- ? ) lua_type LUA_TTHREAD = ; inline
+: lua_isnone ( L n -- ? ) lua_type LUA_TNONE = ; inline
+: lua_isnoneornil ( L n -- ? ) lua_type 0 <= ; inline
+: lua_getglobal ( L s -- ) [ LUA_GLOBALSINDEX ] dip lua_getfield ; inline
+: lua_tostring ( L i -- string ) f lua_tolstring ; inline
+: lua_open ( -- lua_State* ) luaL_newstate ; inline
+: lua_getregistry ( L -- ) LUA_REGISTRYINDEX lua_pushvalue ; inline
+: lua_getgccount ( L -- int ) LUA_GCCOUNT 0 lua_gc ; inline
+
+: luaL_argcheck ( L cond numarg extramsg -- int ) rot 0 = [ luaL_argerror ] [ 3drop 1 ] if ; inline
+: luaL_checkstring ( L n -- string ) f luaL_checklstring ; inline
+: luaL_optstring ( L n d -- string ) f luaL_optlstring ; inline
+: luaL_checkint ( L n -- int ) luaL_checkinteger ; inline
+: luaL_optint ( L  n d -- int ) luaL_optinteger ; inline
+: luaL_checklong ( L n -- long ) luaL_checkinteger ; inline
+: luaL_optlong ( L n d -- long ) luaL_optinteger ; inline
+
+: luaL_typename ( L i -- string ) dupd lua_type lua_typename ; inline
+: luaL_dofile ( L fn -- int )
+    dupd luaL_loadfile 0 = [
+        0 LUA_MULTRET 0 lua_pcall
+    ] [ drop 1 ] if ; inline
+: luaL_dostring ( L s -- int )
+    dupd luaL_loadstring 0 = [
+        0 LUA_MULTRET 0 lua_pcall
+    ] [ drop 1 ] if ; inline
+
+: luaL_getmetatable ( L n -- ) [ LUA_REGISTRYINDEX ] dip lua_getfield ; inline
+
+STRUCT: luaL_Buffer
+    { p      char*                 }
+    { lvl    int                   }
+    { L      lua_State*            }
+    { buffer char[LUAL_BUFFERSIZE] } ;
+
+FUNCTION: void luaL_buffinit ( lua_State* L, luaL_Buffer* B ) ;
+FUNCTION: char* luaL_prepbuffer ( luaL_Buffer* B ) ;
+FUNCTION: void luaL_addlstring ( luaL_Buffer* B, char* s, size_t l ) ;
+FUNCTION: void luaL_addstring ( luaL_Buffer* B, char* s ) ;
+FUNCTION: void luaL_addvalue ( luaL_Buffer* B ) ;
+FUNCTION: void luaL_pushresult ( luaL_Buffer* B ) ;
+
+:: luaL_addchar ( B c -- )
+    B p>> alien-address
+    LUAL_BUFFERSIZE B buffer>> <displaced-alien> alien-address
+    >= [ B luaL_prepbuffer drop ] when
+    c B p>> 0 set-alien-signed-1
+    B [ 1 swap <displaced-alien> ] change-p drop ; inline
+
+: luaL_putchar ( B c -- ) luaL_addchar ; inline
+: luaL_addsize ( B n -- ) [ swap <displaced-alien> ] curry change-p drop ; inline
diff --git a/extra/lua/summary.txt b/extra/lua/summary.txt
new file mode 100644
index 0000000000..e4b960e9a9
--- /dev/null
+++ b/extra/lua/summary.txt
@@ -0,0 +1 @@
+FFI bindings to the Lua programming language.

From 4bc915d526f86fe6757315e99679e3a6cd17ae2b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 12 Apr 2010 21:02:55 -0700
Subject: [PATCH 030/158] C-ENUM: -> ENUM:

---
 basis/alien/data/data-docs.factor             |  2 +-
 basis/alien/syntax/syntax-docs.factor         |  6 +--
 basis/alien/syntax/syntax.factor              |  2 +-
 basis/cairo/ffi/ffi.factor                    | 36 ++++++++--------
 basis/cocoa/application/application.factor    |  2 +-
 basis/compiler/constants/constants.factor     |  4 +-
 basis/core-graphics/core-graphics.factor      |  2 +-
 basis/pango/fonts/fonts.factor                |  2 +-
 basis/unicode/breaks/breaks.factor            |  4 +-
 basis/vm/vm.factor                            |  2 +-
 basis/windows/advapi32/advapi32.factor        | 10 ++---
 basis/windows/ddk/hid/hid.factor              |  4 +-
 basis/windows/ddk/setupapi/setupapi.factor    |  2 +-
 basis/windows/ddk/winusb/winusb.factor        |  2 +-
 .../directx/d3d11shader/d3d11shader.factor    |  2 +-
 .../directx/d3d9types/d3d9types.factor        |  2 +-
 basis/windows/directx/d3dcsx/d3dcsx.factor    |  2 +-
 .../directx/d3dx9shader/d3dx9shader.factor    |  8 ++--
 basis/windows/directx/dcommon/dcommon.factor  |  2 +-
 basis/windows/directx/dwrite/dwrite.factor    | 42 +++++++++----------
 .../windows/directx/dxgitype/dxgitype.factor  |  6 +--
 basis/windows/directx/xapo/xapo.factor        |  2 +-
 basis/windows/directx/xaudio2/xaudio2.factor  |  2 +-
 basis/windows/kernel32/kernel32.factor        |  2 +-
 basis/windows/usp10/usp10.factor              |  2 +-
 basis/x11/constants/constants.factor          |  2 +-
 extra/chipmunk/ffi/ffi.factor                 |  4 +-
 extra/cuda/ffi/ffi.factor                     | 34 +++++++--------
 extra/freetype/freetype.factor                |  4 +-
 extra/libusb/libusb.factor                    | 24 +++++------
 extra/llvm/core/core.factor                   | 14 +++----
 extra/macho/macho.factor                      |  6 +--
 extra/tokyo/alien/tcadb/tcadb.factor          |  2 +-
 extra/tokyo/alien/tcbdb/tcbdb.factor          |  2 +-
 extra/tokyo/alien/tcrdb/tcrdb.factor          |  2 +-
 extra/tokyo/alien/tctdb/tctdb.factor          |  6 +--
 extra/tokyo/alien/tcutil/tcutil.factor        |  2 +-
 37 files changed, 127 insertions(+), 127 deletions(-)

diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor
index d36a4d5fd2..c5130001d9 100644
--- a/basis/alien/data/data-docs.factor
+++ b/basis/alien/data/data-docs.factor
@@ -105,7 +105,7 @@ $nl
 "Important guidelines for passing data in byte arrays:"
 { $subsections "byte-arrays-gc" }
 "C-style enumerated types are supported:"
-{ $subsections POSTPONE: C-ENUM: }
+{ $subsections POSTPONE: ENUM: }
 "C types can be aliased for convenience and consistency with native library documentation:"
 { $subsections POSTPONE: TYPEDEF: }
 "A utility for defining " { $link "destructors" } " for deallocating memory:"
diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor
index b71d0bd533..b7c77dd154 100644
--- a/basis/alien/syntax/syntax-docs.factor
+++ b/basis/alien/syntax/syntax-docs.factor
@@ -69,14 +69,14 @@ HELP: TYPEDEF:
 { $description "Aliases the C type " { $snippet "old" } " under the name " { $snippet "new" } "." }
 { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
 
-HELP: C-ENUM:
-{ $syntax "C-ENUM: type/f words... ;" }
+HELP: ENUM:
+{ $syntax "ENUM: type/f words... ;" }
 { $values { "type" "a name to typedef to int or f" } { "words" "a sequence of word names" } }
 { $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to the rules of C enums." }
 { $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." }
 { $examples
     "Here is an example enumeration definition:"
-    { $code "C-ENUM: color_t red { green 3 } blue ;" }
+    { $code "ENUM: color_t red { green 3 } blue ;" }
     "It is equivalent to the following series of definitions:"
     { $code "CONSTANT: red 0" "CONSTANT: green 3" "CONSTANT: blue 4" }
 } ;
diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor
index 41aed99446..b6cb4af8f6 100755
--- a/basis/alien/syntax/syntax.factor
+++ b/basis/alien/syntax/syntax.factor
@@ -28,7 +28,7 @@ SYNTAX: CALLBACK:
 SYNTAX: TYPEDEF:
     scan-c-type CREATE-C-TYPE dup save-location typedef ;
 
-SYNTAX: C-ENUM:
+SYNTAX: ENUM:
     scan dup "f" =
     [ drop ]
     [ (CREATE-C-TYPE) dup save-location int swap typedef ] if
diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor
index fafc41af26..026fa621f8 100644
--- a/basis/cairo/ffi/ffi.factor
+++ b/basis/cairo/ffi/ffi.factor
@@ -46,7 +46,7 @@ TYPEDEF: void* cairo_destroy_func_t
 STRUCT: cairo_user_data_key_t
     { unused int } ;
 
-C-ENUM: cairo_status_t
+ENUM: cairo_status_t
     CAIRO_STATUS_SUCCESS
     CAIRO_STATUS_NO_MEMORY
     CAIRO_STATUS_INVALID_RESTORE
@@ -126,7 +126,7 @@ FUNCTION: void
 cairo_pop_group_to_source ( cairo_t* cr ) ;
 
 ! Modify state
-C-ENUM: cairo_operator_t
+ENUM: cairo_operator_t
     CAIRO_OPERATOR_CLEAR
 
     CAIRO_OPERATOR_SOURCE
@@ -163,7 +163,7 @@ cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, doub
 FUNCTION: void
 cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
 
-C-ENUM: cairo_antialias_t
+ENUM: cairo_antialias_t
     CAIRO_ANTIALIAS_DEFAULT
     CAIRO_ANTIALIAS_NONE
     CAIRO_ANTIALIAS_GRAY
@@ -172,7 +172,7 @@ C-ENUM: cairo_antialias_t
 FUNCTION: void
 cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
 
-C-ENUM: cairo_fill_rule_t
+ENUM: cairo_fill_rule_t
     CAIRO_FILL_RULE_WINDING
     CAIRO_FILL_RULE_EVEN_ODD ;
 
@@ -182,7 +182,7 @@ cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
 FUNCTION: void
 cairo_set_line_width ( cairo_t* cr, double width ) ;
 
-C-ENUM: cairo_line_cap_t
+ENUM: cairo_line_cap_t
     CAIRO_LINE_CAP_BUTT
     CAIRO_LINE_CAP_ROUND
     CAIRO_LINE_CAP_SQUARE ;
@@ -190,7 +190,7 @@ C-ENUM: cairo_line_cap_t
 FUNCTION: void
 cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
 
-C-ENUM: cairo_line_join_t
+ENUM: cairo_line_join_t
     CAIRO_LINE_JOIN_MITER
     CAIRO_LINE_JOIN_ROUND
     CAIRO_LINE_JOIN_BEVEL ;
@@ -375,30 +375,30 @@ STRUCT: cairo_font_extents_t
     { max_x_advance double }
     { max_y_advance double } ;
 
-C-ENUM: cairo_font_slant_t
+ENUM: cairo_font_slant_t
     CAIRO_FONT_SLANT_NORMAL
     CAIRO_FONT_SLANT_ITALIC
     CAIRO_FONT_SLANT_OBLIQUE ;
 
-C-ENUM: cairo_font_weight_t
+ENUM: cairo_font_weight_t
     CAIRO_FONT_WEIGHT_NORMAL
     CAIRO_FONT_WEIGHT_BOLD ;
 
-C-ENUM: cairo_subpixel_order_t
+ENUM: cairo_subpixel_order_t
     CAIRO_SUBPIXEL_ORDER_DEFAULT
     CAIRO_SUBPIXEL_ORDER_RGB
     CAIRO_SUBPIXEL_ORDER_BGR
     CAIRO_SUBPIXEL_ORDER_VRGB
     CAIRO_SUBPIXEL_ORDER_VBGR ;
 
-C-ENUM: cairo_hint_style_t
+ENUM: cairo_hint_style_t
     CAIRO_HINT_STYLE_DEFAULT
     CAIRO_HINT_STYLE_NONE
     CAIRO_HINT_STYLE_SLIGHT
     CAIRO_HINT_STYLE_MEDIUM
     CAIRO_HINT_STYLE_FULL ;
 
-C-ENUM: cairo_hint_metrics_t
+ENUM: cairo_hint_metrics_t
     CAIRO_HINT_METRICS_DEFAULT
     CAIRO_HINT_METRICS_OFF
     CAIRO_HINT_METRICS_ON ;
@@ -518,7 +518,7 @@ cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
 FUNCTION: cairo_status_t
 cairo_font_face_status ( cairo_font_face_t* font_face ) ;
 
-C-ENUM: cairo_font_type_t
+ENUM: cairo_font_type_t
     CAIRO_FONT_TYPE_TOY
     CAIRO_FONT_TYPE_FT
     CAIRO_FONT_TYPE_WIN32
@@ -630,7 +630,7 @@ cairo_get_target ( cairo_t* cr ) ;
 FUNCTION: cairo_surface_t*
 cairo_get_group_target ( cairo_t* cr ) ;
 
-C-ENUM: cairo_path_data_type_t
+ENUM: cairo_path_data_type_t
     CAIRO_PATH_MOVE_TO
     CAIRO_PATH_LINE_TO
     CAIRO_PATH_CURVE_TO
@@ -696,7 +696,7 @@ cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
 FUNCTION: cairo_status_t
 cairo_surface_status ( cairo_surface_t* surface ) ;
 
-C-ENUM: cairo_surface_type_t
+ENUM: cairo_surface_type_t
     CAIRO_SURFACE_TYPE_IMAGE
     CAIRO_SURFACE_TYPE_PDF
     CAIRO_SURFACE_TYPE_PS
@@ -759,7 +759,7 @@ cairo_surface_show_page ( cairo_surface_t* surface ) ;
 
 ! Image-surface functions
 
-C-ENUM: cairo_format_t
+ENUM: cairo_format_t
     CAIRO_FORMAT_ARGB32
     CAIRO_FORMAT_RGB24
     CAIRO_FORMAT_A8
@@ -831,7 +831,7 @@ cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* k
 FUNCTION: cairo_status_t
 cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
 
-C-ENUM: cairo_pattern_type_t
+ENUM: cairo_pattern_type_t
     CAIRO_PATTERN_TYPE_SOLID
     CAIRO_PATTERN_TYPE_SURFACE
     CAIRO_PATTERN_TYPE_LINEAR
@@ -852,7 +852,7 @@ cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
 FUNCTION: void
 cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
 
-C-ENUM: cairo_extend_t
+ENUM: cairo_extend_t
     CAIRO_EXTEND_NONE
     CAIRO_EXTEND_REPEAT
     CAIRO_EXTEND_REFLECT
@@ -864,7 +864,7 @@ cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
 FUNCTION: cairo_extend_t
 cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
 
-C-ENUM: cairo_filter_t
+ENUM: cairo_filter_t
     CAIRO_FILTER_FAST
     CAIRO_FILTER_GOOD
     CAIRO_FILTER_BEST
diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor
index 6768e1471d..fc5d2baccc 100644
--- a/basis/cocoa/application/application.factor
+++ b/basis/cocoa/application/application.factor
@@ -8,7 +8,7 @@ IN: cocoa.application
 
 : <NSString> ( str -- alien ) <CFString> -> autorelease ;
 
-C-ENUM: f
+ENUM: f
 NSApplicationDelegateReplySuccess
 NSApplicationDelegateReplyCancel
 NSApplicationDelegateReplyFailure ;
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index 0e2fc3041b..7d8ef4791b 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -40,7 +40,7 @@ CONSTANT: deck-bits 18
 : segment-end-offset ( -- n ) 2 bootstrap-cells ; inline
 
 ! Relocation classes
-C-ENUM: f
+ENUM: f
     rc-absolute-cell
     rc-absolute
     rc-relative
@@ -55,7 +55,7 @@ C-ENUM: f
     rc-absolute-1 ;
 
 ! Relocation types
-C-ENUM: f
+ENUM: f
     rt-dlsym
     rt-entry-point
     rt-entry-point-pic
diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor
index 92925f5d64..1e797a3329 100644
--- a/basis/core-graphics/core-graphics.factor
+++ b/basis/core-graphics/core-graphics.factor
@@ -6,7 +6,7 @@ images images.memory core-graphics.types core-foundation.utilities
 opengl.gl literals ;
 IN: core-graphics
 
-C-ENUM: CGImageAlphaInfo
+ENUM: CGImageAlphaInfo
 kCGImageAlphaNone
 kCGImageAlphaPremultipliedLast
 kCGImageAlphaPremultipliedFirst
diff --git a/basis/pango/fonts/fonts.factor b/basis/pango/fonts/fonts.factor
index 7ea4e0a0c2..979e40947c 100644
--- a/basis/pango/fonts/fonts.factor
+++ b/basis/pango/fonts/fonts.factor
@@ -8,7 +8,7 @@ IN: pango.fonts
 
 LIBRARY: pango
 
-C-ENUM: PangoStyle
+ENUM: PangoStyle
 PANGO_STYLE_NORMAL
 PANGO_STYLE_OBLIQUE
 PANGO_STYLE_ITALIC ;
diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor
index 2ab8b27cc7..f330cdb85c 100644
--- a/basis/unicode/breaks/breaks.factor
+++ b/basis/unicode/breaks/breaks.factor
@@ -12,7 +12,7 @@ IN: unicode.breaks
 <PRIVATE
 ! Grapheme breaks
 
-C-ENUM: f Any L V T LV LVT Extend Control CR LF
+ENUM: f Any L V T LV LVT Extend Control CR LF
     SpacingMark Prepend graphemes ;
 
 : jamo-class ( ch -- class )
@@ -131,7 +131,7 @@ VALUE: word-break-table
 "vocab:unicode/data/WordBreakProperty.txt" load-interval-file
 to: word-break-table
 
-C-ENUM: f wOther wCR wLF wNewline wExtend wFormat wKatakana wALetter wMidLetter
+ENUM: f wOther wCR wLF wNewline wExtend wFormat wKatakana wALetter wMidLetter
 wMidNum wMidNumLet wNumeric wExtendNumLet words ;
 
 : word-break-classes ( -- table ) ! Is there a way to avoid this?
diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor
index cef6e9348d..d6915f6b74 100644
--- a/basis/vm/vm.factor
+++ b/basis/vm/vm.factor
@@ -34,7 +34,7 @@ STRUCT: vm
 
 : vm-field-offset ( field -- offset ) vm offset-of ; inline
 
-C-ENUM: f
+ENUM: f
 collect-nursery-op
 collect-aging-op
 collect-to-tenured-op
diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor
index e463725b2f..c40cc232eb 100755
--- a/basis/windows/advapi32/advapi32.factor
+++ b/basis/windows/advapi32/advapi32.factor
@@ -146,7 +146,7 @@ CONSTANT: TokenSessionReference 14
 CONSTANT: TokenSandBoxInert 15
 ! } TOKEN_INFORMATION_CLASS;
 
-C-ENUM: ACCESS_MODE
+ENUM: ACCESS_MODE
     NOT_USED_ACCESS
     GRANT_ACCESS
     SET_ACCESS
@@ -155,18 +155,18 @@ C-ENUM: ACCESS_MODE
     SET_AUDIT_SUCCESS
     SET_AUDIT_FAILURE ;
 
-C-ENUM: MULTIPLE_TRUSTEE_OPERATION
+ENUM: MULTIPLE_TRUSTEE_OPERATION
     NO_MULTIPLE_TRUSTEE
     TRUSTEE_IS_IMPERSONATE ;
 
-C-ENUM: TRUSTEE_FORM
+ENUM: TRUSTEE_FORM
   TRUSTEE_IS_SID
   TRUSTEE_IS_NAME
   TRUSTEE_BAD_FORM
   TRUSTEE_IS_OBJECTS_AND_SID
   TRUSTEE_IS_OBJECTS_AND_NAME ;
 
-C-ENUM: TRUSTEE_TYPE
+ENUM: TRUSTEE_TYPE
     TRUSTEE_IS_UNKNOWN
     TRUSTEE_IS_USER
     TRUSTEE_IS_GROUP
@@ -177,7 +177,7 @@ C-ENUM: TRUSTEE_TYPE
     TRUSTEE_IS_INVALID
     TRUSTEE_IS_COMPUTER ;
 
-C-ENUM: SE_OBJECT_TYPE
+ENUM: SE_OBJECT_TYPE
     SE_UNKNOWN_OBJECT_TYPE
     SE_FILE_OBJECT
     SE_SERVICE
diff --git a/basis/windows/ddk/hid/hid.factor b/basis/windows/ddk/hid/hid.factor
index 0e1e8e208c..957ff8609e 100755
--- a/basis/windows/ddk/hid/hid.factor
+++ b/basis/windows/ddk/hid/hid.factor
@@ -206,7 +206,7 @@ CONSTANT: HID_USAGE_DIGITIZER_BARREL_SWITCH HEX: 44
 CONSTANT: HIDP_LINK_COLLECTION_ROOT        -1
 CONSTANT: HIDP_LINK_COLLECTION_UNSPECIFIED 0
 
-C-ENUM: HIDP_REPORT_TYPE
+ENUM: HIDP_REPORT_TYPE
     HidP_Input
     HidP_Output
     HidP_Feature ;
@@ -607,7 +607,7 @@ HidP_UsageAndPageListDifference (
    ULONG           UsageListLength
    ) ;
 
-C-ENUM: HIDP_KEYBOARD_DIRECTION
+ENUM: HIDP_KEYBOARD_DIRECTION
     HidP_Keyboard_Break
     HidP_Keyboard_Make ;
 
diff --git a/basis/windows/ddk/setupapi/setupapi.factor b/basis/windows/ddk/setupapi/setupapi.factor
index 578a44a6d8..7af177b480 100755
--- a/basis/windows/ddk/setupapi/setupapi.factor
+++ b/basis/windows/ddk/setupapi/setupapi.factor
@@ -1516,7 +1516,7 @@ FUNCTION: BOOL SetupRemoveFileLogEntryA ( HSPFILELOG FileLogHandle, PCSTR LogSec
 FUNCTION: BOOL SetupRemoveFileLogEntryW ( HSPFILELOG FileLogHandle, PCWSTR LogSectionName, PCWSTR TargetFilename ) ;
 ALIAS: SetupRemoveFileLogEntry SetupRemoveFileLogEntryW
 
-C-ENUM: SetupFileLogInfo
+ENUM: SetupFileLogInfo
     SetupFileLogSourceFilename
     SetupFileLogChecksum
     SetupFileLogDiskTagfile
diff --git a/basis/windows/ddk/winusb/winusb.factor b/basis/windows/ddk/winusb/winusb.factor
index 328e16f5c9..d54cd935d1 100755
--- a/basis/windows/ddk/winusb/winusb.factor
+++ b/basis/windows/ddk/winusb/winusb.factor
@@ -22,7 +22,7 @@ STRUCT: USB_INTERFACE_DESCRIPTOR
     { iInterface         UCHAR } ;
 TYPEDEF: USB_INTERFACE_DESCRIPTOR* PUSB_INTERFACE_DESCRIPTOR
 
-C-ENUM: USBD_PIPE_TYPE
+ENUM: USBD_PIPE_TYPE
     UsbdPipeTypeControl
     UsbdPipeTypeIsochronous
     UsbdPipeTypeBulk
diff --git a/basis/windows/directx/d3d11shader/d3d11shader.factor b/basis/windows/directx/d3d11shader/d3d11shader.factor
index 08146300f2..33544d4dc1 100644
--- a/basis/windows/directx/d3d11shader/d3d11shader.factor
+++ b/basis/windows/directx/d3d11shader/d3d11shader.factor
@@ -24,7 +24,7 @@ CONSTANT: D3D11_RETURN_TYPE_DOUBLE    7
 CONSTANT: D3D11_RETURN_TYPE_CONTINUED 8
 TYPEDEF: int D3D11_RESOURCE_RETURN_TYPE
 
-C-ENUM: D3D11_CBUFFER_TYPE
+ENUM: D3D11_CBUFFER_TYPE
     D3D11_CT_CBUFFER
     D3D11_CT_TBUFFER
     D3D11_CT_INTERFACE_POINTERS
diff --git a/basis/windows/directx/d3d9types/d3d9types.factor b/basis/windows/directx/d3d9types/d3d9types.factor
index 09c19bcae4..ff5953b3f4 100644
--- a/basis/windows/directx/d3d9types/d3d9types.factor
+++ b/basis/windows/directx/d3d9types/d3d9types.factor
@@ -502,7 +502,7 @@ CONSTANT: MAXD3DDECLUSAGE         13
 CONSTANT: MAXD3DDECLUSAGEINDEX    15
 CONSTANT: MAXD3DDECLLENGTH        64
 
-C-ENUM: D3DDECLMETHOD
+ENUM: D3DDECLMETHOD
     D3DDECLMETHOD_DEFAULT
     D3DDECLMETHOD_PARTIALU
     D3DDECLMETHOD_PARTIALV
diff --git a/basis/windows/directx/d3dcsx/d3dcsx.factor b/basis/windows/directx/d3dcsx/d3dcsx.factor
index c6d0105fdc..86b804dd19 100644
--- a/basis/windows/directx/d3dcsx/d3dcsx.factor
+++ b/basis/windows/directx/d3dcsx/d3dcsx.factor
@@ -48,7 +48,7 @@ COM-INTERFACE: ID3DX11FFT IUnknown {b3f7a938-4c93-4310-a675-b30d6de50553}
     HRESULT ForwardTransform ( ID3D11UnorderedAccessView* pInputBuffer, ID3D11UnorderedAccessView** ppOutputBuffer )
     HRESULT InverseTransform ( ID3D11UnorderedAccessView* pInputBuffer, ID3D11UnorderedAccessView** ppOutputBuffer ) ;
 
-C-ENUM: D3DX11_FFT_DATA_TYPE
+ENUM: D3DX11_FFT_DATA_TYPE
     D3DX11_FFT_DATA_TYPE_REAL
     D3DX11_FFT_DATA_TYPE_COMPLEX ;
 
diff --git a/basis/windows/directx/d3dx9shader/d3dx9shader.factor b/basis/windows/directx/d3dx9shader/d3dx9shader.factor
index 00844338b5..b6e455b57f 100644
--- a/basis/windows/directx/d3dx9shader/d3dx9shader.factor
+++ b/basis/windows/directx/d3dx9shader/d3dx9shader.factor
@@ -41,14 +41,14 @@ STRUCT: D3DXSEMANTIC
     { UsageIndex UINT } ;
 TYPEDEF: D3DXSEMANTIC* LPD3DXSEMANTIC
 
-C-ENUM: D3DXREGISTER_SET
+ENUM: D3DXREGISTER_SET
     D3DXRS_BOOL
     D3DXRS_INT4
     D3DXRS_FLOAT4
     D3DXRS_SAMPLER ;
 TYPEDEF: D3DXREGISTER_SET* LPD3DXREGISTER_SET
 
-C-ENUM: D3DXPARAMETER_CLASS
+ENUM: D3DXPARAMETER_CLASS
     D3DXPC_SCALAR
     D3DXPC_VECTOR
     D3DXPC_MATRIX_ROWS
@@ -57,7 +57,7 @@ C-ENUM: D3DXPARAMETER_CLASS
     D3DXPC_STRUCT ;
 TYPEDEF: D3DXPARAMETER_CLASS* LPD3DXPARAMETER_CLASS
 
-C-ENUM: D3DXPARAMETER_TYPE
+ENUM: D3DXPARAMETER_TYPE
     D3DXPT_VOID
     D3DXPT_BOOL
     D3DXPT_INT
@@ -158,7 +158,7 @@ COM-INTERFACE: ID3DXTextureShader IUnknown {3E3D67F8-AA7A-405d-A857-BA01D4758426
     HRESULT SetMatrixTransposeArray ( D3DXHANDLE hConstant, D3DXMATRIX* pMatrix, UINT Count )
     HRESULT SetMatrixTransposePointerArray ( D3DXHANDLE hConstant, D3DXMATRIX** ppMatrix, UINT Count ) ;
 
-C-ENUM: D3DXINCLUDE_TYPE
+ENUM: D3DXINCLUDE_TYPE
     D3DXINC_LOCAL
     D3DXINC_SYSTEM ;
 TYPEDEF: D3DXINCLUDE_TYPE* LPD3DXINCLUDE_TYPE
diff --git a/basis/windows/directx/dcommon/dcommon.factor b/basis/windows/directx/dcommon/dcommon.factor
index 32d69f924c..7e74dc0f81 100644
--- a/basis/windows/directx/dcommon/dcommon.factor
+++ b/basis/windows/directx/dcommon/dcommon.factor
@@ -1,7 +1,7 @@
 USING: alien.c-types alien.syntax ;
 IN: windows.directx.dcommon
 
-C-ENUM: DWRITE_MEASURING_MODE
+ENUM: DWRITE_MEASURING_MODE
     DWRITE_MEASURING_MODE_NATURAL
     DWRITE_MEASURING_MODE_GDI_CLASSIC
     DWRITE_MEASURING_MODE_GDI_NATURAL ;
diff --git a/basis/windows/directx/dwrite/dwrite.factor b/basis/windows/directx/dwrite/dwrite.factor
index 91dd422667..b538f5b933 100755
--- a/basis/windows/directx/dwrite/dwrite.factor
+++ b/basis/windows/directx/dwrite/dwrite.factor
@@ -5,7 +5,7 @@ IN: windows.directx.dwrite
 
 LIBRARY: dwrite
 
-C-ENUM: DWRITE_FONT_FILE_TYPE
+ENUM: DWRITE_FONT_FILE_TYPE
     DWRITE_FONT_FILE_TYPE_UNKNOWN
     DWRITE_FONT_FILE_TYPE_CFF
     DWRITE_FONT_FILE_TYPE_TRUETYPE
@@ -15,7 +15,7 @@ C-ENUM: DWRITE_FONT_FILE_TYPE
     DWRITE_FONT_FILE_TYPE_VECTOR
     DWRITE_FONT_FILE_TYPE_BITMAP ;
 
-C-ENUM: DWRITE_FONT_FACE_TYPE
+ENUM: DWRITE_FONT_FACE_TYPE
     DWRITE_FONT_FACE_TYPE_CFF
     DWRITE_FONT_FACE_TYPE_TRUETYPE
     DWRITE_FONT_FACE_TYPE_TRUETYPE_COLLECTION
@@ -24,12 +24,12 @@ C-ENUM: DWRITE_FONT_FACE_TYPE
     DWRITE_FONT_FACE_TYPE_BITMAP
     DWRITE_FONT_FACE_TYPE_UNKNOWN ;
 
-C-ENUM: DWRITE_FONT_SIMULATIONS
+ENUM: DWRITE_FONT_SIMULATIONS
     DWRITE_FONT_SIMULATIONS_NONE
     DWRITE_FONT_SIMULATIONS_BOLD
     DWRITE_FONT_SIMULATIONS_OBLIQUE ;
 
-C-ENUM: DWRITE_FONT_WEIGHT
+ENUM: DWRITE_FONT_WEIGHT
     { DWRITE_FONT_WEIGHT_THIN        100 }
     { DWRITE_FONT_WEIGHT_EXTRA_LIGHT 200 }
     { DWRITE_FONT_WEIGHT_ULTRA_LIGHT 200 }
@@ -47,7 +47,7 @@ C-ENUM: DWRITE_FONT_WEIGHT
     { DWRITE_FONT_WEIGHT_EXTRA_BLACK 950 }
     { DWRITE_FONT_WEIGHT_ULTRA_BLACK 950 } ;
 
-C-ENUM: DWRITE_FONT_STRETCH
+ENUM: DWRITE_FONT_STRETCH
     { DWRITE_FONT_STRETCH_UNDEFINED       0 }
     { DWRITE_FONT_STRETCH_ULTRA_CONDENSED 1 }
     { DWRITE_FONT_STRETCH_EXTRA_CONDENSED 2 }
@@ -60,12 +60,12 @@ C-ENUM: DWRITE_FONT_STRETCH
     { DWRITE_FONT_STRETCH_EXTRA_EXPANDED  8 }
     { DWRITE_FONT_STRETCH_ULTRA_EXPANDED  9 } ;
 
-C-ENUM: DWRITE_FONT_STYLE
+ENUM: DWRITE_FONT_STYLE
     DWRITE_FONT_STYLE_NORMAL
     DWRITE_FONT_STYLE_OBLIQUE
     DWRITE_FONT_STYLE_ITALIC ;
 
-C-ENUM: DWRITE_INFORMATIONAL_STRING_ID
+ENUM: DWRITE_INFORMATIONAL_STRING_ID
     DWRITE_INFORMATIONAL_STRING_NONE
     DWRITE_INFORMATIONAL_STRING_COPYRIGHT_NOTICE
     DWRITE_INFORMATIONAL_STRING_VERSION_STRINGS
@@ -108,7 +108,7 @@ STRUCT: DWRITE_GLYPH_OFFSET
     { advanceOffset  FLOAT }
     { ascenderOffset FLOAT } ;
 
-C-ENUM: DWRITE_FACTORY_TYPE
+ENUM: DWRITE_FACTORY_TYPE
     DWRITE_FACTORY_TYPE_SHARED
     DWRITE_FACTORY_TYPE_ISOLATED ;
 
@@ -133,12 +133,12 @@ COM-INTERFACE: IDWriteFontFile IUnknown {739d886a-cef5-47dc-8769-1a8b41bebbb0}
     HRESULT GetLoader ( IDWriteFontFileLoader** fontFileLoader )
     HRESULT Analyze ( BOOL* isSupportedFontType, DWRITE_FONT_FILE_TYPE* fontFileType, DWRITE_FONT_FACE_TYPE* fontFaceType, UINT32* numberOfFaces ) ;
 
-C-ENUM: DWRITE_PIXEL_GEOMETRY
+ENUM: DWRITE_PIXEL_GEOMETRY
     DWRITE_PIXEL_GEOMETRY_FLAT
     DWRITE_PIXEL_GEOMETRY_RGB
     DWRITE_PIXEL_GEOMETRY_BGR ;
 
-C-ENUM: DWRITE_RENDERING_MODE
+ENUM: DWRITE_RENDERING_MODE
     DWRITE_RENDERING_MODE_DEFAULT
     DWRITE_RENDERING_MODE_ALIASED
     DWRITE_RENDERING_MODE_CLEARTYPE_GDI_CLASSIC
@@ -233,32 +233,32 @@ COM-INTERFACE: IDWriteFont IUnknown {acd16696-8c14-4f5d-877e-fe3fc1d32737}
     HRESULT HasCharacter ( UINT32 unicodeValue, BOOL* exists )
     HRESULT CreateFontFace ( IDWriteFontFace** fontFace ) ;
 
-C-ENUM: DWRITE_READING_DIRECTION
+ENUM: DWRITE_READING_DIRECTION
     DWRITE_READING_DIRECTION_LEFT_TO_RIGHT
     DWRITE_READING_DIRECTION_RIGHT_TO_LEFT ;
 
-C-ENUM: DWRITE_FLOW_DIRECTION
+ENUM: DWRITE_FLOW_DIRECTION
     DWRITE_FLOW_DIRECTION_TOP_TO_BOTTOM ;
 
-C-ENUM: DWRITE_TEXT_ALIGNMENT
+ENUM: DWRITE_TEXT_ALIGNMENT
     DWRITE_TEXT_ALIGNMENT_LEADING
     DWRITE_TEXT_ALIGNMENT_TRAILING
     DWRITE_TEXT_ALIGNMENT_CENTER ;
 
-C-ENUM: DWRITE_PARAGRAPH_ALIGNMENT
+ENUM: DWRITE_PARAGRAPH_ALIGNMENT
     DWRITE_PARAGRAPH_ALIGNMENT_NEAR
     DWRITE_PARAGRAPH_ALIGNMENT_FAR
     DWRITE_PARAGRAPH_ALIGNMENT_CENTER ;
 
-C-ENUM: DWRITE_WORD_WRAPPING
+ENUM: DWRITE_WORD_WRAPPING
     DWRITE_WORD_WRAPPING_WRAP
     DWRITE_WORD_WRAPPING_NO_WRAP ;
 
-C-ENUM: DWRITE_LINE_SPACING_METHOD
+ENUM: DWRITE_LINE_SPACING_METHOD
     DWRITE_LINE_SPACING_METHOD_DEFAULT
     DWRITE_LINE_SPACING_METHOD_UNIFORM ;
 
-C-ENUM: DWRITE_TRIMMING_GRANULARITY
+ENUM: DWRITE_TRIMMING_GRANULARITY
     DWRITE_TRIMMING_GRANULARITY_NONE
     DWRITE_TRIMMING_GRANULARITY_CHARACTER
     DWRITE_TRIMMING_GRANULARITY_WORD ;
@@ -396,7 +396,7 @@ COM-INTERFACE: IDWriteTypography IUnknown {55f1112b-1dc2-4b3c-9541-f46894ed85b6}
     UINT32 GetFontFeatureCount ( )
     HRESULT GetFontFeature ( UINT32 fontFeatureIndex, DWRITE_FONT_FEATURE* fontFeature ) ;
 
-C-ENUM: DWRITE_SCRIPT_SHAPES
+ENUM: DWRITE_SCRIPT_SHAPES
     DWRITE_SCRIPT_SHAPES_DEFAULT
     DWRITE_SCRIPT_SHAPES_NO_VISUAL ;
 
@@ -404,7 +404,7 @@ STRUCT: DWRITE_SCRIPT_ANALYSIS
     { script USHORT               }
     { shapes DWRITE_SCRIPT_SHAPES } ;
 
-C-ENUM: DWRITE_BREAK_CONDITION
+ENUM: DWRITE_BREAK_CONDITION
     DWRITE_BREAK_CONDITION_NEUTRAL
     DWRITE_BREAK_CONDITION_CAN_BREAK
     DWRITE_BREAK_CONDITION_MAY_NOT_BREAK
@@ -413,7 +413,7 @@ C-ENUM: DWRITE_BREAK_CONDITION
 STRUCT: DWRITE_LINE_BREAKPOINT
     { data BYTE } ;
 
-C-ENUM: DWRITE_NUMBER_SUBSTITUTION_METHOD
+ENUM: DWRITE_NUMBER_SUBSTITUTION_METHOD
     DWRITE_NUMBER_SUBSTITUTION_METHOD_FROM_CULTURE
     DWRITE_NUMBER_SUBSTITUTION_METHOD_CONTEXTUAL
     DWRITE_NUMBER_SUBSTITUTION_METHOD_NONE
@@ -612,7 +612,7 @@ COM-INTERFACE: IDWriteGdiInterop IUnknown {1edd9491-9853-4299-898f-6432983b6f3a}
     HRESULT CreateFontFaceFromHdc ( HDC hdc, IDWriteFontFace** fontFace )
     HRESULT CreateBitmapRenderTarget ( HDC hdc, UINT32 width, UINT32 height, IDWriteBitmapRenderTarget** renderTarget ) ;
 
-C-ENUM: DWRITE_TEXTURE_TYPE
+ENUM: DWRITE_TEXTURE_TYPE
     DWRITE_TEXTURE_ALIASED_1x1
     DWRITE_TEXTURE_CLEARTYPE_3x1 ;
 
diff --git a/basis/windows/directx/dxgitype/dxgitype.factor b/basis/windows/directx/dxgitype/dxgitype.factor
index bdab49e652..d0eda4885c 100644
--- a/basis/windows/directx/dxgitype/dxgitype.factor
+++ b/basis/windows/directx/dxgitype/dxgitype.factor
@@ -47,18 +47,18 @@ STRUCT: DXGI_RATIONAL
 { Numerator UINT }
 { Denominator UINT } ;
 
-C-ENUM: DXGI_MODE_SCANLINE_ORDER
+ENUM: DXGI_MODE_SCANLINE_ORDER
     DXGI_MODE_SCANLINE_ORDER_UNSPECIFIED
     DXGI_MODE_SCANLINE_ORDER_PROGRESSIVE
     DXGI_MODE_SCANLINE_ORDER_UPPER_FIELD_FIRST
     DXGI_MODE_SCANLINE_ORDER_LOWER_FIELD_FIRST ;
 
-C-ENUM: DXGI_MODE_SCALING
+ENUM: DXGI_MODE_SCALING
     DXGI_MODE_SCALING_UNSPECIFIED
     DXGI_MODE_SCALING_CENTERED
     DXGI_MODE_SCALING_STRETCHED ;
 
-C-ENUM: DXGI_MODE_ROTATION
+ENUM: DXGI_MODE_ROTATION
     DXGI_MODE_ROTATION_UNSPECIFIED
     DXGI_MODE_ROTATION_IDENTITY
     DXGI_MODE_ROTATION_ROTATE90
diff --git a/basis/windows/directx/xapo/xapo.factor b/basis/windows/directx/xapo/xapo.factor
index f071ea08d5..2f61ade8f5 100644
--- a/basis/windows/directx/xapo/xapo.factor
+++ b/basis/windows/directx/xapo/xapo.factor
@@ -39,7 +39,7 @@ STRUCT: XAPO_LOCKFORPROCESS_BUFFER_PARAMETERS
     { pFormat                    WAVEFORMATEX* }
     { MaxFrameCount              UINT32        } ;
 
-C-ENUM: XAPO_BUFFER_FLAGS
+ENUM: XAPO_BUFFER_FLAGS
     XAPO_BUFFER_SILENT
     XAPO_BUFFER_VALID ;
 
diff --git a/basis/windows/directx/xaudio2/xaudio2.factor b/basis/windows/directx/xaudio2/xaudio2.factor
index bbbf55b34f..a9b2a63f81 100644
--- a/basis/windows/directx/xaudio2/xaudio2.factor
+++ b/basis/windows/directx/xaudio2/xaudio2.factor
@@ -133,7 +133,7 @@ STRUCT: XAUDIO2_EFFECT_CHAIN
     { EffectCount        UINT32                     }
     { pEffectDescriptors XAUDIO2_EFFECT_DESCRIPTOR* } ;
 
-C-ENUM: XAUDIO2_FILTER_TYPE
+ENUM: XAUDIO2_FILTER_TYPE
     LowPassFilter
     BandPassFilter
     HighPassFilter
diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor
index a7c460f525..94cedef38a 100644
--- a/basis/windows/kernel32/kernel32.factor
+++ b/basis/windows/kernel32/kernel32.factor
@@ -199,7 +199,7 @@ CONSTANT: THREAD_PRIORITY_LOWEST -2
 CONSTANT: THREAD_PRIORITY_NORMAL 0
 CONSTANT: THREAD_PRIORITY_TIME_CRITICAL 15
 
-C-ENUM: COMPUTER_NAME_FORMAT
+ENUM: COMPUTER_NAME_FORMAT
     ComputerNameNetBIOS
     ComputerNameDnsHostname
     ComputerNameDnsDomain
diff --git a/basis/windows/usp10/usp10.factor b/basis/windows/usp10/usp10.factor
index 21b4f77434..0f8dcbcdb8 100644
--- a/basis/windows/usp10/usp10.factor
+++ b/basis/windows/usp10/usp10.factor
@@ -37,7 +37,7 @@ FUNCTION: HRESULT ScriptLayout (
     int* piLogicalToVisual
 ) ;
 
-C-ENUM: f
+ENUM: f
     SCRIPT_JUSTIFY_NONE
     SCRIPT_JUSTIFY_ARABIC_BLANK
     SCRIPT_JUSTIFY_CHARACTER
diff --git a/basis/x11/constants/constants.factor b/basis/x11/constants/constants.factor
index 64c7e2f8dd..65a6f7fd75 100644
--- a/basis/x11/constants/constants.factor
+++ b/basis/x11/constants/constants.factor
@@ -406,4 +406,4 @@ CONSTANT: MSBFirst 1
 ! * EXTENDED WINDOW MANAGER HINTS
 ! *****************************************************************
 
-C-ENUM: f _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ;
+ENUM: f _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ;
diff --git a/extra/chipmunk/ffi/ffi.factor b/extra/chipmunk/ffi/ffi.factor
index 857e746d26..ea7c6fbd1a 100644
--- a/extra/chipmunk/ffi/ffi.factor
+++ b/extra/chipmunk/ffi/ffi.factor
@@ -349,7 +349,7 @@ STRUCT: cpSegmentQueryInfo
     { t     cpFloat  }
     { n     cpVect   } ;
 
-C-ENUM: cpShapeType
+ENUM: cpShapeType
     CP_CIRCLE_SHAPE
     CP_SEGMENT_SHAPE
     CP_POLY_SHAPE
@@ -482,7 +482,7 @@ STRUCT: cpContact
 
 FUNCTION: cpContact* cpContactInit ( cpContact* con, cpVect p, cpVect n, cpFloat dist, cpHashValue hash ) ;
 
-C-ENUM: cpArbiterState
+ENUM: cpArbiterState
     cpArbiterStateNormal
     cpArbiterStateFirstColl
     cpArbiterStateIgnore ;
diff --git a/extra/cuda/ffi/ffi.factor b/extra/cuda/ffi/ffi.factor
index b7efeff9fb..3da76698c6 100644
--- a/extra/cuda/ffi/ffi.factor
+++ b/extra/cuda/ffi/ffi.factor
@@ -49,7 +49,7 @@ double    c-type clone always-8-byte-align \ CUdouble    typedef
 STRUCT: CUuuid
     { bytes char[16] } ;
 
-C-ENUM: CUctx_flags
+ENUM: CUctx_flags
     { CU_CTX_SCHED_AUTO  0 }
     { CU_CTX_SCHED_SPIN  1 }
     { CU_CTX_SCHED_YIELD 2 }
@@ -59,11 +59,11 @@ C-ENUM: CUctx_flags
     { CU_CTX_LMEM_RESIZE_TO_MAX 16 }
     { CU_CTX_FLAGS_MASK  HEX: 1f } ;
 
-C-ENUM: CUevent_flags
+ENUM: CUevent_flags
     { CU_EVENT_DEFAULT       0 }
     { CU_EVENT_BLOCKING_SYNC 1 } ;
 
-C-ENUM: CUarray_format
+ENUM: CUarray_format
     { CU_AD_FORMAT_UNSIGNED_INT8  HEX: 01 }
     { CU_AD_FORMAT_UNSIGNED_INT16 HEX: 02 }
     { CU_AD_FORMAT_UNSIGNED_INT32 HEX: 03 }
@@ -73,16 +73,16 @@ C-ENUM: CUarray_format
     { CU_AD_FORMAT_HALF           HEX: 10 }
     { CU_AD_FORMAT_FLOAT          HEX: 20 } ;
 
-C-ENUM: CUaddress_mode
+ENUM: CUaddress_mode
     { CU_TR_ADDRESS_MODE_WRAP   0 }
     { CU_TR_ADDRESS_MODE_CLAMP  1 }
     { CU_TR_ADDRESS_MODE_MIRROR 2 } ;
 
-C-ENUM: CUfilter_mode
+ENUM: CUfilter_mode
     { CU_TR_FILTER_MODE_POINT  0 }
     { CU_TR_FILTER_MODE_LINEAR 1 } ;
 
-C-ENUM: CUdevice_attribute
+ENUM: CUdevice_attribute
     { CU_DEVICE_ATTRIBUTE_MAX_THREADS_PER_BLOCK 1 }
     { CU_DEVICE_ATTRIBUTE_MAX_BLOCK_DIM_X 2 }
     { CU_DEVICE_ATTRIBUTE_MAX_BLOCK_DIM_Y 3 }
@@ -131,7 +131,7 @@ STRUCT: CUdevprop
     { clockRate int }
     { textureAlign int } ;
 
-C-ENUM: CUfunction_attribute
+ENUM: CUfunction_attribute
     { CU_FUNC_ATTRIBUTE_MAX_THREADS_PER_BLOCK 0 }
     { CU_FUNC_ATTRIBUTE_SHARED_SIZE_BYTES 1     }
     { CU_FUNC_ATTRIBUTE_CONST_SIZE_BYTES 2      }
@@ -141,22 +141,22 @@ C-ENUM: CUfunction_attribute
     { CU_FUNC_ATTRIBUTE_BINARY_VERSION 6        }
     CU_FUNC_ATTRIBUTE_MAX ;
 
-C-ENUM: CUfunc_cache
+ENUM: CUfunc_cache
     { CU_FUNC_CACHE_PREFER_NONE   HEX: 00 }
     { CU_FUNC_CACHE_PREFER_SHARED HEX: 01 }
     { CU_FUNC_CACHE_PREFER_L1     HEX: 02 } ;
 
-C-ENUM: CUmemorytype
+ENUM: CUmemorytype
     { CU_MEMORYTYPE_HOST   HEX: 01 }
     { CU_MEMORYTYPE_DEVICE HEX: 02 }
     { CU_MEMORYTYPE_ARRAY  HEX: 03 } ;
 
-C-ENUM: CUcomputemode
+ENUM: CUcomputemode
     { CU_COMPUTEMODE_DEFAULT    0 }
     { CU_COMPUTEMODE_EXCLUSIVE  1 }
     { CU_COMPUTEMODE_PROHIBITED 2 } ;
 
-C-ENUM: CUjit_option
+ENUM: CUjit_option
     { CU_JIT_MAX_REGISTERS 0 }
     CU_JIT_THREADS_PER_BLOCK
     CU_JIT_WALL_TIME
@@ -169,26 +169,26 @@ C-ENUM: CUjit_option
     CU_JIT_TARGET
     CU_JIT_FALLBACK_STRATEGY ;
 
-C-ENUM: CUjit_target
+ENUM: CUjit_target
     { CU_TARGET_COMPUTE_10 0 }
     CU_TARGET_COMPUTE_11
     CU_TARGET_COMPUTE_12
     CU_TARGET_COMPUTE_13
     CU_TARGET_COMPUTE_20 ;
 
-C-ENUM: CUjit_fallback
+ENUM: CUjit_fallback
     { CU_PREFER_PTX 0 }
     CU_PREFER_BINARY ;
 
-C-ENUM: CUgraphicsRegisterFlags
+ENUM: CUgraphicsRegisterFlags
     { CU_GRAPHICS_REGISTER_FLAGS_NONE 0 } ;
 
-C-ENUM: CUgraphicsMapResourceFlags
+ENUM: CUgraphicsMapResourceFlags
     { CU_GRAPHICS_MAP_RESOURCE_FLAGS_NONE          HEX: 00 }
     { CU_GRAPHICS_MAP_RESOURCE_FLAGS_READ_ONLY     HEX: 01 }
     { CU_GRAPHICS_MAP_RESOURCE_FLAGS_WRITE_DISCARD HEX: 02 } ;
 
-C-ENUM: CUarray_cubemap_face
+ENUM: CUarray_cubemap_face
     { CU_CUBEMAP_FACE_POSITIVE_X  HEX: 00 }
     { CU_CUBEMAP_FACE_NEGATIVE_X  HEX: 01 }
     { CU_CUBEMAP_FACE_POSITIVE_Y  HEX: 02 }
@@ -196,7 +196,7 @@ C-ENUM: CUarray_cubemap_face
     { CU_CUBEMAP_FACE_POSITIVE_Z  HEX: 04 }
     { CU_CUBEMAP_FACE_NEGATIVE_Z  HEX: 05 } ;
 
-C-ENUM: CUresult
+ENUM: CUresult
     { CUDA_SUCCESS                    0 }
     { CUDA_ERROR_INVALID_VALUE        1 }
     { CUDA_ERROR_OUT_OF_MEMORY        2 }
diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor
index 497ae883c1..10a2d28dd3 100644
--- a/extra/freetype/freetype.factor
+++ b/extra/freetype/freetype.factor
@@ -176,14 +176,14 @@ FUNCTION: FT_Error FT_Set_Char_Size ( face* face, FT_F26Dot6 char_width, FT_F26D
 
 FUNCTION: FT_Error FT_Load_Char ( face* face, FT_ULong charcode, FT_Int32 load_flags ) ;
 
-C-ENUM: f
+ENUM: f
     FT_RENDER_MODE_NORMAL
     FT_RENDER_MODE_LIGHT
     FT_RENDER_MODE_MONO
     FT_RENDER_MODE_LCD
     FT_RENDER_MODE_LCD_V ;
 
-C-ENUM: f
+ENUM: f
     FT_PIXEL_MODE_NONE
     FT_PIXEL_MODE_MONO
     FT_PIXEL_MODE_GRAY
diff --git a/extra/libusb/libusb.factor b/extra/libusb/libusb.factor
index b276a923b0..a5abc72790 100644
--- a/extra/libusb/libusb.factor
+++ b/extra/libusb/libusb.factor
@@ -19,7 +19,7 @@ LIBRARY: libusb
 
 ALIAS: libusb_le16_to_cpu libusb_cpu_to_le16
 
-C-ENUM: libusb_class_code
+ENUM: libusb_class_code
     { LIBUSB_CLASS_PER_INTERFACE 0 }
     { LIBUSB_CLASS_AUDIO         1 }
     { LIBUSB_CLASS_COMM          2 }
@@ -31,7 +31,7 @@ C-ENUM: libusb_class_code
     { LIBUSB_CLASS_DATA          10 }
     { LIBUSB_CLASS_VENDOR_SPEC HEX: ff } ;
 
-C-ENUM: libusb_descriptor_type
+ENUM: libusb_descriptor_type
     { LIBUSB_DT_DEVICE    HEX: 01 }
     { LIBUSB_DT_CONFIG    HEX: 02 }
     { LIBUSB_DT_STRING    HEX: 03 }
@@ -52,19 +52,19 @@ CONSTANT: LIBUSB_DT_HUB_NONVAR_SIZE       7
 CONSTANT: LIBUSB_ENDPOINT_ADDRESS_MASK    HEX: 0f
 CONSTANT: LIBUSB_ENDPOINT_DIR_MASK        HEX: 80
 
-C-ENUM: libusb_endpoint_direction
+ENUM: libusb_endpoint_direction
     { LIBUSB_ENDPOINT_IN  HEX: 80 }
     { LIBUSB_ENDPOINT_OUT HEX: 00 } ;
 
 CONSTANT: LIBUSB_TRANSFER_TYPE_MASK HEX: 03
 
-C-ENUM: libusb_transfer_type
+ENUM: libusb_transfer_type
     { LIBUSB_TRANSFER_TYPE_CONTROL     0 }
     { LIBUSB_TRANSFER_TYPE_ISOCHRONOUS 1 }
     { LIBUSB_TRANSFER_TYPE_BULK        2 }
     { LIBUSB_TRANSFER_TYPE_INTERRUPT   3 } ;
 
-C-ENUM: libusb_standard_request
+ENUM: libusb_standard_request
     { LIBUSB_REQUEST_GET_STATUS        HEX: 00 }
     { LIBUSB_REQUEST_CLEAR_FEATURE     HEX: 01 }
     { LIBUSB_REQUEST_SET_FEATURE       HEX: 03 }
@@ -77,13 +77,13 @@ C-ENUM: libusb_standard_request
     { LIBUSB_REQUEST_SET_INTERFACE     HEX: 0B }
     { LIBUSB_REQUEST_SYNCH_FRAME       HEX: 0C } ;
 
-C-ENUM: libusb_request_type
+ENUM: libusb_request_type
     { LIBUSB_REQUEST_TYPE_STANDARD HEX: 00 }
     { LIBUSB_REQUEST_TYPE_CLASS    HEX: 20 }
     { LIBUSB_REQUEST_TYPE_VENDOR   HEX: 40 }
     { LIBUSB_REQUEST_TYPE_RESERVED HEX: 60 } ;
 
-C-ENUM: libusb_request_recipient
+ENUM: libusb_request_recipient
     { LIBUSB_RECIPIENT_DEVICE    HEX: 00 }
     { LIBUSB_RECIPIENT_INTERFACE HEX: 01 }
     { LIBUSB_RECIPIENT_ENDPOINT  HEX: 02 }
@@ -91,7 +91,7 @@ C-ENUM: libusb_request_recipient
 
 CONSTANT: LIBUSB_ISO_SYNC_TYPE_MASK HEX: 0C
 
-C-ENUM: libusb_iso_sync_type
+ENUM: libusb_iso_sync_type
     { LIBUSB_ISO_SYNC_TYPE_NONE     0 }
     { LIBUSB_ISO_SYNC_TYPE_ASYNC    1 }
     { LIBUSB_ISO_SYNC_TYPE_ADAPTIVE 2 }
@@ -99,7 +99,7 @@ C-ENUM: libusb_iso_sync_type
 
 CONSTANT: LIBUSB_ISO_USAGE_TYPE_MASK HEX: 30
 
-C-ENUM: libusb_iso_usage_type
+ENUM: libusb_iso_usage_type
     { LIBUSB_ISO_USAGE_TYPE_DATA     0 }
     { LIBUSB_ISO_USAGE_TYPE_FEEDBACK 1 }
     { LIBUSB_ISO_USAGE_TYPE_IMPLICIT 2 } ;
@@ -176,7 +176,7 @@ C-TYPE: libusb_context
 C-TYPE: libusb_device
 C-TYPE: libusb_device_handle
 
-C-ENUM: libusb_error
+ENUM: libusb_error
     { LIBUSB_SUCCESS             0 }
     { LIBUSB_ERROR_IO            -1 }
     { LIBUSB_ERROR_INVALID_PARAM -2 }
@@ -192,7 +192,7 @@ C-ENUM: libusb_error
     { LIBUSB_ERROR_NOT_SUPPORTED -12 }
     { LIBUSB_ERROR_OTHER         -99 } ;
 
-C-ENUM: libusb_transfer_status
+ENUM: libusb_transfer_status
     LIBUSB_TRANSFER_COMPLETED
     LIBUSB_TRANSFER_ERROR
     LIBUSB_TRANSFER_TIMED_OUT
@@ -201,7 +201,7 @@ C-ENUM: libusb_transfer_status
     LIBUSB_TRANSFER_NO_DEVICE
     LIBUSB_TRANSFER_OVERFLOW ;
 
-C-ENUM: libusb_transfer_flags
+ENUM: libusb_transfer_flags
     { LIBUSB_TRANSFER_SHORT_NOT_OK  1 }
     { LIBUSB_TRANSFER_FREE_BUFFER   2 }
     { LIBUSB_TRANSFER_FREE_TRANSFER 4 } ;
diff --git a/extra/llvm/core/core.factor b/extra/llvm/core/core.factor
index 5778a00ffb..4b20655ed4 100644
--- a/extra/llvm/core/core.factor
+++ b/extra/llvm/core/core.factor
@@ -28,7 +28,7 @@ LIBRARY: LLVMCore
 TYPEDEF: uint unsigned
 TYPEDEF: unsigned enum
 
-C-ENUM: LLVMAttribute
+ENUM: LLVMAttribute
     { LLVMZExtAttribute         BIN: 1 }
     { LLVMSExtAttribute         BIN: 10 }
     { LLVMNoReturnAttribute     BIN: 100 }
@@ -41,7 +41,7 @@ C-ENUM: LLVMAttribute
     { LLVMReadNoneAttribute     BIN: 1000000000 }
     { LLVMReadOnlyAttribute     BIN: 10000000000 } ;
 
-C-ENUM: LLVMTypeKind
+ENUM: LLVMTypeKind
   LLVMVoidTypeKind
   LLVMFloatTypeKind
   LLVMDoubleTypeKind
@@ -58,7 +58,7 @@ C-ENUM: LLVMTypeKind
   LLVMOpaqueTypeKind
   LLVMVectorTypeKind ;
 
-C-ENUM: LLVMLinkage
+ENUM: LLVMLinkage
   LLVMExternalLinkage
   LLVMLinkOnceLinkage
   LLVMWeakLinkage
@@ -69,19 +69,19 @@ C-ENUM: LLVMLinkage
   LLVMExternalWeakLinkage
   LLVMGhostLinkage ;
 
-C-ENUM: LLVMVisibility
+ENUM: LLVMVisibility
   LLVMDefaultVisibility
   LLVMHiddenVisibility
   LLVMProtectedVisibility ;
 
-C-ENUM: LLVMCallConv
+ENUM: LLVMCallConv
   { LLVMCCallConv             0 }
   { LLVMFastCallConv          8 }
   { LLVMColdCallConv          9 }
   { LLVMX86StdcallCallConv    64 }
   { LLVMX86FastcallCallConv   65 } ;
 
-C-ENUM: LLVMIntPredicate
+ENUM: LLVMIntPredicate
   { LLVMIntEQ                 32 }
   { LLVMIntNE                 33 }
   { LLVMIntUGT                34 }
@@ -93,7 +93,7 @@ C-ENUM: LLVMIntPredicate
   { LLVMIntSLT                40 }
   { LLVMIntSLE                41 } ;
 
-C-ENUM: LLVMRealPredicate
+ENUM: LLVMRealPredicate
   LLVMRealPredicateFalse
   LLVMRealOEQ
   LLVMRealOGT
diff --git a/extra/macho/macho.factor b/extra/macho/macho.factor
index 70dc594e07..3c0536dd9c 100644
--- a/extra/macho/macho.factor
+++ b/extra/macho/macho.factor
@@ -775,14 +775,14 @@ STRUCT: scattered_relocation_info_little_endian
     { r_address_type_length_pcrel_scattered uint }
     { r_value                               int  } ;
 
-C-ENUM: reloc_type_generic
+ENUM: reloc_type_generic
     GENERIC_RELOC_VANILLA
     GENERIC_RELOC_PAIR
     GENERIC_RELOC_SECTDIFF
     GENERIC_RELOC_PB_LA_PTR
     GENERIC_RELOC_LOCAL_SECTDIFF ;
 
-C-ENUM: reloc_type_x86_64
+ENUM: reloc_type_x86_64
     X86_64_RELOC_UNSIGNED
     X86_64_RELOC_SIGNED
     X86_64_RELOC_BRANCH
@@ -793,7 +793,7 @@ C-ENUM: reloc_type_x86_64
     X86_64_RELOC_SIGNED_2
     X86_64_RELOC_SIGNED_4 ;
 
-C-ENUM: reloc_type_ppc
+ENUM: reloc_type_ppc
     PPC_RELOC_VANILLA
     PPC_RELOC_PAIR
     PPC_RELOC_BR14
diff --git a/extra/tokyo/alien/tcadb/tcadb.factor b/extra/tokyo/alien/tcadb/tcadb.factor
index 6107111be2..cb2a805cba 100644
--- a/extra/tokyo/alien/tcadb/tcadb.factor
+++ b/extra/tokyo/alien/tcadb/tcadb.factor
@@ -9,7 +9,7 @@ LIBRARY: tokyocabinet
 
 TYPEDEF: void* TCADB
 
-C-ENUM: f
+ENUM: f
     ADBOVOID
     ADBOMDB
     ADBONDB
diff --git a/extra/tokyo/alien/tcbdb/tcbdb.factor b/extra/tokyo/alien/tcbdb/tcbdb.factor
index 04913eba73..5871e1d7a0 100644
--- a/extra/tokyo/alien/tcbdb/tcbdb.factor
+++ b/extra/tokyo/alien/tcbdb/tcbdb.factor
@@ -27,7 +27,7 @@ CONSTANT: BDBOTSYNC  64
 
 TYPEDEF: void* BDBCUR
 
-C-ENUM: f
+ENUM: f
     BDBCPCURRENT
     BDBCPBEFORE
     BDBCPAFTER ;
diff --git a/extra/tokyo/alien/tcrdb/tcrdb.factor b/extra/tokyo/alien/tcrdb/tcrdb.factor
index 0da3feafb5..ced1eb1c47 100644
--- a/extra/tokyo/alien/tcrdb/tcrdb.factor
+++ b/extra/tokyo/alien/tcrdb/tcrdb.factor
@@ -25,7 +25,7 @@ C-TYPE: TCRDB
 !     { timeout double }
 !     { opts int } ;
 
-C-ENUM: f
+ENUM: f
     TTESUCCESS
     TTEINVALID
     TTENOHOST
diff --git a/extra/tokyo/alien/tctdb/tctdb.factor b/extra/tokyo/alien/tctdb/tctdb.factor
index e5a278e1b9..3f25298ddb 100644
--- a/extra/tokyo/alien/tctdb/tctdb.factor
+++ b/extra/tokyo/alien/tctdb/tctdb.factor
@@ -27,7 +27,7 @@ CONSTANT: TDBONOLCK  16
 CONSTANT: TDBOLCKNB  32
 CONSTANT: TDBOTSYNC  64
 
-C-ENUM: f
+ENUM: f
   TDBITLEXICAL
   TDBITDECIMAL ;
 
@@ -38,7 +38,7 @@ CONSTANT: TDBITKEEP 16777216
 C-TYPE: TDBCOND
 C-TYPE: TDBQRY
 
-C-ENUM: f
+ENUM: f
     TDBQCSTREQ
     TDBQCSTRINC
     TDBQCSTRBW
@@ -58,7 +58,7 @@ C-ENUM: f
 CONSTANT: TDBQCNEGATE 16777216
 CONSTANT: TDBQCNOIDX  33554432
 
-C-ENUM: f
+ENUM: f
     TDBQOSTRASC
     TDBQOSTRDESC
     TDBQONUMASC
diff --git a/extra/tokyo/alien/tcutil/tcutil.factor b/extra/tokyo/alien/tcutil/tcutil.factor
index e5db5328cb..d77c28b103 100644
--- a/extra/tokyo/alien/tcutil/tcutil.factor
+++ b/extra/tokyo/alien/tcutil/tcutil.factor
@@ -12,7 +12,7 @@ IN: tokyo.alien.tcutil
 
 LIBRARY: tokyocabinet
 
-C-ENUM: f
+ENUM: f
     TCDBTHASH
     TCDBTBTREE
     TCDBTFIXED

From 8c915e05f7d007907fe98d534f600938bb2850ce Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 12 Apr 2010 21:42:48 -0700
Subject: [PATCH 031/158] alien.parser, alien.syntax: refactor ENUM: to
 separate parsing from definition

---
 basis/alien/parser/parser.factor | 27 ++++++++++++++++++---------
 basis/alien/syntax/syntax.factor |  6 +++---
 2 files changed, 21 insertions(+), 12 deletions(-)

diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor
index 1db4ca5cd8..63f5043eeb 100755
--- a/basis/alien/parser/parser.factor
+++ b/basis/alien/parser/parser.factor
@@ -75,19 +75,28 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
     "*" ?head
     [ [ <pointer> ] dip parse-pointers ] when ;
 
+: next-enum-member ( members name value -- members value' )
+    [ 2array suffix! ] [ 1 + ] bi ;
+
 PRIVATE>
 
-: define-enum-member ( word-string value -- next-value )
-     [ create-in ] dip [ define-constant ] keep 1 + ;
+: define-enum-member ( name value -- )
+    [ create-in ] [ define-constant ] bi* ;
 
-: parse-enum-member ( word-string value -- next-value )
-     over "{" =
-     [ 2drop scan scan-object define-enum-member "}" expect ]
-     [ define-enum-member ] if ;
+: define-enum-members ( members -- )
+    [ first2 define-enum-member ] each ;
 
-: parse-enum-members ( counter -- )
-     scan dup ";" = not
-     [ swap parse-enum-member parse-enum-members ] [ 2drop ] if ;
+: parse-enum-member ( members name value -- members value' )
+    over "{" =
+    [ 2drop scan scan-object next-enum-member "}" expect ]
+    [ next-enum-member ] if ;
+
+: parse-enum-members ( members counter -- members )
+    scan dup ";" = not
+    [ swap parse-enum-member parse-enum-members ] [ 2drop ] if ;
+
+: define-enum ( word members -- )
+    [ int swap typedef ] [ define-enum-members ] bi* ;
 
 : scan-function-name ( -- return function )
     scan-c-type scan parse-pointers ;
diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor
index b6cb4af8f6..c69a9b8ebe 100755
--- a/basis/alien/syntax/syntax.factor
+++ b/basis/alien/syntax/syntax.factor
@@ -30,9 +30,9 @@ SYNTAX: TYPEDEF:
 
 SYNTAX: ENUM:
     scan dup "f" =
-    [ drop ]
-    [ (CREATE-C-TYPE) dup save-location int swap typedef ] if
-    0 parse-enum-members ;
+    [ drop f ]
+    [ (CREATE-C-TYPE) dup save-location ] if
+    V{ } clone 0 parse-enum-members define-enum ;
 
 SYNTAX: C-TYPE:
     void CREATE-C-TYPE typedef ;

From f394cb4fdca8044c8da8d2f79bdd5a69c1c4ad54 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 12 Apr 2010 21:54:41 -0700
Subject: [PATCH 032/158] alien.parser: have define-enum handle the case when
 the enum name is f

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

diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor
index 63f5043eeb..952f7b64d9 100755
--- a/basis/alien/parser/parser.factor
+++ b/basis/alien/parser/parser.factor
@@ -96,7 +96,7 @@ PRIVATE>
     [ swap parse-enum-member parse-enum-members ] [ 2drop ] if ;
 
 : define-enum ( word members -- )
-    [ int swap typedef ] [ define-enum-members ] bi* ;
+    [ [ int swap typedef ] when ] [ define-enum-members ] bi* ;
 
 : scan-function-name ( -- return function )
     scan-c-type scan parse-pointers ;

From 6e55a3b8f5b1f6c707e2c85269f7996ac349b838 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 12 Apr 2010 21:58:08 -0700
Subject: [PATCH 033/158] alien.parser, alien.syntax: send ENUM: body to
 parse-enum

---
 basis/alien/parser/parser.factor | 24 +++++++++++++++---------
 basis/alien/syntax/syntax.factor |  5 +----
 2 files changed, 16 insertions(+), 13 deletions(-)

diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor
index 952f7b64d9..731cc4d6b5 100755
--- a/basis/alien/parser/parser.factor
+++ b/basis/alien/parser/parser.factor
@@ -78,14 +78,6 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
 : next-enum-member ( members name value -- members value' )
     [ 2array suffix! ] [ 1 + ] bi ;
 
-PRIVATE>
-
-: define-enum-member ( name value -- )
-    [ create-in ] [ define-constant ] bi* ;
-
-: define-enum-members ( members -- )
-    [ first2 define-enum-member ] each ;
-
 : parse-enum-member ( members name value -- members value' )
     over "{" =
     [ 2drop scan scan-object next-enum-member "}" expect ]
@@ -95,8 +87,22 @@ PRIVATE>
     scan dup ";" = not
     [ swap parse-enum-member parse-enum-members ] [ 2drop ] if ;
 
+: define-enum-member ( name value -- )
+    [ create-in ] [ define-constant ] bi* ;
+
+: define-enum-members ( members -- )
+    [ first2 define-enum-member ] each ;
+
+PRIVATE>
+
+: parse-enum ( -- name members )
+    scan dup "f" =
+    [ drop f ]
+    [ (CREATE-C-TYPE) dup save-location ] if
+    V{ } clone 0 parse-enum-members ;
+
 : define-enum ( word members -- )
-    [ [ int swap typedef ] when ] [ define-enum-members ] bi* ;
+    [ [ int swap typedef ] when* ] [ define-enum-members ] bi* ;
 
 : scan-function-name ( -- return function )
     scan-c-type scan parse-pointers ;
diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor
index c69a9b8ebe..be137b1da8 100755
--- a/basis/alien/syntax/syntax.factor
+++ b/basis/alien/syntax/syntax.factor
@@ -29,10 +29,7 @@ SYNTAX: TYPEDEF:
     scan-c-type CREATE-C-TYPE dup save-location typedef ;
 
 SYNTAX: ENUM:
-    scan dup "f" =
-    [ drop f ]
-    [ (CREATE-C-TYPE) dup save-location ] if
-    V{ } clone 0 parse-enum-members define-enum ;
+    parse-enum define-enum ;
 
 SYNTAX: C-TYPE:
     void CREATE-C-TYPE typedef ;

From e730d3b6d566bf19b93a1d77f92919a0e6d5dd1a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 12 Apr 2010 23:04:29 -0700
Subject: [PATCH 034/158] alien.c-types: use CONSULT: to define c-type-protocol
 methods on c-type-name

---
 basis/alien/c-types/c-types.factor | 61 ++++++++++++------------------
 1 file changed, 24 insertions(+), 37 deletions(-)

diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 17bf4765b8..ff3c9b8dde 100644
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays arrays assocs kernel kernel.private math
+USING: byte-arrays arrays assocs delegate kernel kernel.private math
 math.order math.parser namespaces make parser sequences strings
 words splitting cpu.architecture alien alien.accessors
 alien.strings quotations layouts system compiler.units io
@@ -79,74 +79,50 @@ GENERIC: c-type-class ( name -- class )
 
 M: abstract-c-type c-type-class class>> ;
 
-M: c-type-name c-type-class c-type c-type-class ;
-
 GENERIC: c-type-boxed-class ( name -- class )
 
 M: abstract-c-type c-type-boxed-class boxed-class>> ;
 
-M: c-type-name c-type-boxed-class c-type c-type-boxed-class ;
-
 GENERIC: c-type-boxer ( name -- boxer )
 
 M: c-type c-type-boxer boxer>> ;
 
-M: c-type-name c-type-boxer c-type c-type-boxer ;
-
 GENERIC: c-type-boxer-quot ( name -- quot )
 
 M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
 
-M: c-type-name c-type-boxer-quot c-type c-type-boxer-quot ;
-
 GENERIC: c-type-unboxer ( name -- boxer )
 
 M: c-type c-type-unboxer unboxer>> ;
 
-M: c-type-name c-type-unboxer c-type c-type-unboxer ;
-
 GENERIC: c-type-unboxer-quot ( name -- quot )
 
 M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
 
-M: c-type-name c-type-unboxer-quot c-type c-type-unboxer-quot ;
-
 GENERIC: c-type-rep ( name -- rep )
 
 M: c-type c-type-rep rep>> ;
 
-M: c-type-name c-type-rep c-type c-type-rep ;
-
 GENERIC: c-type-getter ( name -- quot )
 
 M: c-type c-type-getter getter>> ;
 
-M: c-type-name c-type-getter c-type c-type-getter ;
-
 GENERIC: c-type-setter ( name -- quot )
 
 M: c-type c-type-setter setter>> ;
 
-M: c-type-name c-type-setter c-type c-type-setter ;
-
 GENERIC: c-type-align ( name -- n )
 
 M: abstract-c-type c-type-align align>> ;
 
-M: c-type-name c-type-align c-type c-type-align ;
-
 GENERIC: c-type-align-first ( name -- n )
 
-M: c-type-name c-type-align-first c-type c-type-align-first ;
-
 M: abstract-c-type c-type-align-first align-first>> ;
 
 GENERIC: c-type-stack-align? ( name -- ? )
 
 M: c-type c-type-stack-align? stack-align?>> ;
 
-M: c-type-name c-type-stack-align? c-type c-type-stack-align? ;
-
 : c-type-box ( n c-type -- )
     [ c-type-rep ] [ c-type-boxer [ "No boxer" throw ] unless* ] bi
     %box ;
@@ -159,38 +135,26 @@ GENERIC: box-parameter ( n c-type -- )
 
 M: c-type box-parameter c-type-box ;
 
-M: c-type-name box-parameter c-type box-parameter ;
-
 GENERIC: box-return ( c-type -- )
 
 M: c-type box-return f swap c-type-box ;
 
-M: c-type-name box-return c-type box-return ;
-
 GENERIC: unbox-parameter ( n c-type -- )
 
 M: c-type unbox-parameter c-type-unbox ;
 
-M: c-type-name unbox-parameter c-type unbox-parameter ;
-
 GENERIC: unbox-return ( c-type -- )
 
 M: c-type unbox-return f swap c-type-unbox ;
 
-M: c-type-name unbox-return c-type unbox-return ;
-
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
 GENERIC: heap-size ( name -- size )
 
-M: c-type-name heap-size c-type heap-size ;
-
 M: abstract-c-type heap-size size>> ;
 
 GENERIC: stack-size ( name -- size )
 
-M: c-type-name stack-size c-type stack-size ;
-
 M: c-type stack-size size>> cell align ;
 
 : >c-bool ( ? -- int ) 1 0 ? ; inline
@@ -217,6 +181,29 @@ MIXIN: value-type
         \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
     ] [ ] make ;
 
+PROTOCOL: c-type-protocol 
+    c-type-class
+    c-type-boxed-class
+    c-type-boxer
+    c-type-boxer-quot
+    c-type-unboxer
+    c-type-unboxer-quot
+    c-type-rep
+    c-type-getter
+    c-type-setter
+    c-type-align
+    c-type-align-first
+    c-type-stack-align?
+    box-parameter
+    box-return
+    unbox-parameter
+    unbox-return
+    heap-size
+    stack-size ;
+
+CONSULT: c-type-protocol c-type-name
+    c-type ;
+
 PREDICATE: typedef-word < c-type-word
     "c-type" word-prop c-type-name? ;
 

From d3f770d54533b480b4189618b6ee3cfa1aff39df Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 12 Apr 2010 23:58:58 -0700
Subject: [PATCH 035/158] add alien.enums vocab with enum-c-types that convert
 between symbols and integer values in the FFI. update ENUM: to define
 symbolic enums, and take an optional base type

---
 basis/alien/enums/enums.factor   | 38 ++++++++++++++++++++++++++++++++
 basis/alien/parser/parser.factor | 38 ++++++++++++++++----------------
 basis/alien/syntax/syntax.factor |  2 +-
 3 files changed, 58 insertions(+), 20 deletions(-)
 create mode 100644 basis/alien/enums/enums.factor

diff --git a/basis/alien/enums/enums.factor b/basis/alien/enums/enums.factor
new file mode 100644
index 0000000000..7cef34369d
--- /dev/null
+++ b/basis/alien/enums/enums.factor
@@ -0,0 +1,38 @@
+! (c)2010 Joe Groff bsd license
+USING: accessors alien.c-types arrays combinators delegate fry
+kernel quotations sequences words.symbol ;
+IN: alien.enums
+
+TUPLE: enum-c-type base-type members ;
+
+CONSULT: c-type-protocol enum-c-type
+    base-type>> ;
+
+: map-to-case ( quot: ( x -- y ) -- case )
+    { } map-as [ ] suffix ; inline
+
+: enum-unboxer ( members -- quot )
+    [ first2 '[ _ ] 2array ] map-to-case '[ _ case ] ;
+
+: enum-boxer ( members -- quot )
+    [ first2 swap '[ _ ] 2array ] map-to-case '[ _ case ] ;
+
+M: enum-c-type c-type-boxed-class drop object ;
+M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
+M: enum-c-type c-type-unboxer-quot members>> enum-unboxer ;
+M: enum-c-type c-type-setter
+    [ members>> enum-unboxer ] [ base-type>> c-type-setter ] bi
+    '[ _ 2dip @ ] ;
+
+C: <enum-c-type> enum-c-type
+
+<PRIVATE
+
+: define-enum-members ( member-names -- )
+    [ first define-symbol ] each ;
+
+PRIVATE>
+
+: define-enum ( word base-type members -- )
+    [ define-enum-members ] [ <enum-c-type> swap typedef ] bi ;
+
diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor
index 731cc4d6b5..07f0d49f2f 100755
--- a/basis/alien/parser/parser.factor
+++ b/basis/alien/parser/parser.factor
@@ -78,31 +78,31 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
 : next-enum-member ( members name value -- members value' )
     [ 2array suffix! ] [ 1 + ] bi ;
 
+: parse-enum-name ( -- name )
+    scan dup "f" =
+    [ drop f ]
+    [ (CREATE-C-TYPE) dup save-location ] if ;
+
+: parse-enum-base-type ( -- base-type token )
+    scan dup "<" =
+    [ drop scan-object scan ]
+    [ [ int ] dip ] if ;
+
 : parse-enum-member ( members name value -- members value' )
     over "{" =
-    [ 2drop scan scan-object next-enum-member "}" expect ]
-    [ next-enum-member ] if ;
+    [ 2drop scan create-in scan-object next-enum-member "}" expect ]
+    [ [ create-in ] dip next-enum-member ] if ;
 
-: parse-enum-members ( members counter -- members )
-    scan dup ";" = not
-    [ swap parse-enum-member parse-enum-members ] [ 2drop ] if ;
-
-: define-enum-member ( name value -- )
-    [ create-in ] [ define-constant ] bi* ;
-
-: define-enum-members ( members -- )
-    [ first2 define-enum-member ] each ;
+: parse-enum-members ( members counter token -- members )
+    dup ";" = not
+    [ swap parse-enum-member scan parse-enum-members ] [ 2drop ] if ;
 
 PRIVATE>
 
-: parse-enum ( -- name members )
-    scan dup "f" =
-    [ drop f ]
-    [ (CREATE-C-TYPE) dup save-location ] if
-    V{ } clone 0 parse-enum-members ;
-
-: define-enum ( word members -- )
-    [ [ int swap typedef ] when* ] [ define-enum-members ] bi* ;
+: parse-enum ( -- name base-type members )
+    parse-enum-name
+    parse-enum-base-type
+    [ V{ } clone 0 ] dip parse-enum-members ;
 
 : scan-function-name ( -- return function )
     scan-c-type scan parse-pointers ;
diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor
index be137b1da8..570ebf60a5 100755
--- a/basis/alien/syntax/syntax.factor
+++ b/basis/alien/syntax/syntax.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays alien alien.c-types alien.arrays
+USING: accessors arrays alien alien.c-types alien.enums alien.arrays
 alien.strings kernel math namespaces parser sequences words
 quotations math.parser splitting grouping effects assocs
 combinators lexer strings.parser alien.parser fry vocabs.parser

From 52903ee59787c0a35d0ff34bdd3b223dcc46bed8 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 13 Apr 2010 00:13:18 -0700
Subject: [PATCH 036/158] prettyprint ENUM: definitions

---
 basis/alien/enums/enums.factor             |  4 ++++
 basis/alien/prettyprint/prettyprint.factor | 21 +++++++++++++++++----
 2 files changed, 21 insertions(+), 4 deletions(-)

diff --git a/basis/alien/enums/enums.factor b/basis/alien/enums/enums.factor
index 7cef34369d..bd508df075 100644
--- a/basis/alien/enums/enums.factor
+++ b/basis/alien/enums/enums.factor
@@ -8,8 +8,10 @@ TUPLE: enum-c-type base-type members ;
 CONSULT: c-type-protocol enum-c-type
     base-type>> ;
 
+<PRIVATE
 : map-to-case ( quot: ( x -- y ) -- case )
     { } map-as [ ] suffix ; inline
+PRIVATE>
 
 : enum-unboxer ( members -- quot )
     [ first2 '[ _ ] 2array ] map-to-case '[ _ case ] ;
@@ -36,3 +38,5 @@ PRIVATE>
 : define-enum ( word base-type members -- )
     [ define-enum-members ] [ <enum-c-type> swap typedef ] bi ;
 
+PREDICATE: enum-c-type-word < c-type-word
+    "c-type" word-prop enum-c-type? ;
diff --git a/basis/alien/prettyprint/prettyprint.factor b/basis/alien/prettyprint/prettyprint.factor
index c47dafbfce..8ba1328dcd 100644
--- a/basis/alien/prettyprint/prettyprint.factor
+++ b/basis/alien/prettyprint/prettyprint.factor
@@ -1,9 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel combinators alien alien.strings alien.c-types
-alien.parser alien.syntax arrays assocs effects math.parser
-prettyprint.backend prettyprint.custom prettyprint.sections
-definitions see see.private sequences strings words ;
+USING: accessors kernel combinators alien alien.enums
+alien.strings alien.c-types alien.parser alien.syntax arrays
+assocs effects math.parser prettyprint.backend prettyprint.custom
+prettyprint.sections definitions see see.private sequences
+strings words ;
 IN: alien.prettyprint
 
 M: alien pprint*
@@ -110,3 +111,15 @@ M: alien-callback-type-word synopsis*
             ")" text block>
         ]
     } cleave ;
+
+M: enum-c-type-word definer
+    drop \ ENUM: \ ; ;
+M: enum-c-type-word synopsis*
+    {
+        [ seeing-word ]
+        [ definer. ]
+        [ pprint-word ]
+        [ c-type base-type>> dup int eq? [ drop ] [ "<" text pprint-word ] if ]
+    } cleave ;
+M: enum-c-type-word definition
+    c-type members>> ;

From baab8c060d1eeff8e7683e6132c604d2c0bda15f Mon Sep 17 00:00:00 2001
From: Erik Charlebois <erikcharlebois@gmail.com>
Date: Sun, 18 Apr 2010 13:34:18 -0700
Subject: [PATCH 037/158] Remove ENUM: f and replace uses with CONSTANTs. Fix
 bootstrap and load-all errors from enum classes.

---
 basis/alien/enums/enums.factor             |  8 ++-
 basis/alien/parser/parser.factor           |  4 +-
 basis/cocoa/application/application.factor |  7 +--
 basis/compiler/constants/constants.factor  | 66 +++++++++++-----------
 basis/core-graphics/core-graphics.factor   | 16 +++---
 basis/unicode/breaks/breaks.factor         | 31 ++++++++--
 basis/vm/vm.factor                         | 13 ++---
 basis/windows/usp10/usp10.factor           | 33 ++++++-----
 basis/x11/constants/constants.factor       |  4 +-
 extra/freetype/freetype.factor             | 26 ++++-----
 extra/tokyo/alien/tcadb/tcadb.factor       | 17 +++---
 extra/tokyo/alien/tcbdb/tcbdb.factor       |  7 +--
 extra/tokyo/alien/tcrdb/tcrdb.factor       | 19 +++----
 extra/tokyo/alien/tctdb/tctdb.factor       | 45 +++++++--------
 extra/tokyo/alien/tcutil/tcutil.factor     |  9 ++-
 misc/fuel/fuel-syntax.el                   |  6 +-
 unmaintained/cryptlib/libcl/libcl.factor   | 12 ++--
 unmaintained/pdf/libhpdf/libhpdf.factor    | 12 ++--
 18 files changed, 173 insertions(+), 162 deletions(-)

diff --git a/basis/alien/enums/enums.factor b/basis/alien/enums/enums.factor
index bd508df075..97b694f890 100644
--- a/basis/alien/enums/enums.factor
+++ b/basis/alien/enums/enums.factor
@@ -1,6 +1,6 @@
 ! (c)2010 Joe Groff bsd license
 USING: accessors alien.c-types arrays combinators delegate fry
-kernel quotations sequences words.symbol ;
+kernel quotations sequences words.symbol words ;
 IN: alien.enums
 
 TUPLE: enum-c-type base-type members ;
@@ -28,6 +28,12 @@ M: enum-c-type c-type-setter
 
 C: <enum-c-type> enum-c-type
 
+: enum>int ( enum enum-c-type -- int )
+    c-type-unboxer-quot call( x -- y ) ; inline
+
+: int>enum ( int enum-c-type -- enum )
+    c-type-boxer-quot call( x -- y ) ; inline
+
 <PRIVATE
 
 : define-enum-members ( member-names -- )
diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor
index 07f0d49f2f..166c29bef5 100755
--- a/basis/alien/parser/parser.factor
+++ b/basis/alien/parser/parser.factor
@@ -79,9 +79,7 @@ M: pointer return-type-name to>> return-type-name CHAR: * suffix ;
     [ 2array suffix! ] [ 1 + ] bi ;
 
 : parse-enum-name ( -- name )
-    scan dup "f" =
-    [ drop f ]
-    [ (CREATE-C-TYPE) dup save-location ] if ;
+    scan (CREATE-C-TYPE) dup save-location ;
 
 : parse-enum-base-type ( -- base-type token )
     scan dup "<" =
diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor
index fc5d2baccc..db1eefca14 100644
--- a/basis/cocoa/application/application.factor
+++ b/basis/cocoa/application/application.factor
@@ -8,10 +8,9 @@ IN: cocoa.application
 
 : <NSString> ( str -- alien ) <CFString> -> autorelease ;
 
-ENUM: f
-NSApplicationDelegateReplySuccess
-NSApplicationDelegateReplyCancel
-NSApplicationDelegateReplyFailure ;
+CONSTANT: NSApplicationDelegateReplySuccess 0
+CONSTANT: NSApplicationDelegateReplyCancel  1
+CONSTANT: NSApplicationDelegateReplyFailure 2
 
 : with-autorelease-pool ( quot -- )
     NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index 7d8ef4791b..2fdf814521 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel layouts system strings words quotations byte-arrays
-alien alien.syntax arrays literals sequences ;
+alien arrays literals sequences ;
 IN: compiler.constants
 
 ! These constants must match vm/memory.h
@@ -40,42 +40,40 @@ CONSTANT: deck-bits 18
 : segment-end-offset ( -- n ) 2 bootstrap-cells ; inline
 
 ! Relocation classes
-ENUM: f
-    rc-absolute-cell
-    rc-absolute
-    rc-relative
-    rc-absolute-ppc-2/2
-    rc-absolute-ppc-2
-    rc-relative-ppc-2
-    rc-relative-ppc-3
-    rc-relative-arm-3
-    rc-indirect-arm
-    rc-indirect-arm-pc
-    rc-absolute-2
-    rc-absolute-1 ;
+CONSTANT: rc-absolute-cell 0
+CONSTANT: rc-absolute 1
+CONSTANT: rc-relative 2
+CONSTANT: rc-absolute-ppc-2/2 3
+CONSTANT: rc-absolute-ppc-2 4
+CONSTANT: rc-relative-ppc-2 5
+CONSTANT: rc-relative-ppc-3 6
+CONSTANT: rc-relative-arm-3 7
+CONSTANT: rc-indirect-arm 8
+CONSTANT: rc-indirect-arm-pc 9
+CONSTANT: rc-absolute-2 10
+CONSTANT: rc-absolute-1 11
 
 ! Relocation types
-ENUM: f
-    rt-dlsym
-    rt-entry-point
-    rt-entry-point-pic
-    rt-entry-point-pic-tail
-    rt-here
-    rt-this
-    rt-literal
-    rt-untagged
-    rt-megamorphic-cache-hits
-    rt-vm
-    rt-cards-offset
-    rt-decks-offset
-    rt-exception-handler
-    rt-float ;
+CONSTANT: rt-dlsym 0
+CONSTANT: rt-entry-point 1
+CONSTANT: rt-entry-point-pic 2
+CONSTANT: rt-entry-point-pic-tail 3
+CONSTANT: rt-here 4
+CONSTANT: rt-this 5
+CONSTANT: rt-literal 6
+CONSTANT: rt-untagged 7
+CONSTANT: rt-megamorphic-cache-hits 8
+CONSTANT: rt-vm 9
+CONSTANT: rt-cards-offset 10
+CONSTANT: rt-decks-offset 11
+CONSTANT: rt-exception-handler 12
+CONSTANT: rt-float 13
 
 : rc-absolute? ( n -- ? )
     ${
-        rc-absolute-ppc-2/2
-        rc-absolute-cell
-        rc-absolute
-        rc-absolute-2
-        rc-absolute-1
+        $ rc-absolute-ppc-2/2
+        $ rc-absolute-cell
+        $ rc-absolute
+        $ rc-absolute-2
+        $ rc-absolute-1
     } member? ;
diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor
index 1e797a3329..d921789cb0 100644
--- a/basis/core-graphics/core-graphics.factor
+++ b/basis/core-graphics/core-graphics.factor
@@ -6,14 +6,14 @@ images images.memory core-graphics.types core-foundation.utilities
 opengl.gl literals ;
 IN: core-graphics
 
-ENUM: CGImageAlphaInfo
-kCGImageAlphaNone
-kCGImageAlphaPremultipliedLast
-kCGImageAlphaPremultipliedFirst
-kCGImageAlphaLast
-kCGImageAlphaFirst
-kCGImageAlphaNoneSkipLast
-kCGImageAlphaNoneSkipFirst ;
+TYPEDEF: int CGImageAlphaInfo
+CONSTANT: kCGImageAlphaNone 0
+CONSTANT: kCGImageAlphaPremultipliedLast 1
+CONSTANT: kCGImageAlphaPremultipliedFirst 2
+CONSTANT: kCGImageAlphaLast 3
+CONSTANT: kCGImageAlphaFirst 4
+CONSTANT: kCGImageAlphaNoneSkipLast 5
+CONSTANT: kCGImageAlphaNoneSkipFirst 6
 
 CONSTANT: kCGBitmapAlphaInfoMask HEX: 1f
 CONSTANT: kCGBitmapFloatComponents 256
diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor
index f330cdb85c..13c7d1ac79 100644
--- a/basis/unicode/breaks/breaks.factor
+++ b/basis/unicode/breaks/breaks.factor
@@ -12,8 +12,19 @@ IN: unicode.breaks
 <PRIVATE
 ! Grapheme breaks
 
-ENUM: f Any L V T LV LVT Extend Control CR LF
-    SpacingMark Prepend graphemes ;
+CONSTANT: Any 0
+CONSTANT: L 1
+CONSTANT: V 2
+CONSTANT: T 3
+CONSTANT: LV 4
+CONSTANT: LVT 5
+CONSTANT: Extend 6
+CONSTANT: Control 7
+CONSTANT: CR 8
+CONSTANT: LF 9
+CONSTANT: SpacingMark 10
+CONSTANT: Prepend 11
+CONSTANT: graphemes 12
 
 : jamo-class ( ch -- class )
     dup initial? [ drop L ]
@@ -131,8 +142,20 @@ VALUE: word-break-table
 "vocab:unicode/data/WordBreakProperty.txt" load-interval-file
 to: word-break-table
 
-ENUM: f wOther wCR wLF wNewline wExtend wFormat wKatakana wALetter wMidLetter
-wMidNum wMidNumLet wNumeric wExtendNumLet words ;
+CONSTANT: wOther 0
+CONSTANT: wCR 1
+CONSTANT: wLF 2
+CONSTANT: wNewline 3
+CONSTANT: wExtend 4
+CONSTANT: wFormat 5
+CONSTANT: wKatakana 6
+CONSTANT: wALetter 7
+CONSTANT: wMidLetter 8
+CONSTANT: wMidNum 9
+CONSTANT: wMidNumLet 10
+CONSTANT: wNumeric 11
+CONSTANT: wExtendNumLet 12
+CONSTANT: words 13
 
 : word-break-classes ( -- table ) ! Is there a way to avoid this?
     H{
diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor
index d6915f6b74..7d68d8d901 100644
--- a/basis/vm/vm.factor
+++ b/basis/vm/vm.factor
@@ -34,13 +34,12 @@ STRUCT: vm
 
 : vm-field-offset ( field -- offset ) vm offset-of ; inline
 
-ENUM: f
-collect-nursery-op
-collect-aging-op
-collect-to-tenured-op
-collect-full-op
-collect-compact-op
-collect-growing-heap-op ;
+CONSTANT: collect-nursery-op 0
+CONSTANT: collect-aging-op 1
+CONSTANT: collect-to-tenured-op 2
+CONSTANT: collect-full-op 3
+CONSTANT: collect-compact-op 4
+CONSTANT: collect-growing-heap-op 5
 
 STRUCT: copying-sizes
 { size cell }
diff --git a/basis/windows/usp10/usp10.factor b/basis/windows/usp10/usp10.factor
index 0f8dcbcdb8..7a103a91b4 100644
--- a/basis/windows/usp10/usp10.factor
+++ b/basis/windows/usp10/usp10.factor
@@ -37,23 +37,22 @@ FUNCTION: HRESULT ScriptLayout (
     int* piLogicalToVisual
 ) ;
 
-ENUM: f
-    SCRIPT_JUSTIFY_NONE
-    SCRIPT_JUSTIFY_ARABIC_BLANK
-    SCRIPT_JUSTIFY_CHARACTER
-    SCRIPT_JUSTIFY_RESERVED1
-    SCRIPT_JUSTIFY_BLANK
-    SCRIPT_JUSTIFY_RESERVED2
-    SCRIPT_JUSTIFY_RESERVED3
-    SCRIPT_JUSTIFY_ARABIC_NORMAL
-    SCRIPT_JUSTIFY_ARABIC_KASHIDA
-    SCRIPT_JUSTIFY_ALEF
-    SCRIPT_JUSTIFY_HA
-    SCRIPT_JUSTIFY_RA
-    SCRIPT_JUSTIFY_BA
-    SCRIPT_JUSTIFY_BARA
-    SCRIPT_JUSTIFY_SEEN
-    SCRIPT_JUSTIFFY_RESERVED4 ;
+CONSTANT: SCRIPT_JUSTIFY_NONE 0
+CONSTANT: SCRIPT_JUSTIFY_ARABIC_BLANK 1
+CONSTANT: SCRIPT_JUSTIFY_CHARACTER 2
+CONSTANT: SCRIPT_JUSTIFY_RESERVED1 3
+CONSTANT: SCRIPT_JUSTIFY_BLANK 4
+CONSTANT: SCRIPT_JUSTIFY_RESERVED2 5
+CONSTANT: SCRIPT_JUSTIFY_RESERVED3 6
+CONSTANT: SCRIPT_JUSTIFY_ARABIC_NORMAL 7
+CONSTANT: SCRIPT_JUSTIFY_ARABIC_KASHIDA 8
+CONSTANT: SCRIPT_JUSTIFY_ALEF 9
+CONSTANT: SCRIPT_JUSTIFY_HA 10
+CONSTANT: SCRIPT_JUSTIFY_RA 11
+CONSTANT: SCRIPT_JUSTIFY_BA 12
+CONSTANT: SCRIPT_JUSTIFY_BARA 13
+CONSTANT: SCRIPT_JUSTIFY_SEEN 14
+CONSTANT: SCRIPT_JUSTIFFY_RESERVED4 15
 
 STRUCT: SCRIPT_VISATTR
     { flags WORD } ;
diff --git a/basis/x11/constants/constants.factor b/basis/x11/constants/constants.factor
index 65a6f7fd75..e0b040211e 100644
--- a/basis/x11/constants/constants.factor
+++ b/basis/x11/constants/constants.factor
@@ -406,4 +406,6 @@ CONSTANT: MSBFirst 1
 ! * EXTENDED WINDOW MANAGER HINTS
 ! *****************************************************************
 
-ENUM: f _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ;
+CONSTANT: _NET_WM_STATE_REMOVE 0
+CONSTANT: _NET_WM_STATE_ADD 1
+CONSTANT: _NET_WM_STATE_TOGGLE 2
diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor
index 10a2d28dd3..e7b59ca60f 100644
--- a/extra/freetype/freetype.factor
+++ b/extra/freetype/freetype.factor
@@ -176,21 +176,19 @@ FUNCTION: FT_Error FT_Set_Char_Size ( face* face, FT_F26Dot6 char_width, FT_F26D
 
 FUNCTION: FT_Error FT_Load_Char ( face* face, FT_ULong charcode, FT_Int32 load_flags ) ;
 
-ENUM: f
-    FT_RENDER_MODE_NORMAL
-    FT_RENDER_MODE_LIGHT
-    FT_RENDER_MODE_MONO
-    FT_RENDER_MODE_LCD
-    FT_RENDER_MODE_LCD_V ;
+CONSTANT: FT_RENDER_MODE_NORMAL 0
+CONSTANT: FT_RENDER_MODE_LIGHT 1
+CONSTANT: FT_RENDER_MODE_MONO 2
+CONSTANT: FT_RENDER_MODE_LCD 3
+CONSTANT: FT_RENDER_MODE_LCD_V 4
 
-ENUM: f
-    FT_PIXEL_MODE_NONE
-    FT_PIXEL_MODE_MONO
-    FT_PIXEL_MODE_GRAY
-    FT_PIXEL_MODE_GRAY2
-    FT_PIXEL_MODE_GRAY4
-    FT_PIXEL_MODE_LCD
-    FT_PIXEL_MODE_LCD_V ;
+CONSTANT: FT_PIXEL_MODE_NONE 0
+CONSTANT: FT_PIXEL_MODE_MONO 1
+CONSTANT: FT_PIXEL_MODE_GRAY 2
+CONSTANT: FT_PIXEL_MODE_GRAY2 3
+CONSTANT: FT_PIXEL_MODE_GRAY4 4
+CONSTANT: FT_PIXEL_MODE_LCD 5
+CONSTANT: FT_PIXEL_MODE_LCD_V 6
 
 FUNCTION: int FT_Render_Glyph ( glyph* slot, int render_mode ) ;
 
diff --git a/extra/tokyo/alien/tcadb/tcadb.factor b/extra/tokyo/alien/tcadb/tcadb.factor
index cb2a805cba..84163ce080 100644
--- a/extra/tokyo/alien/tcadb/tcadb.factor
+++ b/extra/tokyo/alien/tcadb/tcadb.factor
@@ -9,15 +9,14 @@ LIBRARY: tokyocabinet
 
 TYPEDEF: void* TCADB
 
-ENUM: f
-    ADBOVOID
-    ADBOMDB
-    ADBONDB
-    ADBOHDB
-    ADBOBDB
-    ADBOFDB
-    ADBOTDB
-    ADBOSKEL ;
+CONSTANT: ADBOVOID 0
+CONSTANT: ADBOMDB 1
+CONSTANT: ADBONDB 2
+CONSTANT: ADBOHDB 3
+CONSTANT: ADBOBDB 4
+CONSTANT: ADBOFDB 5
+CONSTANT: ADBOTDB 6
+CONSTANT: ADBOSKEL 7
 
 FUNCTION: TCADB* tcadbnew ( ) ;
 FUNCTION: void tcadbdel ( TCADB* adb ) ;
diff --git a/extra/tokyo/alien/tcbdb/tcbdb.factor b/extra/tokyo/alien/tcbdb/tcbdb.factor
index 5871e1d7a0..2233ceeb93 100644
--- a/extra/tokyo/alien/tcbdb/tcbdb.factor
+++ b/extra/tokyo/alien/tcbdb/tcbdb.factor
@@ -27,10 +27,9 @@ CONSTANT: BDBOTSYNC  64
 
 TYPEDEF: void* BDBCUR
 
-ENUM: f
-    BDBCPCURRENT
-    BDBCPBEFORE
-    BDBCPAFTER ;
+CONSTANT: BDBCPCURRENT 0
+CONSTANT: BDBCPBEFORE 1
+CONSTANT: BDBCPAFTER 2
 
 FUNCTION: c-string tcbdberrmsg ( int ecode ) ;
 FUNCTION: TCBDB* tcbdbnew ( ) ;
diff --git a/extra/tokyo/alien/tcrdb/tcrdb.factor b/extra/tokyo/alien/tcrdb/tcrdb.factor
index ced1eb1c47..7f98f431c7 100644
--- a/extra/tokyo/alien/tcrdb/tcrdb.factor
+++ b/extra/tokyo/alien/tcrdb/tcrdb.factor
@@ -25,16 +25,15 @@ C-TYPE: TCRDB
 !     { timeout double }
 !     { opts int } ;
 
-ENUM: f
-    TTESUCCESS
-    TTEINVALID
-    TTENOHOST
-    TTEREFUSED
-    TTESEND
-    TTERECV
-    TTEKEEP
-    TTENOREC ;
-CONSTANT: TTEMISC 9999
+CONSTANT: TTESUCCESS 0
+CONSTANT: TTEINVALID 1
+CONSTANT: TTENOHOST  2
+CONSTANT: TTEREFUSED 3
+CONSTANT: TTESEND    4
+CONSTANT: TTERECV    5
+CONSTANT: TTEKEEP    6
+CONSTANT: TTENOREC   7
+CONSTANT: TTEMISC    9999
 
 CONSTANT: RDBTRECON   1
 CONSTANT: RDBXOLCKREC 1
diff --git a/extra/tokyo/alien/tctdb/tctdb.factor b/extra/tokyo/alien/tctdb/tctdb.factor
index 3f25298ddb..072f428d58 100644
--- a/extra/tokyo/alien/tctdb/tctdb.factor
+++ b/extra/tokyo/alien/tctdb/tctdb.factor
@@ -27,9 +27,8 @@ CONSTANT: TDBONOLCK  16
 CONSTANT: TDBOLCKNB  32
 CONSTANT: TDBOTSYNC  64
 
-ENUM: f
-  TDBITLEXICAL
-  TDBITDECIMAL ;
+CONSTANT: TDBITLEXICAL 0
+CONSTANT: TDBITDECIMAL 1
 
 CONSTANT: TDBITOPT  9998
 CONSTANT: TDBITVOID 9999
@@ -38,31 +37,29 @@ CONSTANT: TDBITKEEP 16777216
 C-TYPE: TDBCOND
 C-TYPE: TDBQRY
 
-ENUM: f
-    TDBQCSTREQ
-    TDBQCSTRINC
-    TDBQCSTRBW
-    TDBQCSTREW
-    TDBQCSTRAND
-    TDBQCSTROR
-    TDBQCSTROREQ
-    TDBQCSTRRX
-    TDBQCNUMEQ
-    TDBQCNUMGT
-    TDBQCNUMGE
-    TDBQCNUMLT
-    TDBQCNUMLE
-    TDBQCNUMBT
-    TDBQCNUMOREQ ;
+CONSTANT: TDBQCSTREQ   0
+CONSTANT: TDBQCSTRINC  1
+CONSTANT: TDBQCSTRBW   2
+CONSTANT: TDBQCSTREW   3
+CONSTANT: TDBQCSTRAND  4
+CONSTANT: TDBQCSTROR   5
+CONSTANT: TDBQCSTROREQ 6
+CONSTANT: TDBQCSTRRX   7
+CONSTANT: TDBQCNUMEQ   8
+CONSTANT: TDBQCNUMGT   9
+CONSTANT: TDBQCNUMGE   10
+CONSTANT: TDBQCNUMLT   11
+CONSTANT: TDBQCNUMLE   12
+CONSTANT: TDBQCNUMBT   13
+CONSTANT: TDBQCNUMOREQ 14
 
 CONSTANT: TDBQCNEGATE 16777216
 CONSTANT: TDBQCNOIDX  33554432
 
-ENUM: f
-    TDBQOSTRASC
-    TDBQOSTRDESC
-    TDBQONUMASC
-    TDBQONUMDESC ;
+CONSTANT: TDBQOSTRASC  0
+CONSTANT: TDBQOSTRDESC 1
+CONSTANT: TDBQONUMASC  2
+CONSTANT: TDBQONUMDESC 3
 
 CONSTANT: TDBQPPUT  1
 CONSTANT: TDBQPOUT  2
diff --git a/extra/tokyo/alien/tcutil/tcutil.factor b/extra/tokyo/alien/tcutil/tcutil.factor
index d77c28b103..54fe000df7 100644
--- a/extra/tokyo/alien/tcutil/tcutil.factor
+++ b/extra/tokyo/alien/tcutil/tcutil.factor
@@ -12,11 +12,10 @@ IN: tokyo.alien.tcutil
 
 LIBRARY: tokyocabinet
 
-ENUM: f
-    TCDBTHASH
-    TCDBTBTREE
-    TCDBTFIXED
-    TCDBTTABLE ;
+CONSTANT: TCDBTHASH 0
+CONSTANT: TCDBTBTREE 1
+CONSTANT: TCDBTFIXED 2
+CONSTANT: TCDBTTABLE 3
 
 ! FIXME: on windows 64bits this isn't correct, because long is 32bits there, and time_t is int64
 TYPEDEF: long tokyo_time_t
diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el
index c6638915b7..80010235b1 100644
--- a/misc/fuel/fuel-syntax.el
+++ b/misc/fuel/fuel-syntax.el
@@ -47,7 +47,7 @@
   '(":" "::" ";" "&:" "<<" "<PRIVATE" ">>"
     "ABOUT:" "AFTER:" "ALIAS:" "ALIEN:" "ARTICLE:"
     "B" "BEFORE:" "BIN:"
-    "C:" "CALLBACK:" "C-ENUM:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"
+    "C:" "CALLBACK:" "ENUM:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"
     "DEFER:"
     "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
     "f" "FORGET:" "FROM:" "FUNCTION:"
@@ -165,7 +165,7 @@
 
 (defconst fuel-syntax--indent-def-starts '("" ":"
                                            "AFTER" "BEFORE"
-                                           "C-ENUM" "COM-INTERFACE" "CONSULT"
+                                           "ENUM" "COM-INTERFACE" "CONSULT"
                                            "FROM" "FUNCTION:"
                                            "INTERSECTION:"
                                            "M" "M:" "MACRO" "MACRO:"
@@ -280,7 +280,7 @@
     ("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
     ("\\_<USING:\\( \\)" (1 "<b"))
     ("\\_<\\(C\\)-ENUM: \\(;\\)" (1 "<b") (2 ">b"))
-    ("\\_<C-ENUM:\\( \\|\n\\)" (1 "<b"))
+    ("\\_<ENUM:\\( \\|\n\\)" (1 "<b"))
     ("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\|\n\\)\\([^;]\\|$\\)" (1 "<b"))
     ("\\_<TUPLE: +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)" (1 "<b"))
     ("\\_<\\(SYMBOLS\\|SPECIALIZED-ARRAYS\\|SINGLETONS\\|VARIANT\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)"
diff --git a/unmaintained/cryptlib/libcl/libcl.factor b/unmaintained/cryptlib/libcl/libcl.factor
index 02bd38d045..e2b13e8cb1 100644
--- a/unmaintained/cryptlib/libcl/libcl.factor
+++ b/unmaintained/cryptlib/libcl/libcl.factor
@@ -878,13 +878,11 @@ TYPEDEF: int CRYPT_KEYID_TYPE
 ! Internal keyset options
 ! (As _NONE but open for exclusive access, _CRYPT_DEFINED
 ! Last possible key option type, _CRYPT_DEFINED Last external keyset option)
-C-ENUM: f
-    CRYPT_KEYOPT_NONE
-    CRYPT_KEYOPT_READONLY
-    CRYPT_KEYOPT_CREATE
-    CRYPT_IKEYOPT_EXCLUSIVEACCESS
-    CRYPT_KEYOPT_LAST
-;
+CONSTANT: CRYPT_KEYOPT_NONE 0
+CONSTANT: CRYPT_KEYOPT_READONLY 1
+CONSTANT: CRYPT_KEYOPT_CREATE 2
+CONSTANT: CRYPT_IKEYOPT_EXCLUSIVEACCESS 3
+CONSTANT: CRYPT_KEYOPT_LAST 4
 
 : CRYPT_KEYOPT_LAST_EXTERNAL   3 ; inline ! = CRYPT_KEYOPT_CREATE + 1
 
diff --git a/unmaintained/pdf/libhpdf/libhpdf.factor b/unmaintained/pdf/libhpdf/libhpdf.factor
index f01feb494d..49e02d4f8f 100644
--- a/unmaintained/pdf/libhpdf/libhpdf.factor
+++ b/unmaintained/pdf/libhpdf/libhpdf.factor
@@ -24,13 +24,11 @@ IN: pdf.libhpdf
 : HPDF_COMP_MASK      HEX: FF ; inline
 
 ! page mode
-C-ENUM: f
-    HPDF_PAGE_MODE_USE_NONE
-    HPDF_PAGE_MODE_USE_OUTLINE
-    HPDF_PAGE_MODE_USE_THUMBS
-    HPDF_PAGE_MODE_FULL_SCREEN
-    HPDF_PAGE_MODE_EOF
-;
+CONSTANT: HPDF_PAGE_MODE_USE_NONE 0
+CONSTANT: HPDF_PAGE_MODE_USE_OUTLINE 1
+CONSTANT: HPDF_PAGE_MODE_USE_THUMBS 2
+CONSTANT: HPDF_PAGE_MODE_FULL_SCREEN 3
+CONSTANT: HPDF_PAGE_MODE_EOF 4
 
 : error-code ( -- seq ) {
      { HEX: 1001  "HPDF_ARRAY_COUNT_ERR\nInternal error. The consistency of the data was lost." }

From fdeb305a3ccc04fc84890bbeaddb76f6863d8cc3 Mon Sep 17 00:00:00 2001
From: Erik Charlebois <erikcharlebois@gmail.com>
Date: Mon, 19 Apr 2010 15:53:59 -0700
Subject: [PATCH 038/158] Use generic word for enum>number. Tests and
 documentations.

---
 basis/alien/enums/enums-docs.factor   | 30 +++++++++++++
 basis/alien/enums/enums-tests.factor  | 35 +++++++++++++++
 basis/alien/enums/enums.factor        | 65 +++++++++++++++------------
 basis/alien/syntax/syntax-docs.factor | 13 +++---
 4 files changed, 107 insertions(+), 36 deletions(-)
 create mode 100644 basis/alien/enums/enums-docs.factor
 create mode 100644 basis/alien/enums/enums-tests.factor

diff --git a/basis/alien/enums/enums-docs.factor b/basis/alien/enums/enums-docs.factor
new file mode 100644
index 0000000000..86c8503c61
--- /dev/null
+++ b/basis/alien/enums/enums-docs.factor
@@ -0,0 +1,30 @@
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types help.markup help.syntax words ;
+IN: alien.enums
+
+HELP: define-enum
+{ $values
+    { "word" word } { "base-type" c-type } { "members" "sequence of word and value pairs" }
+}
+{ $description "Defines an enum. This is the run-time equivalent of ENUM:." } ;
+
+HELP: enum>number
+{ $values
+    { "enum" "an enum word" }
+    { "number" "the corresponding number value" }
+}
+{ $description "Converts an enum to a number." } ;
+
+HELP: number>enum
+{ $values
+    { "number" "an enum number" } { "enum-c-type" "an enum type" }
+    { "enum" "the corresponding enum word" }
+}
+{ $description "Convert a number to an enum." } ;
+
+ARTICLE: "alien.enums" "alien.enums"
+{ $vocab-link "alien.enums" }
+;
+
+ABOUT: "alien.enums"
diff --git a/basis/alien/enums/enums-tests.factor b/basis/alien/enums/enums-tests.factor
new file mode 100644
index 0000000000..f0c665830d
--- /dev/null
+++ b/basis/alien/enums/enums-tests.factor
@@ -0,0 +1,35 @@
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.enums alien.enums.private
+alien.syntax sequences tools.test words ;
+IN: alien.enums.tests
+
+ENUM: color_t red { green 3 } blue ;
+ENUM: instrument_t < ushort trombone trumpet ;
+
+{ { red green blue 5 } }
+[ { 0 3 4 5 } [ <color_t> ] map ] unit-test
+
+{ { 0 3 4 5 } }
+[ { red green blue 5 } [ enum>number ] map ] unit-test
+
+{ { -1 trombone trumpet } }
+[ { -1 0 1 } [ <instrument_t> ] map ] unit-test
+
+{ { -1 0 1 } }
+[ { -1 trombone trumpet } [ enum>number ] map ] unit-test
+
+{ t }
+[ color_t "c-type" word-prop enum-c-type? ] unit-test
+
+{ f }
+[ ushort "c-type" word-prop enum-c-type? ] unit-test
+
+{ int }
+[ color_t "c-type" word-prop base-type>> ] unit-test
+
+{ ushort }
+[ instrument_t "c-type" word-prop base-type>> ] unit-test
+
+{ V{ { red 0 } { green 3 } { blue 4 } } }
+[ color_t "c-type" word-prop members>> ] unit-test
diff --git a/basis/alien/enums/enums.factor b/basis/alien/enums/enums.factor
index 97b694f890..6920a7742d 100644
--- a/basis/alien/enums/enums.factor
+++ b/basis/alien/enums/enums.factor
@@ -1,48 +1,55 @@
-! (c)2010 Joe Groff bsd license
-USING: accessors alien.c-types arrays combinators delegate fry
-kernel quotations sequences words.symbol words ;
+! (c)2010 Joe Groff, Erik Charlebois bsd license
+USING: accessors alien.c-types arrays classes.singleton combinators
+delegate fry generic.parser kernel math parser sequences words ;
 IN: alien.enums
 
+<PRIVATE
 TUPLE: enum-c-type base-type members ;
-
+C: <enum-c-type> enum-c-type
 CONSULT: c-type-protocol enum-c-type
     base-type>> ;
-
-<PRIVATE
-: map-to-case ( quot: ( x -- y ) -- case )
-    { } map-as [ ] suffix ; inline
 PRIVATE>
 
-: enum-unboxer ( members -- quot )
-    [ first2 '[ _ ] 2array ] map-to-case '[ _ case ] ;
+GENERIC: enum>number ( enum -- number )
+M: integer enum>number ;
 
-: enum-boxer ( members -- quot )
-    [ first2 swap '[ _ ] 2array ] map-to-case '[ _ case ] ;
-
-M: enum-c-type c-type-boxed-class drop object ;
-M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
-M: enum-c-type c-type-unboxer-quot members>> enum-unboxer ;
-M: enum-c-type c-type-setter
-    [ members>> enum-unboxer ] [ base-type>> c-type-setter ] bi
-    '[ _ 2dip @ ] ;
-
-C: <enum-c-type> enum-c-type
-
-: enum>int ( enum enum-c-type -- int )
-    c-type-unboxer-quot call( x -- y ) ; inline
-
-: int>enum ( int enum-c-type -- enum )
+: number>enum ( number enum-c-type -- enum )
     c-type-boxer-quot call( x -- y ) ; inline
 
 <PRIVATE
+: enum-boxer ( members -- quot )
+    [ first2 swap '[ _ ] 2array ]
+    { } map-as [ ] suffix '[ _ case ] ;
+PRIVATE>
+
+M: enum-c-type c-type-boxed-class drop object ;
+M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
+M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
+M: enum-c-type c-type-setter
+   [ enum>number ] swap base-type>> c-type-setter '[ _ 2dip @ ] ;
+
+<PRIVATE
+
+: define-enum>number ( class value -- )
+    [ \ enum>number create-method-in ]
+    [ '[ drop _ ] ] bi* define ;
 
 : define-enum-members ( member-names -- )
-    [ first define-symbol ] each ;
+    [
+        [ first define-singleton-class ]
+        [ first2 define-enum>number ] bi
+    ] each ;
+
+: define-enum-constructor ( word -- )
+    [ name>> "<" ">" surround create-in ] keep
+    [ number>enum ] curry (( enum -- number )) define-inline ;
 
 PRIVATE>
 
 : define-enum ( word base-type members -- )
-    [ define-enum-members ] [ <enum-c-type> swap typedef ] bi ;
-
+    [ dup define-enum-constructor ] 2dip
+    dup define-enum-members
+    <enum-c-type> swap typedef ;
+    
 PREDICATE: enum-c-type-word < c-type-word
     "c-type" word-prop enum-c-type? ;
diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor
index b7c77dd154..f93f1fb3b8 100644
--- a/basis/alien/syntax/syntax-docs.factor
+++ b/basis/alien/syntax/syntax-docs.factor
@@ -1,6 +1,6 @@
 IN: alien.syntax
-USING: alien alien.c-types alien.parser alien.libraries
-classes.struct help.markup help.syntax see ;
+USING: alien alien.c-types alien.enums alien.libraries classes.struct
+help.markup help.syntax see ;
 
 HELP: DLL"
 { $syntax "DLL\" path\"" }
@@ -70,15 +70,14 @@ HELP: TYPEDEF:
 { $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
 
 HELP: ENUM:
-{ $syntax "ENUM: type/f words... ;" }
+{ $syntax "ENUM: type words... ;" "ENUM: type < base-type words..." }
 { $values { "type" "a name to typedef to int or f" } { "words" "a sequence of word names" } }
-{ $description "Creates a sequence of word definitions in the current vocabulary. Each word pushes an integer according to the rules of C enums." }
-{ $notes "This word emulates a C-style " { $snippet "enum" } " in Factor. While this feature can be used for any purpose, using integer constants is discouraged unless it is for interfacing with C libraries. Factor code should use " { $link "words.symbol" } " or " { $link "singletons" } " instead." }
+{ $description "Creates a c-type that boxes and unboxes integer values to singletons. A singleton is defined for each member word. The base c-type can optionally be specified and defaults to " { $snippet "int" } ". A constructor word " { $snippet "<type>" } " is defined for converting from integers to singletons. The generic word " { $link enum>number } " converts from singletons to integers. Enum-typed values are automatically prettyprinted as their singleton words. Unrecognizing enum numbers are kept as numbers." }
 { $examples
     "Here is an example enumeration definition:"
     { $code "ENUM: color_t red { green 3 } blue ;" }
-    "It is equivalent to the following series of definitions:"
-    { $code "CONSTANT: red 0" "CONSTANT: green 3" "CONSTANT: blue 4" }
+    "The following expression returns true:"
+    { $code "3 <color_t> [ green = ] [ enum>number 3 = ] bi and" }
 } ;
 
 HELP: C-TYPE:

From e4b67b268c76dbd110943557732166c70ef10412 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 20 Apr 2010 13:40:16 -0500
Subject: [PATCH 039/158] Add eval-js and eval-js-file

---
 extra/javascriptcore/ffi/ffi.factor        |  7 ++--
 extra/javascriptcore/javascriptcore.factor | 42 +++++++++++++++++++++-
 2 files changed, 45 insertions(+), 4 deletions(-)

diff --git a/extra/javascriptcore/ffi/ffi.factor b/extra/javascriptcore/ffi/ffi.factor
index 844e169eed..6489699d4d 100644
--- a/extra/javascriptcore/ffi/ffi.factor
+++ b/extra/javascriptcore/ffi/ffi.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.libraries alien.syntax
-classes.struct combinators io.encodings.utf8 system ;
+classes.struct combinators io.encodings.utf16n
+io.encodings.utf8 system ;
 IN: javascriptcore.ffi
 
 <<
@@ -9,6 +10,7 @@ IN: javascriptcore.ffi
         { [ os macosx? ] [ "/System/Library/Frameworks/JavaScriptCore.framework/Versions/Current/JavaScriptCore" ] }
         ! { [ os winnt? ]  [ "javascriptcore.dll" ] }
         ! { [ os unix? ]  [ "libsqlite3.so" ] }
+        [ ]
     } cond cdecl add-library
 >>
 
@@ -36,7 +38,6 @@ TYPEDEF: void* JSObjectHasInstanceCallback
 TYPEDEF: void* JSObjectConvertToTypeCallback
 TYPEDEF: uint unsigned
 TYPEDEF: ushort JSChar
-! char[utf16n] for strings
 
 C-ENUM: JSPropertyAttributes
     { kJSPropertyAttributeNone       0 }
@@ -202,7 +203,7 @@ FUNCTION: void JSPropertyNameAccumulatorAddName ( JSPropertyNameAccumulatorRef a
 
 FUNCTION: JSStringRef JSStringCreateWithCharacters ( JSChar* chars, size_t numChars ) ;
 
-FUNCTION: JSStringRef JSStringCreateWithUTF8CString ( c-string[utf8] string ) ;
+FUNCTION: JSStringRef JSStringCreateWithUTF8CString ( c-string string ) ;
 
 FUNCTION: JSStringRef JSStringRetain ( JSStringRef string ) ;
 
diff --git a/extra/javascriptcore/javascriptcore.factor b/extra/javascriptcore/javascriptcore.factor
index 773a559d2d..bfd222f9e8 100644
--- a/extra/javascriptcore/javascriptcore.factor
+++ b/extra/javascriptcore/javascriptcore.factor
@@ -1,8 +1,48 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: javascriptcore.ffi.hack kernel ;
+USING: alien.c-types alien.data byte-arrays continuations fry
+io.encodings.string io.encodings.utf8 io.files
+javascriptcore.ffi javascriptcore.ffi.hack kernel namespaces
+sequences ;
 IN: javascriptcore
 
 : with-javascriptcore ( quot -- )
     set-callstack-bounds
     call ; inline
+
+SYMBOL: js-context
+
+: with-global-context ( quot -- )
+    [
+        [ f JSGlobalContextCreate ] dip
+        [ '[ _ @ ] ]
+        [ drop '[ _ JSGlobalContextRelease ] ] 2bi
+        [ ] cleanup
+    ] with-scope ; inline
+
+: JSString>string ( JSString -- string )
+    dup JSStringGetMaximumUTF8CStringSize [ <byte-array> ] keep
+    [ JSStringGetUTF8CString drop ] [ drop ] 2bi
+    utf8 decode [ 0 = ] trim-tail ;
+
+: JSValueRef>string ( ctx JSValueRef/f -- string/f )
+    [
+        f JSValueToStringCopy
+        [ JSString>string ] [ JSStringRelease ] bi
+    ] [
+        drop f
+    ] if* ;
+
+: eval-js ( string -- ret/f exception/f )
+    [
+        [
+            [
+                swap JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
+                [ JSEvaluateScript ] keep *void*
+            ]
+            [ '[ [ _ ] dip JSValueRef>string ] bi@ ] bi
+        ] with-global-context
+    ] with-javascriptcore ;
+
+: eval-js-path ( path -- ret/f exception/f ) utf8 file-contents eval-js ;
+

From 73eb31a35c36b1323e34df9f0467deb43f12a7a8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 20 Apr 2010 14:21:05 -0500
Subject: [PATCH 040/158] Add unit test to javascriptcore, make eval-js throw
 errors and return a string

---
 extra/javascriptcore/javascriptcore-tests.factor | 10 ++++++++++
 extra/javascriptcore/javascriptcore.factor       | 16 ++++++++--------
 2 files changed, 18 insertions(+), 8 deletions(-)
 create mode 100644 extra/javascriptcore/javascriptcore-tests.factor

diff --git a/extra/javascriptcore/javascriptcore-tests.factor b/extra/javascriptcore/javascriptcore-tests.factor
new file mode 100644
index 0000000000..f04ada89f2
--- /dev/null
+++ b/extra/javascriptcore/javascriptcore-tests.factor
@@ -0,0 +1,10 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors javascriptcore kernel tools.test ;
+IN: javascriptcore.tests
+
+[ "2" ] [ "1+1" eval-js ] unit-test
+
+[ "1+shoes" eval-js ]
+[ error>> "ReferenceError: Can't find variable: shoes" = ] must-fail-with
+
diff --git a/extra/javascriptcore/javascriptcore.factor b/extra/javascriptcore/javascriptcore.factor
index bfd222f9e8..eabb97df61 100644
--- a/extra/javascriptcore/javascriptcore.factor
+++ b/extra/javascriptcore/javascriptcore.factor
@@ -6,6 +6,8 @@ javascriptcore.ffi javascriptcore.ffi.hack kernel namespaces
 sequences ;
 IN: javascriptcore
 
+ERROR: javascriptcore-error error ;
+
 : with-javascriptcore ( quot -- )
     set-callstack-bounds
     call ; inline
@@ -33,16 +35,14 @@ SYMBOL: js-context
         drop f
     ] if* ;
 
-: eval-js ( string -- ret/f exception/f )
-    [
+: eval-js ( string -- result-string )
+    '[
         [
-            [
-                swap JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
-                [ JSEvaluateScript ] keep *void*
-            ]
-            [ '[ [ _ ] dip JSValueRef>string ] bi@ ] bi
+            dup _ JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
+            [ JSEvaluateScript ] keep *void*
+            dup [ nip JSValueRef>string javascriptcore-error ] [ drop JSValueRef>string ] if
         ] with-global-context
     ] with-javascriptcore ;
 
-: eval-js-path ( path -- ret/f exception/f ) utf8 file-contents eval-js ;
+: eval-js-path ( path -- result-string ) utf8 file-contents eval-js ;
 

From b71933f4d7331d04851ac6a55aae21461c3f7018 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 20 Apr 2010 13:51:10 -0700
Subject: [PATCH 041/158] cuda.ptx: better representation of operands

---
 extra/cuda/ptx/ptx-tests.factor |  79 +++++++++-------
 extra/cuda/ptx/ptx.factor       | 159 ++++++++++++++++++++------------
 2 files changed, 144 insertions(+), 94 deletions(-)

diff --git a/extra/cuda/ptx/ptx-tests.factor b/extra/cuda/ptx/ptx-tests.factor
index 28391a5f58..1ba7ecfcc8 100644
--- a/extra/cuda/ptx/ptx-tests.factor
+++ b/extra/cuda/ptx/ptx-tests.factor
@@ -1,4 +1,4 @@
-USING: cuda.ptx tools.test ;
+USING: cuda.ptx io.streams.string tools.test ;
 IN: cuda.ptx.tests
 
 [ """	.version 2.0
@@ -113,6 +113,17 @@ IN: cuda.ptx.tests
     } ptx>string
 ] unit-test
 
+[ "a" ] [ [ "a" write-ptx-operand ] with-string-writer ] unit-test
+[ "2" ] [ [ 2 write-ptx-operand ] with-string-writer ] unit-test
+[ "0d4000000000000000" ] [ [ 2.0 write-ptx-operand ] with-string-writer ] unit-test
+[ "!a" ] [ [ T{ ptx-negation f "a" } write-ptx-operand ] with-string-writer ] unit-test
+[ "{a, b, c, d}" ] [ [ T{ ptx-vector f { "a" "b" "c" "d" } } write-ptx-operand ] with-string-writer ] unit-test
+[ "[a]" ] [ [ T{ ptx-indirect f "a" 0 } write-ptx-operand ] with-string-writer ] unit-test
+[ "[a+1]" ] [ [ T{ ptx-indirect f "a" 1 } write-ptx-operand ] with-string-writer ] unit-test
+[ "[a-1]" ] [ [ T{ ptx-indirect f "a" -1 } write-ptx-operand ] with-string-writer ] unit-test
+[ "a[1]" ] [ [ T{ ptx-element f "a" 1 } write-ptx-operand ] with-string-writer ] unit-test
+[ "{a, b[2], 3, 0d4000000000000000}" ] [ [ T{ ptx-vector f { "a" T{ ptx-element f "b" 2 } 3 2.0 } } write-ptx-operand ] with-string-writer ] unit-test
+
 [ """	.version 2.0
 	.target sm_20
 	abs.s32 a, b;
@@ -127,11 +138,11 @@ foo:	abs.s32 a, b;
         { body {
             T{ abs { type .s32 } { dest "a" } { a "b" } }
             T{ abs
-                { predicate T{ ptx-predicate { variable "p" } } }
+                { predicate "p" }
                 { type .s32 } { dest "a" } { a "b" }
             }
             T{ abs
-                { predicate T{ ptx-predicate { negated? t } { variable "p" } } }
+                { predicate T{ ptx-negation f "p" } }
                 { type .s32 } { dest "a" } { a "b" }
             }
             T{ abs
@@ -206,9 +217,9 @@ foo:	abs.s32 a, b;
         { version "2.0" }
         { target T{ ptx-target { arch sm_20 } } }
         { body {
-            T{ atom { op .and } { type .u32 } { dest "a" } { a "[b]" } { b "c" } }
-            T{ atom { storage-space .global } { op .or } { type .u32 } { dest "a" } { a "[b]" } { b "c" } }
-            T{ atom { storage-space .shared } { op .cas } { type .u32 } { dest "a" } { a "[b]" } { b "c" } { c "d" } }
+            T{ atom { op .and } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } { b "c" } }
+            T{ atom { storage-space .global } { op .or } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } { b "c" } }
+            T{ atom { storage-space .shared } { op .cas } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } { b "c" } { c "d" } }
 
         } }
     } ptx>string
@@ -229,8 +240,8 @@ foo:	abs.s32 a, b;
         { body {
             T{ bar.arrive { a "a" } { b "b" } }
             T{ bar.red { op .popc } { type .u32 } { dest "a" } { a "b" } { c "d" } }
-            T{ bar.red { op .popc } { type .u32 } { dest "a" } { a "b" } { c "!d" } }
-            T{ bar.red { op .popc } { type .u32 } { dest "a" } { a "b" } { b "c" } { c "!d" } }
+            T{ bar.red { op .popc } { type .u32 } { dest "a" } { a "b" } { c T{ ptx-negation f "d" } } }
+            T{ bar.red { op .popc } { type .u32 } { dest "a" } { a "b" } { b "c" } { c T{ ptx-negation f "d" } } }
             T{ bar.sync { a "a" } }
             T{ bar.sync { a "a" } { b "b" } }
         } }
@@ -327,6 +338,7 @@ foo:	abs.s32 a, b;
 	call (a), foo, (b);
 	call (a), foo, (b, c);
 	call (a), foo, (b, c, d);
+	call (a[2]), foo, (b, c, d[3]);
 	call foo, (b, c, d);
 """ ] [
     T{ ptx
@@ -339,6 +351,7 @@ foo:	abs.s32 a, b;
             T{ call { return "a" } { target "foo" } { params { "b" } } }
             T{ call { return "a" } { target "foo" } { params { "b" "c" } } }
             T{ call { return "a" } { target "foo" } { params { "b" "c" "d" } } }
+            T{ call { return T{ ptx-element f "a" 2 } } { target "foo" } { params { "b" "c" T{ ptx-element f "d" 3 } } } }
             T{ call { target "foo" } { params { "b" "c" "d" } } }
         } }
     } ptx>string
@@ -549,13 +562,13 @@ foo:	abs.s32 a, b;
         { version "2.0" }
         { target T{ ptx-target { arch sm_20 } } }
         { body {
-            T{ ld { type .u32 } { dest "a" } { a "[b]" } }
-            T{ ld { type T{ .v2 { of .u32 } } } { dest "a" } { a "[b]" } }
-            T{ ld { type T{ .v4 { of .u32 } } } { dest "a" } { a "[b]" } }
-            T{ ld { type T{ .v4 { of .u32 } } } { dest "{a, b, c, d}" } { a "[e]" } }
+            T{ ld { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
+            T{ ld { type T{ .v2 { of .u32 } } } { dest "a" } { a T{ ptx-indirect f "b" } } }
+            T{ ld { type T{ .v4 { of .u32 } } } { dest "a" } { a T{ ptx-indirect f "b" } } }
+            T{ ld { type T{ .v4 { of .u32 } } } { dest T{ ptx-vector f { "a" "b" "c" "d" } } } { a "[e]" } }
             T{ ld { cache-op .lu } { type .u32 } { dest "a" } { a "[b]" } }
-            T{ ld { storage-space T{ .const } } { cache-op .lu } { type .u32 } { dest "a" } { a "[b]" } }
-            T{ ld { volatile? t } { storage-space T{ .const { bank 5 } } } { type .u32 } { dest "a" } { a "[b]" } }
+            T{ ld { storage-space T{ .const } } { cache-op .lu } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
+            T{ ld { volatile? t } { storage-space T{ .const { bank 5 } } } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
         } }
     } ptx>string
 ] unit-test
@@ -574,13 +587,13 @@ foo:	abs.s32 a, b;
         { version "2.0" }
         { target T{ ptx-target { arch sm_20 } } }
         { body {
-            T{ ldu { type .u32 } { dest "a" } { a "[b]" } }
-            T{ ldu { type T{ .v2 { of .u32 } } } { dest "a" } { a "[b]" } }
-            T{ ldu { type T{ .v4 { of .u32 } } } { dest "a" } { a "[b]" } }
-            T{ ldu { type T{ .v4 { of .u32 } } } { dest "{a, b, c, d}" } { a "[e]" } }
+            T{ ldu { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
+            T{ ldu { type T{ .v2 { of .u32 } } } { dest "a" } { a T{ ptx-indirect f "b" } } }
+            T{ ldu { type T{ .v4 { of .u32 } } } { dest "a" } { a T{ ptx-indirect f "b" } } }
+            T{ ldu { type T{ .v4 { of .u32 } } } { dest T{ ptx-vector f { "a" "b" "c" "d" } } } { a "[e]" } }
             T{ ldu { cache-op .lu } { type .u32 } { dest "a" } { a "[b]" } }
-            T{ ldu { storage-space T{ .const } } { cache-op .lu } { type .u32 } { dest "a" } { a "[b]" } }
-            T{ ldu { volatile? t } { storage-space T{ .const { bank 5 } } } { type .u32 } { dest "a" } { a "[b]" } }
+            T{ ldu { storage-space T{ .const } } { cache-op .lu } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
+            T{ ldu { volatile? t } { storage-space T{ .const { bank 5 } } } { type .u32 } { dest "a" } { a T{ ptx-indirect f "b" } } }
         } }
     } ptx>string
 ] unit-test
@@ -723,9 +736,9 @@ foo:	abs.s32 a, b;
         { version "2.0" }
         { target T{ ptx-target { arch sm_20 } } }
         { body {
-            T{ prefetch { level .L1 } { a "[a]" } }
-            T{ prefetch { storage-space .local } { level .L2 } { a "[a]" } }
-            T{ prefetchu { level .L1 } { a "[a]" } }
+            T{ prefetch { level .L1 } { a T{ ptx-indirect f "a" } } }
+            T{ prefetch { storage-space .local } { level .L2 } { a T{ ptx-indirect f "a" } } }
+            T{ prefetchu { level .L1 } { a T{ ptx-indirect f "a" } } }
         } }
     } ptx>string
 ] unit-test
@@ -781,8 +794,8 @@ foo:	abs.s32 a, b;
         { version "2.0" }
         { target T{ ptx-target { arch sm_20 } } }
         { body {
-            T{ red { op .and } { type .u32 } { dest "[a]" } { a "b" } }
-            T{ red { storage-space .global } { op .and } { type .u32 } { dest "[a]" } { a "b" } }
+            T{ red { op .and } { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
+            T{ red { storage-space .global } { op .and } { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
         } }
     } ptx>string
 ] unit-test
@@ -861,7 +874,7 @@ foo:	abs.s32 a, b;
             T{ set { cmp-op .gt } { dest-type .u32 } { type .s32 } { dest "a" } { a "b" } { b "c" } }
             T{ set { cmp-op .gt } { ftz? t } { dest-type .u32 } { type .f32 } { dest "a" } { a "b" } { b "c" } }
             T{ set { cmp-op .gt } { bool-op .and } { ftz? t } { dest-type .u32 } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "d" } }
-            T{ set { cmp-op .gt } { bool-op .and } { ftz? t } { dest-type .u32 } { type .f32 } { dest "a" } { a "b" } { b "c" } { c "!d" } }
+            T{ set { cmp-op .gt } { bool-op .and } { ftz? t } { dest-type .u32 } { type .f32 } { dest "a" } { a "b" } { b "c" } { c T{ ptx-negation f "d" } } }
         } }
     } ptx>string
 ] unit-test
@@ -982,13 +995,13 @@ foo:	abs.s32 a, b;
         { version "2.0" }
         { target T{ ptx-target { arch sm_20 } } }
         { body {
-            T{ st { type .u32 } { dest "[a]" } { a "b" } }
-            T{ st { type T{ .v2 { of .u32 } } } { dest "[a]" } { a "b" } }
-            T{ st { type T{ .v4 { of .u32 } } } { dest "[a]" } { a "b" } }
-            T{ st { type T{ .v4 { of .u32 } } } { dest "[a]" } { a "{b, c, d, e}" } }
-            T{ st { cache-op .lu } { type .u32 } { dest "[a]" } { a "b" } }
-            T{ st { storage-space .local } { cache-op .lu } { type .u32 } { dest "[a]" } { a "b" } }
-            T{ st { volatile? t } { storage-space .local } { type .u32 } { dest "[a]" } { a "b" } }
+            T{ st { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
+            T{ st { type T{ .v2 { of .u32 } } } { dest T{ ptx-indirect f "a" } } { a "b" } }
+            T{ st { type T{ .v4 { of .u32 } } } { dest T{ ptx-indirect f "a" } } { a "b" } }
+            T{ st { type T{ .v4 { of .u32 } } } { dest T{ ptx-indirect f "a" } } { a T{ ptx-vector f { "b" "c" "d" "e" } } } }
+            T{ st { cache-op .lu } { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
+            T{ st { storage-space .local } { cache-op .lu } { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
+            T{ st { volatile? t } { storage-space .local } { type .u32 } { dest T{ ptx-indirect f "a" } } { a "b" } }
         } }
     } ptx>string
 ] unit-test
diff --git a/extra/cuda/ptx/ptx.factor b/extra/cuda/ptx/ptx.factor
index 4618f8b5b6..49a53d7fbf 100644
--- a/extra/cuda/ptx/ptx.factor
+++ b/extra/cuda/ptx/ptx.factor
@@ -64,14 +64,30 @@ TUPLE: ptx-variable
     { initializer ?string } ;
 UNION: ?ptx-variable POSTPONE: f ptx-variable ;
 
-TUPLE: ptx-predicate
-    { negated? boolean }
-    { variable string } ; 
-UNION: ?ptx-predicate POSTPONE: f ptx-predicate ;
+TUPLE: ptx-negation
+    { var string } ; 
+
+TUPLE: ptx-vector
+    elements ;
+
+TUPLE: ptx-element
+    { var string }
+    { index integer } ;
+
+UNION: ptx-var
+    string ptx-element ;
+
+TUPLE: ptx-indirect
+    { base ptx-var }
+    { offset integer } ;
+
+UNION: ptx-operand
+    integer float ptx-var ptx-negation ptx-vector ptx-indirect ;
+UNION: ?ptx-operand POSTPONE: f ptx-operand ;
 
 TUPLE: ptx-instruction
     { label ?string }
-    { predicate ?ptx-predicate } ;
+    { predicate ?ptx-operand } ;
 
 TUPLE: ptx-entry
     { name string }
@@ -112,25 +128,25 @@ UNION: ?ptx-rounding-mode POSTPONE: f ptx-rounding-mode ;
 
 TUPLE: ptx-typed-instruction < ptx-instruction
     { type ptx-type }
-    { dest string } ;
+    { dest ptx-operand } ;
 
 TUPLE: ptx-2op-instruction < ptx-typed-instruction
-    { a string } ;
+    { a ptx-operand } ;
 
 TUPLE: ptx-3op-instruction < ptx-typed-instruction
-    { a string }
-    { b string } ;
+    { a ptx-operand }
+    { b ptx-operand } ;
 
 TUPLE: ptx-4op-instruction < ptx-typed-instruction
-    { a string }
-    { b string }
-    { c string } ;
+    { a ptx-operand }
+    { b ptx-operand }
+    { c ptx-operand } ;
 
 TUPLE: ptx-5op-instruction < ptx-typed-instruction
-    { a string }
-    { b string }
-    { c string }
-    { d string } ;
+    { a ptx-operand }
+    { b ptx-operand }
+    { c ptx-operand }
+    { d ptx-operand } ;
 
 TUPLE: ptx-addsub-instruction < ptx-3op-instruction
     { sat? boolean }
@@ -181,7 +197,7 @@ INSTANCE: .hi ptx-cmp-op
 TUPLE: ptx-set-instruction < ptx-3op-instruction
     { cmp-op ptx-cmp-op }
     { bool-op ?ptx-op }
-    { c ?string }
+    { c ?ptx-operand }
     { ftz? boolean } ;
 
 VARIANT: ptx-cache-op
@@ -216,17 +232,17 @@ TUPLE: and       < ptx-3op-instruction ;
 TUPLE: atom      < ptx-3op-instruction
     { storage-space ?ptx-storage-space }
     { op ptx-op }
-    { c ?string } ;
+    { c ?ptx-operand } ;
 TUPLE: bar.arrive < ptx-instruction
-    { a string }
-    { b string } ;
+    { a ptx-operand }
+    { b ptx-operand } ;
 TUPLE: bar.red   < ptx-2op-instruction
     { op ptx-op }
-    { b ?string }
-    { c string } ;
+    { b ?ptx-operand }
+    { c ptx-operand } ;
 TUPLE: bar.sync  < ptx-instruction
-    { a string }
-    { b ?string } ;
+    { a ptx-operand }
+    { b ?ptx-operand } ;
 TUPLE: bfe       < ptx-4op-instruction ;
 TUPLE: bfi       < ptx-5op-instruction ;
 TUPLE: bfind     < ptx-2op-instruction
@@ -235,7 +251,7 @@ TUPLE: bra       < ptx-branch-instruction ;
 TUPLE: brev      < ptx-2op-instruction ;
 TUPLE: brkpt     < ptx-instruction ;
 TUPLE: call      < ptx-branch-instruction
-    { return ?string }
+    { return ?ptx-operand }
     params ;
 TUPLE: clz       < ptx-2op-instruction ;
 TUPLE: cnot      < ptx-2op-instruction ;
@@ -255,8 +271,8 @@ TUPLE: exit      < ptx-instruction ;
 TUPLE: fma       <{ ptx-mad-instruction ptx-float-env } ;
 TUPLE: isspacep  < ptx-instruction
     { storage-space ptx-storage-space }
-    { dest string }
-    { a string } ;
+    { dest ptx-operand }
+    { a ptx-operand } ;
 TUPLE: ld        < ptx-ldst-instruction ;
 TUPLE: ldu       < ptx-ldst-instruction ;
 TUPLE: lg2       <{ ptx-2op-instruction ptx-float-env } ;
@@ -273,14 +289,14 @@ TUPLE: neg       <{ ptx-2op-instruction ptx-float-ftz } ;
 TUPLE: not       < ptx-2op-instruction ;
 TUPLE: or        < ptx-3op-instruction ;
 TUPLE: pmevent   < ptx-instruction
-    { a string } ;
+    { a ptx-operand } ;
 TUPLE: popc      < ptx-2op-instruction ;
 TUPLE: prefetch  < ptx-instruction
-    { a string }
+    { a ptx-operand }
     { storage-space ?ptx-storage-space }
     { level ptx-cache-level } ;
 TUPLE: prefetchu < ptx-instruction
-    { a string }
+    { a ptx-operand }
     { level ptx-cache-level } ;
 TUPLE: prmt      < ptx-4op-instruction
     { mode ?ptx-prmt-mode } ;
@@ -296,7 +312,7 @@ TUPLE: selp      < ptx-4op-instruction ;
 TUPLE: set       < ptx-set-instruction
     { dest-type ptx-type } ;
 TUPLE: setp      < ptx-set-instruction
-    { |dest ?string } ;
+    { |dest ?ptx-operand } ;
 TUPLE: shl       < ptx-3op-instruction ;
 TUPLE: shr       < ptx-3op-instruction ;
 TUPLE: sin       <{ ptx-2op-instruction ptx-float-env } ;
@@ -340,6 +356,27 @@ M: ptx-func ptx-semicolon? drop f ;
 M: .file ptx-semicolon? drop f ;
 M: .loc ptx-semicolon? drop f ;
 
+GENERIC: write-ptx-operand ( operand -- )
+
+M: string write-ptx-operand write ;
+M: integer write-ptx-operand number>string write ;
+M: float write-ptx-operand "0d" write double>bits >hex 16 CHAR: 0 pad-head write ;
+M: ptx-negation write-ptx-operand "!" write var>> write ;
+M: ptx-vector write-ptx-operand
+    "{" write
+    elements>> [ ", " write ] [ write-ptx-operand ] interleave
+    "}" write ;
+M: ptx-element write-ptx-operand dup var>> write "[" write index>> number>string write "]" write ;
+M: ptx-indirect write-ptx-operand
+    "[" write
+    dup base>> write-ptx-operand
+    offset>> {
+        { [ dup zero? ] [ drop ] }
+        { [ dup 0 < ] [ number>string write ] }
+        [ "+" write number>string write ]
+    } cond
+    "]" write ;
+
 GENERIC: (write-ptx-element) ( elt -- )
 
 : write-ptx-element ( elt -- )
@@ -376,7 +413,7 @@ M: ptx-target (write-ptx-element)
     [ arch>> [ name>> ] [ f ] if* ]
     [ map_f64_to_f32?>> [ "map_f64_to_f32" ] [ f ] if ]
     [ texmode>> [ name>> ] [ f ] if* ] tri
-    3array sift ", " join write ;
+    3array sift [ ", " write ] [ write ] interleave ;
 
 : write-ptx-dim ( dim -- )
     {
@@ -435,7 +472,7 @@ M: .maxnreg (write-ptx-element)
     ".maxnreg " write n>> number>string write ;
 M: .maxntid (write-ptx-element)
     ".maxntid " write
-    dup sequence? [ [ number>string ] map ", " join write ] [ number>string write ] if ;
+    dup sequence? [ [ ", " write ] [ number>string write ] interleave ] [ number>string write ] if ;
 M: .pragma (write-ptx-element)
     ".pragma \"" write pragma>> write "\"" write ;
 
@@ -444,28 +481,28 @@ M: ptx-instruction ptx-element-label
 
 : write-insn ( insn name -- insn )
     over predicate>>
-    [ "@" write dup negated?>> [ "!" write ] when variable>> write " " write ] when*
+    [ "@" write write-ptx-operand " " write ] when*
     write ;
 
 : write-2op ( insn -- )
     dup type>> (write-ptx-element) " " write
-    dup dest>> write ", " write
-    dup a>> write
+    dup dest>> write-ptx-operand ", " write
+    dup a>> write-ptx-operand
     drop ;
 
 : write-3op ( insn -- )
     dup write-2op ", " write
-    dup b>> write
+    dup b>> write-ptx-operand
     drop ;
 
 : write-4op ( insn -- )
     dup write-3op ", " write
-    dup c>> write
+    dup c>> write-ptx-operand
     drop ;
 
 : write-5op ( insn -- )
     dup write-4op ", " write
-    dup d>> write
+    dup d>> write-ptx-operand
     drop ;
 
 : write-ftz ( insn -- )
@@ -534,22 +571,22 @@ M: atom (write-ptx-element)
     dup storage-space>> (write-ptx-element)
     dup op>> (write-ptx-element)
     dup write-3op
-    c>> [ ", " write write ] when* ;
+    c>> [ ", " write write-ptx-operand ] when* ;
 M: bar.arrive (write-ptx-element)
     "bar.arrive " write-insn
-    dup a>> write ", " write
-    dup b>> write
+    dup a>> write-ptx-operand ", " write
+    dup b>> write-ptx-operand
     drop ;
 M: bar.red (write-ptx-element)
     "bar.red" write-insn
     dup op>> (write-ptx-element)
     dup write-2op
-    dup b>> [ ", " write write ] when*
-    ", " write c>> write ;
+    dup b>> [ ", " write write-ptx-operand ] when*
+    ", " write c>> write-ptx-operand ;
 M: bar.sync (write-ptx-element)
     "bar.sync " write-insn
-    dup a>> write
-    dup b>> [ ", " write write ] when*
+    dup a>> write-ptx-operand
+    dup b>> [ ", " write write-ptx-operand ] when*
     drop ;
 M: bfe (write-ptx-element)
     "bfe" write-insn
@@ -573,9 +610,9 @@ M: brkpt (write-ptx-element)
 M: call (write-ptx-element)
     "call" write-insn
     dup write-uni " " write
-    dup return>> [ "(" write write "), " write ] when*
+    dup return>> [ "(" write write-ptx-operand "), " write ] when*
     dup target>> write
-    dup params>> [ ", (" write ", " join write ")" write ] unless-empty
+    dup params>> [ ", (" write [ ", " write ] [ write-ptx-operand ] interleave ")" write ] unless-empty
     drop ;
 M: clz (write-ptx-element)
     "clz" write-insn
@@ -619,7 +656,7 @@ M: isspacep (write-ptx-element)
     "isspacep" write-insn
     dup storage-space>> (write-ptx-element)
     " " write
-    dup dest>> write ", " write a>> write ;
+    dup dest>> write-ptx-operand ", " write a>> write-ptx-operand ;
 M: ld (write-ptx-element)
     "ld" write-insn
     write-ldst ;
@@ -679,19 +716,19 @@ M: prefetch (write-ptx-element)
     "prefetch" write-insn
     dup storage-space>> (write-ptx-element)
     dup level>> (write-ptx-element)
-    " " write a>> write ;
+    " " write a>> write-ptx-operand ;
 M: prefetchu (write-ptx-element)
     "prefetchu" write-insn
     dup level>> (write-ptx-element)
-    " " write a>> write ;
+    " " write a>> write-ptx-operand ;
 M: prmt (write-ptx-element)
     "prmt" write-insn
     dup type>> (write-ptx-element)
     dup mode>> (write-ptx-element) " " write
-    dup dest>> write ", " write
-    dup a>> write ", " write
-    dup b>> write ", " write
-    dup c>> write
+    dup dest>> write-ptx-operand ", " write
+    dup a>> write-ptx-operand ", " write
+    dup b>> write-ptx-operand ", " write
+    dup c>> write-ptx-operand
     drop ;
 M: rcp (write-ptx-element)
     "rcp" write-insn
@@ -722,16 +759,16 @@ M: set (write-ptx-element)
     dup write-set
     dup dest-type>> (write-ptx-element)
     dup write-3op
-    c>> [ ", " write write ] when* ;
+    c>> [ ", " write write-ptx-operand ] when* ;
 M: setp (write-ptx-element)
     "setp" write-insn
     dup write-set
     dup type>> (write-ptx-element) " " write
-    dup dest>> write
-    dup |dest>> [ "|" write write ] when* ", " write
-    dup a>> write ", " write
-    dup b>> write
-    c>> [ ", " write write ] when* ;
+    dup dest>> write-ptx-operand
+    dup |dest>> [ "|" write write-ptx-operand ] when* ", " write
+    dup a>> write-ptx-operand ", " write
+    dup b>> write-ptx-operand
+    c>> [ ", " write write-ptx-operand ] when* ;
 M: shl (write-ptx-element)
     "shl" write-insn
     write-3op ;

From 6ecf43b91f777670fae1125738cebba22dc88eae Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 20 Apr 2010 16:04:35 -0500
Subject: [PATCH 042/158] fix add-library in javascriptcore

---
 extra/javascriptcore/ffi/ffi.factor | 14 ++++++++------
 1 file changed, 8 insertions(+), 6 deletions(-)

diff --git a/extra/javascriptcore/ffi/ffi.factor b/extra/javascriptcore/ffi/ffi.factor
index 6489699d4d..7a038b0883 100644
--- a/extra/javascriptcore/ffi/ffi.factor
+++ b/extra/javascriptcore/ffi/ffi.factor
@@ -2,16 +2,18 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.libraries alien.syntax
 classes.struct combinators io.encodings.utf16n
-io.encodings.utf8 system ;
+io.encodings.utf8 kernel system ;
 IN: javascriptcore.ffi
 
 <<
 "javascriptcore" {
-        { [ os macosx? ] [ "/System/Library/Frameworks/JavaScriptCore.framework/Versions/Current/JavaScriptCore" ] }
-        ! { [ os winnt? ]  [ "javascriptcore.dll" ] }
-        ! { [ os unix? ]  [ "libsqlite3.so" ] }
-        [ ]
-    } cond cdecl add-library
+    { [ os macosx? ] [
+        "/System/Library/Frameworks/JavaScriptCore.framework/Versions/Current/JavaScriptCore" cdecl add-library
+    ] }
+    ! { [ os winnt? ]  [ "javascriptcore.dll" ] }
+    ! { [ os unix? ]  [ "libsqlite3.so" ] }
+    [ drop ]
+} cond
 >>
 
 LIBRARY: javascriptcore

From b32782ac9b5729da2a73134d28828b43c5593581 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 20 Apr 2010 17:25:28 -0500
Subject: [PATCH 043/158] Move the guts of eval-js to its own word, add
 eval-js-standalone for unit tests

---
 .../javascriptcore/javascriptcore-tests.factor  |  4 ++--
 extra/javascriptcore/javascriptcore.factor      | 17 ++++++++---------
 2 files changed, 10 insertions(+), 11 deletions(-)

diff --git a/extra/javascriptcore/javascriptcore-tests.factor b/extra/javascriptcore/javascriptcore-tests.factor
index f04ada89f2..53ae12d2b0 100644
--- a/extra/javascriptcore/javascriptcore-tests.factor
+++ b/extra/javascriptcore/javascriptcore-tests.factor
@@ -3,8 +3,8 @@
 USING: accessors javascriptcore kernel tools.test ;
 IN: javascriptcore.tests
 
-[ "2" ] [ "1+1" eval-js ] unit-test
+[ "2" ] [ "1+1" eval-js-standalone ] unit-test
 
-[ "1+shoes" eval-js ]
+[ "1+shoes" eval-js-standalone ]
 [ error>> "ReferenceError: Can't find variable: shoes" = ] must-fail-with
 
diff --git a/extra/javascriptcore/javascriptcore.factor b/extra/javascriptcore/javascriptcore.factor
index eabb97df61..65b6fe5fff 100644
--- a/extra/javascriptcore/javascriptcore.factor
+++ b/extra/javascriptcore/javascriptcore.factor
@@ -35,14 +35,13 @@ SYMBOL: js-context
         drop f
     ] if* ;
 
-: eval-js ( string -- result-string )
-    '[
-        [
-            dup _ JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
-            [ JSEvaluateScript ] keep *void*
-            dup [ nip JSValueRef>string javascriptcore-error ] [ drop JSValueRef>string ] if
-        ] with-global-context
-    ] with-javascriptcore ;
+: eval-js ( context string -- result-string )
+    dupd JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
+    [ JSEvaluateScript ] keep *void*
+    dup [ nip JSValueRef>string javascriptcore-error ] [ drop JSValueRef>string ] if ;
 
-: eval-js-path ( path -- result-string ) utf8 file-contents eval-js ;
+: eval-js-standalone ( string -- result-string )
+    '[ [ _ eval-js ] with-global-context ] with-javascriptcore ;
+
+: eval-js-path-standalone ( path -- result-string ) utf8 file-contents eval-js-standalone ;
 

From 78e26edb9a7829821caddbb0205650dd584c4887 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 20 Apr 2010 15:28:09 -0700
Subject: [PATCH 044/158] GNUmakefile: build factor shared library by default
 again

---
 GNUmakefile | 42 +++++++++++++++++++++++-------------------
 1 file changed, 23 insertions(+), 19 deletions(-)

diff --git a/GNUmakefile b/GNUmakefile
index 30f44e9eba..300a62f71c 100755
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -106,61 +106,63 @@ help:
 	@echo "NO_UI=1  don't link with X11 libraries (ignored on Mac OS X)"
 	@echo "X11=1  force link with X11 libraries instead of Cocoa (only on Mac OS X)"
 
+ALL = factor factor-ffi-test factor-lib
+
 openbsd-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.32
 
 openbsd-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.openbsd.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.openbsd.x86.64
 
 freebsd-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.32
 
 freebsd-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.freebsd.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.freebsd.x86.64
 
 netbsd-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.32
 
 netbsd-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.netbsd.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.netbsd.x86.64
 
 macosx-ppc:
-	$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.ppc
+	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.ppc
 
 macosx-x86-32:
-	$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.32
+	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.32
 
 macosx-x86-64:
-	$(MAKE) factor factor-ffi-test macosx.app CONFIG=vm/Config.macosx.x86.64
+	$(MAKE) $(ALL) macosx.app CONFIG=vm/Config.macosx.x86.64
 
 linux-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.32
 
 linux-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.x86.64
 
 linux-ppc:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.ppc
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.ppc
 
 linux-arm:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.linux.arm
+	$(MAKE) $(ALL) CONFIG=vm/Config.linux.arm
 
 solaris-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.32
 
 solaris-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.solaris.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.solaris.x86.64
 
 winnt-x86-32:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.32
+	$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.32
 	$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.32
 
 winnt-x86-64:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.nt.x86.64
+	$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.64
 	$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
 
 wince-arm:
-	$(MAKE) factor factor-ffi-test CONFIG=vm/Config.windows.ce.arm
+	$(MAKE) $(ALL) CONFIG=vm/Config.windows.ce.arm
 
 ifdef CONFIG
 
@@ -173,6 +175,8 @@ macosx.app: factor
 $(ENGINE): $(DLL_OBJS)
 	$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
 
+factor-lib: $(ENGINE)
+
 factor: $(EXE_OBJS) $(DLL_OBJS)
 	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
 		$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
@@ -217,4 +221,4 @@ clean:
 tags:
 	etags vm/*.{cpp,hpp,mm,S,c}
 
-.PHONY: factor factor-console factor-ffi-test tags clean macosx.app
+.PHONY: factor factor-lib factor-console factor-ffi-test tags clean macosx.app

From 54134f90f5d633d9de2cb5b0234c7856a8bd5cd1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 20 Apr 2010 17:30:02 -0500
Subject: [PATCH 045/158] use js-context in eval-js

---
 extra/javascriptcore/javascriptcore.factor | 19 ++++++++++---------
 1 file changed, 10 insertions(+), 9 deletions(-)

diff --git a/extra/javascriptcore/javascriptcore.factor b/extra/javascriptcore/javascriptcore.factor
index 65b6fe5fff..738f1749bc 100644
--- a/extra/javascriptcore/javascriptcore.factor
+++ b/extra/javascriptcore/javascriptcore.factor
@@ -8,20 +8,20 @@ IN: javascriptcore
 
 ERROR: javascriptcore-error error ;
 
-: with-javascriptcore ( quot -- )
-    set-callstack-bounds
-    call ; inline
-
 SYMBOL: js-context
 
 : with-global-context ( quot -- )
     [
-        [ f JSGlobalContextCreate ] dip
-        [ '[ _ @ ] ]
+        [ f JSGlobalContextCreate dup js-context set ] dip
+        [ nip '[ @ ] ]
         [ drop '[ _ JSGlobalContextRelease ] ] 2bi
         [ ] cleanup
     ] with-scope ; inline
 
+: with-javascriptcore ( quot -- )
+    set-callstack-bounds
+    with-global-context ; inline
+
 : JSString>string ( JSString -- string )
     dup JSStringGetMaximumUTF8CStringSize [ <byte-array> ] keep
     [ JSStringGetUTF8CString drop ] [ drop ] 2bi
@@ -35,13 +35,14 @@ SYMBOL: js-context
         drop f
     ] if* ;
 
-: eval-js ( context string -- result-string )
-    dupd JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
+: eval-js ( string -- result-string )
+    [ js-context get dup ] dip
+    JSStringCreateWithUTF8CString f f 0 JSValueRef <c-object>
     [ JSEvaluateScript ] keep *void*
     dup [ nip JSValueRef>string javascriptcore-error ] [ drop JSValueRef>string ] if ;
 
 : eval-js-standalone ( string -- result-string )
-    '[ [ _ eval-js ] with-global-context ] with-javascriptcore ;
+    '[ _ eval-js ] with-javascriptcore ;
 
 : eval-js-path-standalone ( path -- result-string ) utf8 file-contents eval-js-standalone ;
 

From f9668be81419fefb28ce8c0cbc982c7f724f98ae Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 20 Apr 2010 17:05:14 -0700
Subject: [PATCH 046/158] alien.enums: make enum>number foldable so it
 optimizes constant enums to constant ints, make number>enum a macro so it
 doesn't use c-type metadata at runtime

---
 basis/alien/enums/enums.factor | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/basis/alien/enums/enums.factor b/basis/alien/enums/enums.factor
index 6920a7742d..d8c1a02c69 100644
--- a/basis/alien/enums/enums.factor
+++ b/basis/alien/enums/enums.factor
@@ -1,6 +1,6 @@
 ! (c)2010 Joe Groff, Erik Charlebois bsd license
 USING: accessors alien.c-types arrays classes.singleton combinators
-delegate fry generic.parser kernel math parser sequences words ;
+delegate fry generic.parser kernel macros math parser sequences words ;
 IN: alien.enums
 
 <PRIVATE
@@ -10,18 +10,18 @@ CONSULT: c-type-protocol enum-c-type
     base-type>> ;
 PRIVATE>
 
-GENERIC: enum>number ( enum -- number )
+GENERIC: enum>number ( enum -- number ) foldable
 M: integer enum>number ;
 
-: number>enum ( number enum-c-type -- enum )
-    c-type-boxer-quot call( x -- y ) ; inline
-
 <PRIVATE
 : enum-boxer ( members -- quot )
     [ first2 swap '[ _ ] 2array ]
     { } map-as [ ] suffix '[ _ case ] ;
 PRIVATE>
 
+MACRO: number>enum ( enum-c-type -- )
+    c-type members>> enum-boxer ;
+
 M: enum-c-type c-type-boxed-class drop object ;
 M: enum-c-type c-type-boxer-quot members>> enum-boxer ;
 M: enum-c-type c-type-unboxer-quot drop [ enum>number ] ;
@@ -42,7 +42,7 @@ M: enum-c-type c-type-setter
 
 : define-enum-constructor ( word -- )
     [ name>> "<" ">" surround create-in ] keep
-    [ number>enum ] curry (( enum -- number )) define-inline ;
+    [ number>enum ] curry (( number -- enum )) define-inline ;
 
 PRIVATE>
 

From e3e19ddc6758e2356ae89e460039901ccef9bbab Mon Sep 17 00:00:00 2001
From: Erik Charlebois <erikcharlebois@gmail.com>
Date: Tue, 20 Apr 2010 22:27:52 -0700
Subject: [PATCH 047/158] Remove redundant vocab usage in model-viewer

---
 extra/model-viewer/model-viewer.factor | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/extra/model-viewer/model-viewer.factor b/extra/model-viewer/model-viewer.factor
index f1b184f220..606eada523 100644
--- a/extra/model-viewer/model-viewer.factor
+++ b/extra/model-viewer/model-viewer.factor
@@ -8,8 +8,7 @@ io io.encodings.ascii io.files io.files.temp kernel locals math
 math.matrices math.vectors.simd math.parser math.vectors
 method-chains namespaces sequences splitting threads ui ui.gadgets
 ui.gadgets.worlds ui.pixel-formats specialized-arrays
-specialized-vectors literals fry
-sequences.deep destructors math.bitwise opengl.gl
+specialized-vectors fry sequences.deep destructors math.bitwise opengl.gl
 game.models game.models.obj game.models.loader game.models.collada
 prettyprint images.tga literals ;
 FROM: alien.c-types => float ;

From ddfeee462100fb65950d653e3497e336cbccee30 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 21 Apr 2010 00:29:43 -0500
Subject: [PATCH 048/158] Add a 'not tested' tag to javascriptcore

---
 extra/javascriptcore/tags.txt | 1 +
 1 file changed, 1 insertion(+)
 create mode 100644 extra/javascriptcore/tags.txt

diff --git a/extra/javascriptcore/tags.txt b/extra/javascriptcore/tags.txt
new file mode 100644
index 0000000000..700f0dc9a5
--- /dev/null
+++ b/extra/javascriptcore/tags.txt
@@ -0,0 +1 @@
+not tested

From c5530080c47651ec869633432c7125c8339abbef Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Wed, 21 Apr 2010 00:40:40 -0500
Subject: [PATCH 049/158] Fixing issue where require-when could create a
 circularity

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

diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 2945736f3c..535932fdc7 100644
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -75,7 +75,7 @@ require-when-table [ V{ } clone ] initialize
 : load-conditional-requires ( vocab -- )
     vocab-name require-when-vocabs get in? [
         require-when-table get [
-            [ [ vocab ] all? ] dip
+            [ [ vocab dup [ source-loaded?>> +done+ = ] when ] all? ] dip
             [ require ] curry when
         ] assoc-each
     ] when ;

From eefc8b6e2f962b7ec1b1645c34a83a982a210c8c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 21 Apr 2010 00:41:30 -0500
Subject: [PATCH 050/158] Fix C-ENUM: -> ENUM:

---
 extra/javascriptcore/ffi/ffi.factor | 6 +++---
 extra/javascriptcore/platforms.txt  | 1 +
 extra/javascriptcore/tags.txt       | 1 -
 3 files changed, 4 insertions(+), 4 deletions(-)
 create mode 100644 extra/javascriptcore/platforms.txt
 delete mode 100644 extra/javascriptcore/tags.txt

diff --git a/extra/javascriptcore/ffi/ffi.factor b/extra/javascriptcore/ffi/ffi.factor
index 7a038b0883..02847e2fa8 100644
--- a/extra/javascriptcore/ffi/ffi.factor
+++ b/extra/javascriptcore/ffi/ffi.factor
@@ -41,17 +41,17 @@ TYPEDEF: void* JSObjectConvertToTypeCallback
 TYPEDEF: uint unsigned
 TYPEDEF: ushort JSChar
 
-C-ENUM: JSPropertyAttributes
+ENUM: JSPropertyAttributes
     { kJSPropertyAttributeNone       0 }
     { kJSPropertyAttributeReadOnly   2 }
     { kJSPropertyAttributeDontEnum   4 }
     { kJSPropertyAttributeDontDelete 8 } ;
 
-C-ENUM: JSClassAttributes
+ENUM: JSClassAttributes
     { kJSClassAttributeNone 0 }
     { kJSClassAttributeNoAutomaticPrototype 2 } ;
 
-C-ENUM: JSType
+ENUM: JSType
     kJSTypeUndefined,
     kJSTypeNull,
     kJSTypeBoolean,
diff --git a/extra/javascriptcore/platforms.txt b/extra/javascriptcore/platforms.txt
new file mode 100644
index 0000000000..6e806f449e
--- /dev/null
+++ b/extra/javascriptcore/platforms.txt
@@ -0,0 +1 @@
+macosx
diff --git a/extra/javascriptcore/tags.txt b/extra/javascriptcore/tags.txt
deleted file mode 100644
index 700f0dc9a5..0000000000
--- a/extra/javascriptcore/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-not tested

From 33cf10e922e32e220f41dc40dbb08365bb7dfa1c Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 20 Apr 2010 22:48:28 -0700
Subject: [PATCH 051/158] lua: clean up some literals abuse

---
 extra/lua/lua.factor | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/extra/lua/lua.factor b/extra/lua/lua.factor
index 730979e68e..fa997b1d65 100644
--- a/extra/lua/lua.factor
+++ b/extra/lua/lua.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.accessors alien.c-types alien.libraries
 alien.syntax classes.struct combinators io.encodings.ascii kernel
-literals locals math system ;
+locals math system ;
 IN: lua
 
 << "liblua5.1" {
@@ -19,12 +19,12 @@ TYPEDEF: ptrdiff_t LUA_INTEGER
 CONSTANT: LUA_IDSIZE 60
 
 ! This is normally the BUFSIZ value of the given platform.
-CONSTANT: LUAL_BUFFERSIZE $[
+: LUAL_BUFFERSIZE ( -- x )
     {
         { [ os windows? ] [ 512 ] }
         { [ os macosx? ] [ 1024 ] }
         { [ os unix? ] [ 8192 ] }
-    } cond ] 
+    } cond ;
 
 ! lua.h
 CONSTANT: LUA_SIGNATURE B{ 27 76 117 97 }
@@ -207,7 +207,7 @@ STRUCT: lua_Debug
 : luaL_getn ( L i -- int ) lua_objlen ; inline
 : luaL_setn ( L i j -- ) 3drop ; inline
  
-CONSTANT: LUA_ERRFILE $[ $ LUA_ERRERR 1 + ]
+: LUA_ERRFILE ( -- x ) LUA_ERRERR 1 + ;
 
 STRUCT: luaL_Reg
     { name char*         }

From 339952697fa0a159600d4b400216aa9528c46b2f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 21 Apr 2010 21:32:33 -0500
Subject: [PATCH 052/158] Fix alien.enum docs

---
 basis/alien/enums/enums-docs.factor | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/basis/alien/enums/enums-docs.factor b/basis/alien/enums/enums-docs.factor
index 86c8503c61..8a689fe9c4 100644
--- a/basis/alien/enums/enums-docs.factor
+++ b/basis/alien/enums/enums-docs.factor
@@ -23,8 +23,11 @@ HELP: number>enum
 }
 { $description "Convert a number to an enum." } ;
 
-ARTICLE: "alien.enums" "alien.enums"
+ARTICLE: "alien.enums" "Alien Enumerations"
 { $vocab-link "alien.enums" }
-;
+"Defining enums at run-time:"
+{ $subsection define-enum }
+"Conversions between enums and integers:"
+{ $subsections enum>number number>enum } ;
 
 ABOUT: "alien.enums"

From 4c7ab0e9a3786f761d8d4f39c31d46a8d95c5bf9 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 21 Apr 2010 21:33:04 -0700
Subject: [PATCH 053/158] doll up ENUM: docs

---
 basis/alien/data/data-docs.factor     |  2 +-
 basis/alien/enums/enums-docs.factor   | 11 +++++++----
 basis/alien/syntax/syntax-docs.factor |  2 +-
 3 files changed, 9 insertions(+), 6 deletions(-)

diff --git a/basis/alien/data/data-docs.factor b/basis/alien/data/data-docs.factor
index c5130001d9..1401190f45 100644
--- a/basis/alien/data/data-docs.factor
+++ b/basis/alien/data/data-docs.factor
@@ -105,7 +105,7 @@ $nl
 "Important guidelines for passing data in byte arrays:"
 { $subsections "byte-arrays-gc" }
 "C-style enumerated types are supported:"
-{ $subsections POSTPONE: ENUM: }
+{ $subsections "alien.enums" POSTPONE: ENUM: }
 "C types can be aliased for convenience and consistency with native library documentation:"
 { $subsections POSTPONE: TYPEDEF: }
 "A utility for defining " { $link "destructors" } " for deallocating memory:"
diff --git a/basis/alien/enums/enums-docs.factor b/basis/alien/enums/enums-docs.factor
index 8a689fe9c4..cc23a40df3 100644
--- a/basis/alien/enums/enums-docs.factor
+++ b/basis/alien/enums/enums-docs.factor
@@ -1,13 +1,13 @@
 ! Copyright (C) 2010 Erik Charlebois.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types help.markup help.syntax words ;
+USING: alien.c-types alien.syntax help.markup help.syntax words ;
 IN: alien.enums
 
 HELP: define-enum
 { $values
     { "word" word } { "base-type" c-type } { "members" "sequence of word and value pairs" }
 }
-{ $description "Defines an enum. This is the run-time equivalent of ENUM:." } ;
+{ $description "Defines an enum. This is the run-time equivalent of " { $link POSTPONE: ENUM: } "." } ;
 
 HELP: enum>number
 { $values
@@ -23,11 +23,14 @@ HELP: number>enum
 }
 { $description "Convert a number to an enum." } ;
 
-ARTICLE: "alien.enums" "Alien Enumerations"
-{ $vocab-link "alien.enums" }
+ARTICLE: "alien.enums" "Enumeration types"
+"The " { $vocab-link "alien.enums" } " vocab contains the implementation for " { $link POSTPONE: ENUM: } " C types, and provides words for converting between enum symbols and integers."
+$nl
 "Defining enums at run-time:"
 { $subsection define-enum }
 "Conversions between enums and integers:"
 { $subsections enum>number number>enum } ;
 
+{ POSTPONE: ENUM: define-enum enum>number number>enum } related-words
+
 ABOUT: "alien.enums"
diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor
index f93f1fb3b8..c960984d53 100644
--- a/basis/alien/syntax/syntax-docs.factor
+++ b/basis/alien/syntax/syntax-docs.factor
@@ -72,7 +72,7 @@ HELP: TYPEDEF:
 HELP: ENUM:
 { $syntax "ENUM: type words... ;" "ENUM: type < base-type words..." }
 { $values { "type" "a name to typedef to int or f" } { "words" "a sequence of word names" } }
-{ $description "Creates a c-type that boxes and unboxes integer values to singletons. A singleton is defined for each member word. The base c-type can optionally be specified and defaults to " { $snippet "int" } ". A constructor word " { $snippet "<type>" } " is defined for converting from integers to singletons. The generic word " { $link enum>number } " converts from singletons to integers. Enum-typed values are automatically prettyprinted as their singleton words. Unrecognizing enum numbers are kept as numbers." }
+{ $description "Creates a c-type that boxes and unboxes integer values to symbols. A symbol is defined for each member word. The base c-type can optionally be specified and defaults to " { $link int } ". A constructor word " { $snippet "<type>" } " is defined for converting from integers to singletons. The generic word " { $link enum>number } " converts from singletons to integers. Enum-typed values are automatically prettyprinted as their singleton words. Unrecognizing enum numbers are kept as numbers." }
 { $examples
     "Here is an example enumeration definition:"
     { $code "ENUM: color_t red { green 3 } blue ;" }

From e5c65b22041489b9a48adcc9c01721da3f8b6f44 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 21 Apr 2010 22:22:06 -0700
Subject: [PATCH 054/158] use word-props instead of singletons for enum>number
 conversion so there's not a big fat generic making the image buy another
 plane ticket

---
 basis/alien/enums/enums.factor | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/basis/alien/enums/enums.factor b/basis/alien/enums/enums.factor
index d8c1a02c69..18000105e7 100644
--- a/basis/alien/enums/enums.factor
+++ b/basis/alien/enums/enums.factor
@@ -1,6 +1,6 @@
 ! (c)2010 Joe Groff, Erik Charlebois bsd license
-USING: accessors alien.c-types arrays classes.singleton combinators
-delegate fry generic.parser kernel macros math parser sequences words ;
+USING: accessors alien.c-types arrays combinators delegate fry
+generic.parser kernel macros math parser sequences words words.symbol ;
 IN: alien.enums
 
 <PRIVATE
@@ -12,6 +12,7 @@ PRIVATE>
 
 GENERIC: enum>number ( enum -- number ) foldable
 M: integer enum>number ;
+M: symbol enum>number "enum-value" word-prop ;
 
 <PRIVATE
 : enum-boxer ( members -- quot )
@@ -30,14 +31,13 @@ M: enum-c-type c-type-setter
 
 <PRIVATE
 
-: define-enum>number ( class value -- )
-    [ \ enum>number create-method-in ]
-    [ '[ drop _ ] ] bi* define ;
+: define-enum-value ( class value -- )
+    "enum-value" set-word-prop ;
 
 : define-enum-members ( member-names -- )
     [
-        [ first define-singleton-class ]
-        [ first2 define-enum>number ] bi
+        [ first define-symbol ]
+        [ first2 define-enum-value ] bi
     ] each ;
 
 : define-enum-constructor ( word -- )

From d6036b6d5bb45662ce680b78a882610f5142bf5e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 13:57:35 -0500
Subject: [PATCH 055/158] make host>device only take one parameter, add 2<<<
 for calling cuda functions where shared-memory is 0, simplify hello-world
 example

---
 extra/cuda/demos/hello-world/hello-world.factor |  5 ++---
 extra/cuda/memory/memory.factor                 | 17 +++++++++--------
 extra/cuda/syntax/syntax.factor                 |  3 +++
 3 files changed, 14 insertions(+), 11 deletions(-)

diff --git a/extra/cuda/demos/hello-world/hello-world.factor b/extra/cuda/demos/hello-world/hello-world.factor
index 8855ce6fea..19951c709c 100644
--- a/extra/cuda/demos/hello-world/hello-world.factor
+++ b/extra/cuda/demos/hello-world/hello-world.factor
@@ -10,10 +10,9 @@ CUDA-FUNCTION: helloWorld ( char* string-ptr ) ;
 
 :: cuda-hello-world ( -- )
     T{ launcher { device 0 } } [
-        "Hello World!" [ - ] map-index malloc-device-string
-        &dispose dup :> str
+        "Hello World!" [ - ] map-index host>device &dispose :> str
 
-        { 6 1 1 } { 2 1 } 1 3<<< helloWorld
+        str { 6 1 1 } { 2 1 } 2<<< helloWorld
 
         str device>host utf8 alien>string print
     ] with-cuda ;
diff --git a/extra/cuda/memory/memory.factor b/extra/cuda/memory/memory.factor
index c3dfe56a53..1ababcb8a0 100644
--- a/extra/cuda/memory/memory.factor
+++ b/extra/cuda/memory/memory.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.data assocs byte-arrays cuda.ffi
 cuda.utils destructors io.encodings.string io.encodings.utf8
-kernel locals namespaces sequences ;
+kernel locals namespaces sequences strings ;
 QUALIFIED-WITH: alien.c-types a
 IN: cuda.memory
 
@@ -61,14 +61,15 @@ M: cuda-memory dispose ( ptr -- )
 : memcpy-array>array ( dest-array dest-index src-array src-ptr count -- )
     cuMemcpyAtoA cuda-error ;
 
-: host>device ( dest-ptr src-ptr -- )
-    [ ptr>> ] dip dup length cuMemcpyHtoD cuda-error ;
+GENERIC: host>device ( obj -- ptr )
+
+M: string host>device utf8 encode host>device ;
+
+M: byte-array host>device ( byte-array -- ptr )
+    [ length cuda-malloc ] keep
+    [ [ ptr>> ] dip dup length cuMemcpyHtoD cuda-error ]
+    [ drop ] 2bi ;
 
 :: device>host ( ptr -- seq )
     ptr byte-length <byte-array>
     [ ptr [ ptr>> ] [ byte-length ] bi cuMemcpyDtoH cuda-error ] keep ;
-
-: malloc-device-string ( string -- n )
-    utf8 encode
-    [ length cuda-malloc ] keep
-    [ host>device ] [ drop ] 2bi ;
diff --git a/extra/cuda/syntax/syntax.factor b/extra/cuda/syntax/syntax.factor
index 1cd5edb9d4..ad19c696ec 100644
--- a/extra/cuda/syntax/syntax.factor
+++ b/extra/cuda/syntax/syntax.factor
@@ -13,6 +13,9 @@ SYNTAX: CUDA-FUNCTION:
     scan [ create-in current-cuda-library get ] [ ] bi
     ";" scan-c-args drop define-cuda-word ;
 
+: 2<<< ( dim-block dim-grid -- function-launcher )
+    0 f function-launcher boa ;
+
 : 3<<< ( dim-block dim-grid shared-size -- function-launcher )
     f function-launcher boa ;
 

From 656f8987a1223d26098e0546d19c7fe3bd90978b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 14:27:19 -0500
Subject: [PATCH 056/158] Run hello-world on each CUDA device. fix a bug with
 returning the hello world string.  add with-each-cuda-device combinator to
 run a program on each device. add an init-hook for cuda-init

---
 extra/cuda/cuda.factor                        |  8 ++++++-
 .../cuda/demos/hello-world/hello-world.factor | 21 +++++++++++--------
 extra/cuda/utils/utils.factor                 |  3 +++
 3 files changed, 22 insertions(+), 10 deletions(-)

diff --git a/extra/cuda/cuda.factor b/extra/cuda/cuda.factor
index 94e10a96dd..b2687d1cb6 100644
--- a/extra/cuda/cuda.factor
+++ b/extra/cuda/cuda.factor
@@ -3,7 +3,7 @@
 USING: accessors alien alien.data alien.parser alien.strings
 alien.syntax arrays assocs byte-arrays classes.struct
 combinators continuations cuda.ffi cuda.memory cuda.utils
-destructors fry io io.backend io.encodings.string
+destructors fry init io io.backend io.encodings.string
 io.encodings.utf8 kernel lexer locals macros math math.parser
 namespaces nested-comments opengl.gl.extensions parser
 prettyprint quotations sequences words ;
@@ -14,6 +14,10 @@ TUPLE: launcher
 { device integer initial: 0 }
 { device-flags initial: 0 } ;
 
+: <launcher> ( device-id -- launcher )
+    launcher new
+        swap >>device ; inline
+
 TUPLE: function-launcher
 dim-block dim-grid shared-size stream ;
 
@@ -81,3 +85,5 @@ MACRO: cuda-arguments ( c-types -- quot: ( args... function -- ) )
     ]
     [ 2nip \ function-launcher suffix a:void function-effect ]
     3bi define-declared ;
+
+[ init-cuda ] "cuda-init" add-startup-hook
diff --git a/extra/cuda/demos/hello-world/hello-world.factor b/extra/cuda/demos/hello-world/hello-world.factor
index 19951c709c..789948be68 100644
--- a/extra/cuda/demos/hello-world/hello-world.factor
+++ b/extra/cuda/demos/hello-world/hello-world.factor
@@ -1,20 +1,23 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.strings cuda cuda.memory cuda.syntax
-destructors io io.encodings.utf8 kernel locals math sequences ;
+USING: accessors alien.c-types alien.strings cuda cuda.devices
+cuda.memory cuda.syntax cuda.utils destructors io
+io.encodings.string io.encodings.utf8 kernel locals math
+math.parser namespaces sequences ;
 IN: cuda.demos.hello-world
 
 CUDA-LIBRARY: hello vocab:cuda/demos/hello-world/hello.ptx
 
 CUDA-FUNCTION: helloWorld ( char* string-ptr ) ;
 
-:: cuda-hello-world ( -- )
-    T{ launcher { device 0 } } [
-        "Hello World!" [ - ] map-index host>device &dispose :> str
+: cuda-hello-world ( -- )
+    [
+        cuda-launcher get device>> number>string
+        "CUDA device " ": " surround write
+        "Hello World!" [ - ] map-index host>device
 
-        str { 6 1 1 } { 2 1 } 2<<< helloWorld
-
-        str device>host utf8 alien>string print
-    ] with-cuda ;
+        [ { 6 1 1 } { 2 1 } 2<<< helloWorld ]
+        [ device>host utf8 decode print ] bi
+    ] with-each-cuda-device ;
 
 MAIN: cuda-hello-world
diff --git a/extra/cuda/utils/utils.factor b/extra/cuda/utils/utils.factor
index 912b9e2e92..32e8bf2fac 100644
--- a/extra/cuda/utils/utils.factor
+++ b/extra/cuda/utils/utils.factor
@@ -141,3 +141,6 @@ ERROR: no-cuda-library name ;
 : function-shared-size ( n -- )
     [ cuda-function get ] dip
     cuFuncSetSharedSize cuda-error ;
+
+: with-each-cuda-device ( quot -- )
+    [ enumerate-cuda-devices ] dip '[ <launcher> _ with-cuda ] each ; inline

From 8ae600124c378908b2a82c6d418881f61a2fcfff Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 14:28:17 -0500
Subject: [PATCH 057/158] remove init-cuda from a combinator because it's a
 startup-hook now

---
 extra/cuda/cuda.factor | 1 -
 1 file changed, 1 deletion(-)

diff --git a/extra/cuda/cuda.factor b/extra/cuda/cuda.factor
index b2687d1cb6..c4812a285f 100644
--- a/extra/cuda/cuda.factor
+++ b/extra/cuda/cuda.factor
@@ -34,7 +34,6 @@ dim-block dim-grid shared-size stream ;
     '[ cuda-context set _ call ] with-cuda-context ; inline
 
 : with-cuda ( launcher quot -- )
-    init-cuda
     [ H{ } clone cuda-memory-hashtable ] 2dip '[
         _ 
         [ cuda-launcher set ]

From b34c75a6a34a040c6542cb8b17d04e9c8f5cb1a1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 14:43:13 -0500
Subject: [PATCH 058/158] move cuda.utils library words to cuda.libraries

---
 extra/cuda/cuda.factor                |  2 +-
 extra/cuda/libraries/authors.txt      |  1 +
 extra/cuda/libraries/libraries.factor | 53 +++++++++++++++++++++++++++
 extra/cuda/utils/utils.factor         | 49 -------------------------
 4 files changed, 55 insertions(+), 50 deletions(-)
 create mode 100644 extra/cuda/libraries/authors.txt
 create mode 100644 extra/cuda/libraries/libraries.factor

diff --git a/extra/cuda/cuda.factor b/extra/cuda/cuda.factor
index c4812a285f..837d13c1c0 100644
--- a/extra/cuda/cuda.factor
+++ b/extra/cuda/cuda.factor
@@ -6,7 +6,7 @@ combinators continuations cuda.ffi cuda.memory cuda.utils
 destructors fry init io io.backend io.encodings.string
 io.encodings.utf8 kernel lexer locals macros math math.parser
 namespaces nested-comments opengl.gl.extensions parser
-prettyprint quotations sequences words ;
+prettyprint quotations sequences words cuda.libraries ;
 QUALIFIED-WITH: alien.c-types a
 IN: cuda
 
diff --git a/extra/cuda/libraries/authors.txt b/extra/cuda/libraries/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/cuda/libraries/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/cuda/libraries/libraries.factor b/extra/cuda/libraries/libraries.factor
new file mode 100644
index 0000000000..93b9842919
--- /dev/null
+++ b/extra/cuda/libraries/libraries.factor
@@ -0,0 +1,53 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.data arrays assocs
+cuda.ffi cuda.utils io.backend kernel namespaces sequences ;
+IN: cuda.libraries
+
+SYMBOL: cuda-libraries
+cuda-libraries [ H{ } clone ] initialize
+
+SYMBOL: current-cuda-library
+
+TUPLE: cuda-library name path handle ;
+
+: <cuda-library> ( name path -- obj )
+    \ cuda-library new
+        swap >>path
+        swap >>name ;
+
+: add-cuda-library ( name path -- )
+    normalize-path <cuda-library>
+    dup name>> cuda-libraries get-global set-at ;
+
+: ?delete-at ( key assoc -- old/key ? )
+    2dup delete-at* [ 2nip t ] [ 2drop f ] if ; inline
+
+ERROR: no-cuda-library name ;
+
+: load-module ( path -- module )
+    [ CUmodule <c-object> ] dip
+    [ cuModuleLoad cuda-error ] 2keep drop *void* ;
+
+: unload-module ( module -- )
+    cuModuleUnload cuda-error ;
+
+: load-cuda-library ( library -- handle )
+    path>> load-module ;
+
+: lookup-cuda-library ( name -- cuda-library )
+    cuda-libraries get ?at [ no-cuda-library ] unless ;
+
+: remove-cuda-library ( name -- library )
+    cuda-libraries get ?delete-at [ no-cuda-library ] unless ;
+
+: unload-cuda-library ( name -- )
+    remove-cuda-library handle>> unload-module ;
+
+: cached-module ( module-name -- alien )
+    lookup-cuda-library
+    cuda-modules get-global [ load-cuda-library ] cache ;
+
+: cached-function ( module-name function-name -- alien )
+    [ cached-module ] dip
+    2array cuda-functions get [ first2 get-function-ptr* ] cache ;
diff --git a/extra/cuda/utils/utils.factor b/extra/cuda/utils/utils.factor
index 32e8bf2fac..7422836c84 100644
--- a/extra/cuda/utils/utils.factor
+++ b/extra/cuda/utils/utils.factor
@@ -44,55 +44,6 @@ ERROR: throw-cuda-error n ;
 
 : destroy-context ( context -- ) cuCtxDestroy cuda-error ;
 
-SYMBOL: cuda-libraries
-cuda-libraries [ H{ } clone ] initialize
-
-SYMBOL: current-cuda-library
-
-TUPLE: cuda-library name path handle ;
-
-: <cuda-library> ( name path -- obj )
-    \ cuda-library new
-        swap >>path
-        swap >>name ;
-
-: add-cuda-library ( name path -- )
-    normalize-path <cuda-library>
-    dup name>> cuda-libraries get-global set-at ;
-
-: ?delete-at ( key assoc -- old/key ? )
-    2dup delete-at* [ 2nip t ] [ 2drop f ] if ; inline
-
-ERROR: no-cuda-library name ;
-
-: load-module ( path -- module )
-    [ CUmodule <c-object> ] dip
-    [ cuModuleLoad cuda-error ] 2keep drop *void* ;
-
-: unload-module ( module -- )
-    cuModuleUnload cuda-error ;
-
-: load-cuda-library ( library -- handle )
-    path>> load-module ;
-
-: lookup-cuda-library ( name -- cuda-library )
-    cuda-libraries get ?at [ no-cuda-library ] unless ;
-
-: remove-cuda-library ( name -- library )
-    cuda-libraries get ?delete-at [ no-cuda-library ] unless ;
-
-: unload-cuda-library ( name -- )
-    remove-cuda-library handle>> unload-module ;
-
-
-: cached-module ( module-name -- alien )
-    lookup-cuda-library
-    cuda-modules get-global [ load-cuda-library ] cache ;
-
-: cached-function ( module-name function-name -- alien )
-    [ cached-module ] dip
-    2array cuda-functions get [ first2 get-function-ptr* ] cache ;
-
 : launch-function* ( function -- ) cuLaunch cuda-error ;
 
 : launch-function ( -- ) cuda-function get cuLaunch cuda-error ;

From b8c10dc2cdeb0ae89d0af5c95363557e889a2a4a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 14:43:48 -0500
Subject: [PATCH 059/158] Add using

---
 extra/cuda/syntax/syntax.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/cuda/syntax/syntax.factor b/extra/cuda/syntax/syntax.factor
index ad19c696ec..70a052726f 100644
--- a/extra/cuda/syntax/syntax.factor
+++ b/extra/cuda/syntax/syntax.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.parser cuda cuda.utils io.backend kernel lexer
-namespaces parser ;
+USING: alien.parser cuda cuda.libraries cuda.utils io.backend
+kernel lexer namespaces parser ;
 IN: cuda.syntax
 
 SYNTAX: CUDA-LIBRARY:

From 8323332838df0d92a23caaca577b27b1e9901bd9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 15:06:43 -0500
Subject: [PATCH 060/158] Compile the .cu file with a relative pathname instead
 of absolute

---
 extra/cuda/nvcc/authors.txt |  1 +
 extra/cuda/nvcc/nvcc.factor | 31 +++++++++++++++++++++++++++++++
 2 files changed, 32 insertions(+)
 create mode 100644 extra/cuda/nvcc/authors.txt
 create mode 100644 extra/cuda/nvcc/nvcc.factor

diff --git a/extra/cuda/nvcc/authors.txt b/extra/cuda/nvcc/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/cuda/nvcc/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/cuda/nvcc/nvcc.factor b/extra/cuda/nvcc/nvcc.factor
new file mode 100644
index 0000000000..c1e35c32ca
--- /dev/null
+++ b/extra/cuda/nvcc/nvcc.factor
@@ -0,0 +1,31 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators.smart io.backend io.directories
+io.launcher io.pathnames kernel locals math sequences splitting
+system ;
+IN: cuda.nvcc
+
+HOOK: nvcc-path os ( -- path )
+
+M: object nvcc-path "nvcc" ;
+
+M: macosx nvcc-path "/usr/local/cuda/bin/nvcc" ;
+
+: cu>ptx ( path -- path' )
+    ".cu" ?tail drop ".ptx" append ;
+
+: nvcc-command ( path -- seq )
+    [
+        [ nvcc-path "--ptx" "-o" ] dip
+        [ cu>ptx ] [ file-name ] bi
+    ] output>array ;
+
+ERROR: nvcc-failed n path ;
+
+:: compile-cu ( path -- path' )
+    path normalize-path :> path2
+    path2 parent-directory [
+        path2 nvcc-command
+        run-process wait-for-process [ path2 nvcc-failed ] unless-zero
+        path2 cu>ptx
+    ] with-directory ;

From 095763bceeb17fbab5513a7807a0138cf8031168 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 18:27:13 -0500
Subject: [PATCH 061/158] Move cuda.devices word out of cuda.utils

---
 extra/cuda/devices/devices.factor | 8 ++++++--
 extra/cuda/utils/utils.factor     | 3 ---
 2 files changed, 6 insertions(+), 5 deletions(-)

diff --git a/extra/cuda/devices/devices.factor b/extra/cuda/devices/devices.factor
index 37e199e74e..de36f70280 100644
--- a/extra/cuda/devices/devices.factor
+++ b/extra/cuda/devices/devices.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.data alien.strings arrays assocs
-byte-arrays classes.struct combinators cuda.ffi cuda.utils io
-io.encodings.utf8 kernel math.parser prettyprint sequences ;
+byte-arrays classes.struct combinators cuda cuda.ffi cuda.utils
+fry io io.encodings.utf8 kernel math.parser prettyprint
+sequences ;
 IN: cuda.devices
 
 : #cuda-devices ( -- n )
@@ -14,6 +15,9 @@ IN: cuda.devices
 : enumerate-cuda-devices ( -- devices )
     #cuda-devices iota [ n>cuda-device ] map ;
 
+: with-each-cuda-device ( quot -- )
+    [ enumerate-cuda-devices ] dip '[ <launcher> _ with-cuda ] each ; inline
+
 : cuda-device-properties ( device -- properties )
     [ CUdevprop <c-object> ] dip
     [ cuDeviceGetProperties cuda-error ] 2keep drop
diff --git a/extra/cuda/utils/utils.factor b/extra/cuda/utils/utils.factor
index 7422836c84..eef205992f 100644
--- a/extra/cuda/utils/utils.factor
+++ b/extra/cuda/utils/utils.factor
@@ -92,6 +92,3 @@ ERROR: throw-cuda-error n ;
 : function-shared-size ( n -- )
     [ cuda-function get ] dip
     cuFuncSetSharedSize cuda-error ;
-
-: with-each-cuda-device ( quot -- )
-    [ enumerate-cuda-devices ] dip '[ <launcher> _ with-cuda ] each ; inline

From 654e4d48f5f60e4aa83f0343e8e5e92b78490806 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 20:12:54 -0500
Subject: [PATCH 062/158] More error checking in constructors for when slot
 name is repeated or a slot is not present in a tuple

---
 extra/constructors/constructors-tests.factor | 12 ++++++++++--
 extra/constructors/constructors.factor       | 18 ++++++++++++++----
 2 files changed, 24 insertions(+), 6 deletions(-)

diff --git a/extra/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor
index 1e098645bf..fef3150f6e 100644
--- a/extra/constructors/constructors-tests.factor
+++ b/extra/constructors/constructors-tests.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit initializers math ;
+USING: accessors calendar combinators.short-circuit
+constructors eval initializers kernel math tools.test ;
 IN: constructors.tests
 
 TUPLE: stock-spread stock spread timestamp ;
@@ -41,3 +41,11 @@ CONSTRUCTOR: ct4 ( a b c d -- obj )
 [ 2 ] [ 0 0 <ct2> a>> ] unit-test
 [ 3 ] [ 0 0 0 <ct3> a>> ] unit-test
 [ 4 ] [ 0 0 0 0 <ct4> a>> ] unit-test
+
+[
+    """IN: constructors.tests
+TUPLE: foo a b ;
+CONSTRUCTOR: foo ( a c -- obj ) ;""" eval( -- )
+] [
+    error>> unknown-constructor-parameters?
+] must-fail-with
diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor
index 747c8f53fc..51df4e8de6 100644
--- a/extra/constructors/constructors.factor
+++ b/extra/constructors/constructors.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs classes classes.tuple effects.parser
-fry generalizations generic.standard kernel lexer locals macros
-parser sequences slots vocabs words arrays ;
+USING: accessors arrays assocs classes classes.tuple
+effects.parser fry generalizations generic.standard kernel
+lexer locals macros parser sequences sets slots vocabs words ;
 IN: constructors
 
 ! An experiment
@@ -38,6 +38,15 @@ MACRO:: slots>constructor ( class slots -- quot )
         default-params swap assoc-union values _ firstn class boa
     ] ;
 
+ERROR: repeated-constructor-parameters class effect ;
+
+ERROR: unknown-constructor-parameters class effect unknown ;
+
+: ensure-constructor-parameters ( class effect -- class effect )
+    dup in>> all-unique? [ repeated-constructor-parameters ] unless
+    2dup [ all-slots [ name>> ] map ] [ in>> ] bi* swap diff
+    [ unknown-constructor-parameters ] unless-empty ;
+
 :: (define-constructor) ( constructor-word class effect def -- word quot )
     constructor-word
     class def define-initializer
@@ -53,7 +62,8 @@ MACRO:: slots>constructor ( class slots -- quot )
     scan-word [ name>> "<" ">" surround create-in dup reset-generic ] keep ;
 
 : parse-constructor ( -- class word effect def )
-    scan-constructor complete-effect parse-definition ;
+    scan-constructor complete-effect ensure-constructor-parameters
+    parse-definition ;
 
 SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
 

From 6809ac0855e7cf0e97227ff9e02215e922e9ec97 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 23:14:53 -0500
Subject: [PATCH 063/158] Copy factor.image to factor.image.fresh after
 bootstrapping.  Use $ECHO in more places.

---
 build-support/factor.sh | 78 +++++++++++++++++++++++------------------
 1 file changed, 43 insertions(+), 35 deletions(-)

diff --git a/build-support/factor.sh b/build-support/factor.sh
index 68d138c3ef..3e720c2e21 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -25,7 +25,7 @@ test_program_installed() {
 
 exit_script() {
     if [[ $FIND_MAKE_TARGET -eq true ]] ; then
-        echo $MAKE_TARGET;
+        $ECHO $MAKE_TARGET;
     fi
     exit $1
 }
@@ -37,7 +37,7 @@ ensure_program_installed() {
         $ECHO -n "Checking for $i..."
         test_program_installed $i
         if [[ $? -eq 0 ]]; then
-            echo -n "not "
+            $ECHO -n "not "
         else    
             installed=$(( $installed + 1 ))
         fi
@@ -194,8 +194,8 @@ find_architecture() {
 }
 
 write_test_program() {
-    echo "#include <stdio.h>" > $C_WORD.c
-    echo "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c
+    $ECHO "#include <stdio.h>" > $C_WORD.c
+    $ECHO "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c
 }
 
 c_find_word_size() {
@@ -247,6 +247,7 @@ set_factor_library() {
 
 set_factor_image() {
     FACTOR_IMAGE=factor.image
+    FACTOR_IMAGE_FRESH=factor.image.fresh
 }
 
 echo_build_info() {
@@ -275,7 +276,7 @@ check_os_arch_word() {
         $ECHO "WORD: $WORD"
         $ECHO "OS, ARCH, or WORD is empty.  Please report this."
 
-        echo $MAKE_TARGET
+        $ECHO $MAKE_TARGET
         exit_script 5
     fi
 }
@@ -344,22 +345,22 @@ invoke_git() {
 }
 
 git_clone() {
-    echo "Downloading the git repository from factorcode.org..."
+    $ECHO "Downloading the git repository from factorcode.org..."
     invoke_git clone $GIT_URL
 }
 
 update_script_name() {
-    echo `dirname $0`/_update.sh
+    $ECHO `dirname $0`/_update.sh
 }
 
 update_script() {
     update_script=`update_script_name`
     bash_path=`which bash`
-    echo "#!$bash_path" >"$update_script"
-    echo "git pull \"$GIT_URL\" master" >>"$update_script"
-    echo "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \
+    $ECHO "#!$bash_path" >"$update_script"
+    $ECHO "git pull \"$GIT_URL\" master" >>"$update_script"
+    $ECHO "if [[ \$? -eq 0 ]]; then exec \"$0\" $SCRIPT_ARGS; else echo \"git pull failed\"; exit 2; fi" \
         >>"$update_script"
-    echo "exit 0" >>"$update_script"
+    $ECHO "exit 0" >>"$update_script"
 
     chmod 755 "$update_script"
     exec "$update_script"
@@ -370,16 +371,16 @@ update_script_changed() {
 }
 
 git_fetch_factorcode() {
-    echo "Fetching the git repository from factorcode.org..."
+    $ECHO "Fetching the git repository from factorcode.org..."
 
     rm -f `update_script_name`
     invoke_git fetch "$GIT_URL" master
 
     if update_script_changed; then
-        echo "Updating and restarting the factor.sh script..."
+        $ECHO "Updating and restarting the factor.sh script..."
         update_script
     else
-        echo "Updating the working tree..."
+        $ECHO "Updating the working tree..."
         invoke_git pull "$GIT_URL" master
     fi
 }
@@ -414,11 +415,11 @@ backup_factor() {
 
 check_makefile_exists() {
     if [[ ! -e "GNUmakefile" ]] ; then
-        echo ""
-        echo "***GNUmakefile not found***"
-        echo "You are likely in the wrong directory."
-        echo "Run this script from your factor directory:"
-        echo "     ./build-support/factor.sh"
+        $ECHO ""
+        $ECHO "***GNUmakefile not found***"
+        $ECHO "You are likely in the wrong directory."
+        $ECHO "Run this script from your factor directory:"
+        $ECHO "     ./build-support/factor.sh"
         exit_script 6
     fi
 }
@@ -438,7 +439,7 @@ make_factor() {
 }
 
 update_boot_images() {
-    echo "Deleting old images..."
+    $ECHO "Deleting old images..."
     $DELETE checksums.txt* > /dev/null 2>&1
     # delete boot images with one or two characters after the dot
     $DELETE $BOOT_IMAGE.{?,??} > /dev/null 2>&1
@@ -451,10 +452,10 @@ update_boot_images() {
              netbsd) disk_md5=`md5 $BOOT_IMAGE | cut -f4 -d' '`;;
              *) disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '` ;;
         esac
-        echo "Factorcode md5: $factorcode_md5";
-        echo "Disk md5: $disk_md5";
+        $ECHO "Factorcode md5: $factorcode_md5";
+        $ECHO "Disk md5: $disk_md5";
         if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
-            echo "Your disk boot image matches the one on factorcode.org."
+            $ECHO "Your disk boot image matches the one on factorcode.org."
         else
             $DELETE $BOOT_IMAGE > /dev/null 2>&1
             get_boot_image;
@@ -465,7 +466,7 @@ update_boot_images() {
 }
 
 get_boot_image() {
-    echo "Downloading boot image $BOOT_IMAGE."
+    $ECHO "Downloading boot image $BOOT_IMAGE."
     get_url http://factorcode.org/images/latest/$BOOT_IMAGE
 }
 
@@ -473,7 +474,7 @@ get_url() {
     if [[ $DOWNLOADER -eq "" ]] ; then
         set_downloader;
     fi
-    echo $DOWNLOADER $1 ;
+    $ECHO $DOWNLOADER $1 ;
     $DOWNLOADER $1
     check_ret $DOWNLOADER
 }
@@ -484,8 +485,15 @@ get_config_info() {
     check_libraries
 }
 
+copy_fresh_image() {
+    $ECHO "Copying $FACTOR_IMAGE to $FACTOR_IMAGE_FRESH..."
+    $COPY $FACTOR_IMAGE $FACTOR_IMAGE_FRESH
+    $ECHO "done."
+}
+
 bootstrap() {
     ./$FACTOR_BINARY -i=$BOOT_IMAGE
+	copy_fresh_image
 }
 
 install() {
@@ -532,22 +540,22 @@ install_build_system_port() {
     test_program_installed git
     if [[ $? -ne 1 ]] ; then
         ensure_program_installed yes
-        echo "git not found."
-        echo "This script requires either git-core or port."
-        echo "If it fails, install git-core or port and try again."
+        $ECHO "git not found."
+        $ECHO "This script requires either git-core or port."
+        $ECHO "If it fails, install git-core or port and try again."
         ensure_program_installed port
-        echo "Installing git-core with port...this will take awhile."
+        $ECHO "Installing git-core with port...this will take awhile."
         yes | sudo port install git-core
     fi
 }
 
 usage() {
-    echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target|report [optional-target]"
-    echo "If you are behind a firewall, invoke as:"
-    echo "env GIT_PROTOCOL=http $0 <command>"
-    echo ""
-    echo "Example for overriding the default target:"
-    echo "    $0 update macosx-x86-32"
+    $ECHO "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target|report [optional-target]"
+    $ECHO "If you are behind a firewall, invoke as:"
+    $ECHO "env GIT_PROTOCOL=http $0 <command>"
+    $ECHO ""
+    $ECHO "Example for overriding the default target:"
+    $ECHO "    $0 update macosx-x86-32"
 }
 
 MAKE_TARGET=unknown

From 8d76f2e6124b97d0b84efdc741a984da04513508 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 23:17:47 -0500
Subject: [PATCH 064/158] Sprinkle init-cuda everywhere you could conceivably
 need it!

---
 extra/cuda/cuda.factor            | 3 +--
 extra/cuda/devices/devices.factor | 7 +++++++
 extra/cuda/ffi/ffi.factor         | 1 -
 3 files changed, 8 insertions(+), 3 deletions(-)

diff --git a/extra/cuda/cuda.factor b/extra/cuda/cuda.factor
index 837d13c1c0..2c09fd176f 100644
--- a/extra/cuda/cuda.factor
+++ b/extra/cuda/cuda.factor
@@ -34,6 +34,7 @@ dim-block dim-grid shared-size stream ;
     '[ cuda-context set _ call ] with-cuda-context ; inline
 
 : with-cuda ( launcher quot -- )
+    init-cuda
     [ H{ } clone cuda-memory-hashtable ] 2dip '[
         _ 
         [ cuda-launcher set ]
@@ -84,5 +85,3 @@ MACRO: cuda-arguments ( c-types -- quot: ( args... function -- ) )
     ]
     [ 2nip \ function-launcher suffix a:void function-effect ]
     3bi define-declared ;
-
-[ init-cuda ] "cuda-init" add-startup-hook
diff --git a/extra/cuda/devices/devices.factor b/extra/cuda/devices/devices.factor
index de36f70280..c9117bd00c 100644
--- a/extra/cuda/devices/devices.factor
+++ b/extra/cuda/devices/devices.factor
@@ -7,9 +7,11 @@ sequences ;
 IN: cuda.devices
 
 : #cuda-devices ( -- n )
+    init-cuda
     int <c-object> [ cuDeviceGetCount cuda-error ] keep *int ;
 
 : n>cuda-device ( n -- device )
+    init-cuda
     [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ;
 
 : enumerate-cuda-devices ( -- devices )
@@ -27,16 +29,19 @@ IN: cuda.devices
     enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
 
 : cuda-device-name ( n -- string )
+    init-cuda
     [ 256 [ <byte-array> ] keep ] dip
     [ cuDeviceGetName cuda-error ]
     [ 2drop utf8 alien>string ] 3bi ;
 
 : cuda-device-capability ( n -- pair )
+    init-cuda
     [ int <c-object> int <c-object> ] dip
     [ cuDeviceComputeCapability cuda-error ]
     [ drop [ *int ] bi@ ] 3bi 2array ;
 
 : cuda-device-memory ( n -- bytes )
+    init-cuda
     [ uint <c-object> ] dip
     [ cuDeviceTotalMem cuda-error ]
     [ drop *uint ] 2bi ;
@@ -47,6 +52,7 @@ IN: cuda.devices
     [ 2drop *int ] 3bi ;
 
 : cuda-device. ( n -- )
+    init-cuda
     {
         [ "Device: " write number>string print ]
         [ "Name: " write cuda-device-name print ]
@@ -64,6 +70,7 @@ IN: cuda.devices
     } cleave ;
 
 : cuda. ( -- )
+    init-cuda
     "CUDA Version: " write cuda-version number>string print nl
     #cuda-devices iota [ nl ] [ cuda-device. ] interleave ;
 
diff --git a/extra/cuda/ffi/ffi.factor b/extra/cuda/ffi/ffi.factor
index 3da76698c6..bcbb1ff60a 100644
--- a/extra/cuda/ffi/ffi.factor
+++ b/extra/cuda/ffi/ffi.factor
@@ -460,4 +460,3 @@ FUNCTION: CUresult cuGraphicsMapResources ( uint count, CUgraphicsResource* reso
 FUNCTION: CUresult cuGraphicsUnmapResources ( uint count, CUgraphicsResource* resources, CUstream hStream ) ;
 
 FUNCTION: CUresult cuGetExportTable ( void** ppExportTable, CUuuid* pExportTableId ) ;
-

From cc546c3a94607b514178f6b76a1e2c498cb30af1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 23:19:26 -0500
Subject: [PATCH 065/158] init-cuda in a couple more places...

---
 extra/cuda/devices/devices.factor | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/extra/cuda/devices/devices.factor b/extra/cuda/devices/devices.factor
index c9117bd00c..8b29295a0b 100644
--- a/extra/cuda/devices/devices.factor
+++ b/extra/cuda/devices/devices.factor
@@ -20,7 +20,8 @@ IN: cuda.devices
 : with-each-cuda-device ( quot -- )
     [ enumerate-cuda-devices ] dip '[ <launcher> _ with-cuda ] each ; inline
 
-: cuda-device-properties ( device -- properties )
+: cuda-device-properties ( n -- properties )
+    init-cuda
     [ CUdevprop <c-object> ] dip
     [ cuDeviceGetProperties cuda-error ] 2keep drop
     CUdevprop memory>struct ;
@@ -46,7 +47,8 @@ IN: cuda.devices
     [ cuDeviceTotalMem cuda-error ]
     [ drop *uint ] 2bi ;
 
-: cuda-device-attribute ( attribute dev -- n )
+: cuda-device-attribute ( attribute n -- n )
+    init-cuda
     [ int <c-object> ] 2dip
     [ cuDeviceGetAttribute cuda-error ]
     [ 2drop *int ] 3bi ;

From e3d6ba974cf4ce104038554bfd44a7f5b70e08e6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 23:28:24 -0500
Subject: [PATCH 066/158] Remove dumb echo from factor.sh

---
 build-support/factor.sh | 1 -
 1 file changed, 1 deletion(-)

diff --git a/build-support/factor.sh b/build-support/factor.sh
index 3e720c2e21..bcc3e8f966 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -488,7 +488,6 @@ get_config_info() {
 copy_fresh_image() {
     $ECHO "Copying $FACTOR_IMAGE to $FACTOR_IMAGE_FRESH..."
     $COPY $FACTOR_IMAGE $FACTOR_IMAGE_FRESH
-    $ECHO "done."
 }
 
 bootstrap() {

From a51fea1224ae366be7dc01dc7370f04028125a55 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 23 Apr 2010 23:30:51 -0500
Subject: [PATCH 067/158] Fix unit test for when auto-use isnt on and test the
 other constructor error condition

---
 extra/constructors/constructors-tests.factor | 12 +++++++++++-
 1 file changed, 11 insertions(+), 1 deletion(-)

diff --git a/extra/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor
index fef3150f6e..0ad83a6c5f 100644
--- a/extra/constructors/constructors-tests.factor
+++ b/extra/constructors/constructors-tests.factor
@@ -43,7 +43,17 @@ CONSTRUCTOR: ct4 ( a b c d -- obj )
 [ 4 ] [ 0 0 0 0 <ct4> a>> ] unit-test
 
 [
-    """IN: constructors.tests
+    """USE: constructors
+IN: constructors.tests
+TUPLE: foo a b ;
+CONSTRUCTOR: foo ( a a -- obj ) ;""" eval( -- )
+] [
+    error>> repeated-constructor-parameters?
+] must-fail-with
+
+[
+    """USE: constructors
+IN: constructors.tests
 TUPLE: foo a b ;
 CONSTRUCTOR: foo ( a c -- obj ) ;""" eval( -- )
 ] [

From d4eba4632a1ae3cb4a801350410e32a4babe6f49 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Sat, 24 Apr 2010 21:29:46 -0500
Subject: [PATCH 068/158] Making tools.deploy.shaker remove  require-when data
 structures

---
 basis/tools/deploy/shaker/shaker.factor | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index a2a2dbbc86..485f0f5fa7 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -6,7 +6,7 @@ parser.notes lexer strings.parser vocabs sequences sequences.deep
 sequences.private words memory kernel.private continuations io
 vocabs.loader system strings sets vectors quotations byte-arrays
 sorting compiler.units definitions generic generic.standard
-generic.single tools.deploy.config combinators classes
+generic.single tools.deploy.config combinators classes vocabs.loader.private
 classes.builtin slots.private grouping command-line io.pathnames ;
 QUALIFIED: bootstrap.stage2
 QUALIFIED: classes.private
@@ -349,6 +349,8 @@ IN: tools.deploy.shaker
                 lexer-factory
                 print-use-hook
                 root-cache
+                require-when-vocabs
+                require-when-table
                 source-files.errors:error-types
                 source-files.errors:error-observers
                 vocabs:dictionary

From 859ec88bcd3788cea1c45af5d40bd1c927ee886a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 25 Apr 2010 12:18:45 -0700
Subject: [PATCH 069/158] ui.backend.x11: search path for xmessage rather than
 hardcoding path

---
 basis/ui/backend/x11/x11.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor
index 6a7a8d147f..fc7943efb0 100644
--- a/basis/ui/backend/x11/x11.factor
+++ b/basis/ui/backend/x11/x11.factor
@@ -332,7 +332,7 @@ M: x11-ui-backend beep ( -- )
     [ dup CHAR: ' = [ drop "'\\''" ] [ 1string ] if ] { } map-as concat ;
 
 : xmessage ( string -- )
-    escape-' "/usr/X11R6/bin/xmessage '" "'" surround system drop ;
+    escape-' "/usr/bin/env xmessage '" "'" surround system drop ;
 PRIVATE>
 
 M: x11-ui-backend system-alert

From 6023070fec9d9b073022c8d8bce7fd02c252f322 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 25 Apr 2010 14:59:07 -0500
Subject: [PATCH 070/158] A little overzealous with the factor.sh echo cleanup

---
 build-support/factor.sh | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/build-support/factor.sh b/build-support/factor.sh
index bcc3e8f966..d8b547d8d6 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -25,7 +25,8 @@ test_program_installed() {
 
 exit_script() {
     if [[ $FIND_MAKE_TARGET -eq true ]] ; then
-        $ECHO $MAKE_TARGET;
+		# Must be echo not $ECHO
+        echo $MAKE_TARGET;
     fi
     exit $1
 }

From daf63d11b6b0a67a1d8515866e00f00da23eda39 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 25 Apr 2010 15:16:08 -0500
Subject: [PATCH 071/158] gitignore the fresh boot image

---
 .gitignore | 1 +
 1 file changed, 1 insertion(+)

diff --git a/.gitignore b/.gitignore
index 3bc5a6ffda..7bd42557b7 100644
--- a/.gitignore
+++ b/.gitignore
@@ -12,6 +12,7 @@ Factor/factor
 *.res
 *.RES
 *.image
+factor.image.fresh
 *.dylib
 factor
 factor.com

From 13baf777c9b48e3a016c23b861eff4ad04a937dc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 25 Apr 2010 15:23:44 -0500
Subject: [PATCH 072/158] Test factor.sh output on unix platforms

---
 extra/build-support/authors.txt                |  1 +
 extra/build-support/build-support-tests.factor |  6 ++++++
 extra/build-support/build-support.factor       | 10 ++++++++++
 extra/build-support/platforms.txt              |  1 +
 4 files changed, 18 insertions(+)
 create mode 100644 extra/build-support/authors.txt
 create mode 100644 extra/build-support/build-support-tests.factor
 create mode 100644 extra/build-support/build-support.factor
 create mode 100644 extra/build-support/platforms.txt

diff --git a/extra/build-support/authors.txt b/extra/build-support/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/build-support/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/build-support/build-support-tests.factor b/extra/build-support/build-support-tests.factor
new file mode 100644
index 0000000000..1f855d5701
--- /dev/null
+++ b/extra/build-support/build-support-tests.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: build-support sequences tools.test ;
+IN: build-support.tests
+
+[ f ] [ factor.sh-make-target empty? ] unit-test
diff --git a/extra/build-support/build-support.factor b/extra/build-support/build-support.factor
new file mode 100644
index 0000000000..177042e186
--- /dev/null
+++ b/extra/build-support/build-support.factor
@@ -0,0 +1,10 @@
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays io io.backend io.encodings.utf8 io.launcher ;
+IN: build-support
+
+CONSTANT: factor.sh-path "resource:build-support/factor.sh"
+
+: factor.sh-make-target ( -- string )
+    factor.sh-path normalize-path "make-target" 2array
+    utf8 [ readln ] with-process-reader ;
diff --git a/extra/build-support/platforms.txt b/extra/build-support/platforms.txt
new file mode 100644
index 0000000000..509143d863
--- /dev/null
+++ b/extra/build-support/platforms.txt
@@ -0,0 +1 @@
+unix

From 879687521defefcffba194814e7170dcd136819a Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-224-36.res.carleton.edu>
Date: Sun, 25 Apr 2010 18:09:58 -0500
Subject: [PATCH 073/158] Documenting bitfields in structs

---
 basis/classes/struct/struct-docs.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor
index 7dbfda1f4f..68a4876f92 100644
--- a/basis/classes/struct/struct-docs.factor
+++ b/basis/classes/struct/struct-docs.factor
@@ -35,7 +35,8 @@ HELP: STRUCT:
 { "Struct classes cannot have a superclass defined." }
 { "The slots of a struct must all have a type declared. The type must be a C type." } 
 { { $link read-only } " slots on structs are not enforced, though they may be declared." }
-} } ;
+}
+"Additionally, structs may use bit fields. A slot specifier may use the syntax " { $snippet "bits: n" } " to specify that the bit width of the slot is " { $snippet "n" } ". Bit width may be specified on signed or unsigned integer slots. The layout of bit fields is not guaranteed to match that of any particular C compiler." } ;
 
 HELP: S{
 { $syntax "S{ class slots... }" }

From c9db8f4269439805eeac8c1d1236cf7883b945a8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 27 Apr 2010 10:52:19 -0400
Subject: [PATCH 074/158] io.sockets: update <datagram> docs

---
 basis/io/sockets/sockets-docs.factor | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor
index 8cc6ef731d..a41fc1e6c3 100644
--- a/basis/io/sockets/sockets-docs.factor
+++ b/basis/io/sockets/sockets-docs.factor
@@ -192,12 +192,13 @@ HELP: <datagram>
     }
 }
 { $notes
-    "To accept UDP/IP packets from any host, use an address specifier returned by the following code, where 1234 is the desired port number:"
-    { $code "f 1234 <inet> resolve-host" }
-    "To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:"
-    { $code "\"localhost\" 1234 <inet> resolve-host" }
+    "To accept UDP/IP packets from any host, use an address specifier where the host name is set to " { $link f } ":"
+    { $code "f 1234 <inet4> <datagram>" }
+    "To create a datagram socket bound to a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the datagram instance to obtain the actual port number it is bound to:"
+    { $code "f 0 <inet4> <datagram>" }
+    "To accept UDP/IP packets from the loopback interface only, use an address specifier like the following:"
+    { $code "\"127.0.0.1\" 1234 <inet4> <datagram>s" }
     "Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly."
-    "Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding"
 }
 { $errors "Throws an error if the port is already in use, or if the OS forbids access." } ;
 

From 5ac954b1547cdbcf6119f0b4cb462dd0898d6e58 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 28 Apr 2010 05:04:09 -0400
Subject: [PATCH 075/158] vocabs: add a link to the parse-time word lookup
 article

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

diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor
index 1c65e627d5..3f8a71e76c 100644
--- a/core/vocabs/vocabs-docs.factor
+++ b/core/vocabs/vocabs-docs.factor
@@ -39,7 +39,7 @@ $nl
 }
 "Removing a vocabulary:"
 { $subsections forget-vocab }
-{ $see-also "words" "vocabs.loader" } ;
+{ $see-also "words" "vocabs.loader" "word-search" } ;
 
 ABOUT: "vocabularies"
 

From 0ab9046300788ce87e48be5911b8f80a7828207c Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 28 Apr 2010 15:48:47 -0700
Subject: [PATCH 076/158] rename half-floats vocab to math.floats.half

---
 basis/images/normalization/normalization.factor               | 2 +-
 basis/{half-floats => math/floats/half}/authors.txt           | 0
 .../floats/half/half-tests.factor}                            | 4 ++--
 .../half-floats.factor => math/floats/half/half.factor}       | 2 +-
 basis/{half-floats => math/floats/half}/summary.txt           | 0
 extra/gpu/render/render.factor                                | 2 +-
 extra/gpu/shaders/shaders.factor                              | 2 +-
 7 files changed, 6 insertions(+), 6 deletions(-)
 rename basis/{half-floats => math/floats/half}/authors.txt (100%)
 rename basis/{half-floats/half-floats-tests.factor => math/floats/half/half-tests.factor} (93%)
 rename basis/{half-floats/half-floats.factor => math/floats/half/half.factor} (98%)
 rename basis/{half-floats => math/floats/half}/summary.txt (100%)

diff --git a/basis/images/normalization/normalization.factor b/basis/images/normalization/normalization.factor
index 6eaca01e15..db68e4bad6 100644
--- a/basis/images/normalization/normalization.factor
+++ b/basis/images/normalization/normalization.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types byte-arrays combinators fry
 grouping images kernel locals math math.vectors
-sequences specialized-arrays half-floats ;
+sequences specialized-arrays math.floats.half ;
 FROM: alien.c-types => float ;
 SPECIALIZED-ARRAY: half
 SPECIALIZED-ARRAY: float
diff --git a/basis/half-floats/authors.txt b/basis/math/floats/half/authors.txt
similarity index 100%
rename from basis/half-floats/authors.txt
rename to basis/math/floats/half/authors.txt
diff --git a/basis/half-floats/half-floats-tests.factor b/basis/math/floats/half/half-tests.factor
similarity index 93%
rename from basis/half-floats/half-floats-tests.factor
rename to basis/math/floats/half/half-tests.factor
index d6b26cb129..82db3d195b 100644
--- a/basis/half-floats/half-floats-tests.factor
+++ b/basis/math/floats/half/half-tests.factor
@@ -1,7 +1,7 @@
-USING: accessors alien.c-types alien.syntax half-floats kernel
+USING: accessors alien.c-types alien.syntax math.floats.half kernel
 math tools.test specialized-arrays alien.data classes.struct ;
 SPECIALIZED-ARRAY: half
-IN: half-floats.tests
+IN: math.floats.half.tests
 
 [ HEX: 0000 ] [  0.0  half>bits ] unit-test
 [ HEX: 8000 ] [ -0.0  half>bits ] unit-test
diff --git a/basis/half-floats/half-floats.factor b/basis/math/floats/half/half.factor
similarity index 98%
rename from basis/half-floats/half-floats.factor
rename to basis/math/floats/half/half.factor
index 4c84bb81cc..ffa3550452 100644
--- a/basis/half-floats/half-floats.factor
+++ b/basis/math/floats/half/half.factor
@@ -2,7 +2,7 @@
 USING: accessors alien.accessors alien.c-types alien.data
 alien.syntax kernel math math.order ;
 FROM: math => float ;
-IN: half-floats
+IN: math.floats.half
 
 : half>bits ( float -- bits )
     float>bits
diff --git a/basis/half-floats/summary.txt b/basis/math/floats/half/summary.txt
similarity index 100%
rename from basis/half-floats/summary.txt
rename to basis/math/floats/half/summary.txt
diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor
index 6e66832a2f..d1cb0357ed 100755
--- a/extra/gpu/render/render.factor
+++ b/extra/gpu/render/render.factor
@@ -4,7 +4,7 @@ assocs classes classes.mixin classes.parser classes.singleton classes.struct
 classes.tuple classes.tuple.private combinators combinators.tuple destructors fry
 generic generic.parser gpu gpu.buffers gpu.framebuffers
 gpu.framebuffers.private gpu.shaders gpu.shaders.private gpu.state
-gpu.textures gpu.textures.private half-floats images kernel
+gpu.textures gpu.textures.private math.floats.half images kernel
 lexer locals math math.order math.parser namespaces opengl
 opengl.gl parser quotations sequences slots sorting
 specialized-arrays strings ui.gadgets.worlds variants
diff --git a/extra/gpu/shaders/shaders.factor b/extra/gpu/shaders/shaders.factor
index 8a2931e431..d1c137128a 100755
--- a/extra/gpu/shaders/shaders.factor
+++ b/extra/gpu/shaders/shaders.factor
@@ -8,7 +8,7 @@ kernel lexer literals locals math math.parser memoize multiline namespaces
 opengl opengl.gl opengl.shaders parser quotations sequences
 specialized-arrays splitting strings tr ui.gadgets.worlds
 variants vectors vocabs vocabs.loader vocabs.parser words
-words.constant half-floats typed ;
+words.constant math.floats.half typed ;
 QUALIFIED-WITH: alien.c-types c
 SPECIALIZED-ARRAY: int
 SPECIALIZED-ARRAY: void*

From 84c79879dfba4ce786c34e403ef2eeca4817044e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 28 Apr 2010 18:41:36 -0700
Subject: [PATCH 077/158] game.models.half-edge words for walking half-edge
 model representation

---
 extra/game/models/half-edge/authors.txt       |  1 +
 .../models/half-edge/half-edge-tests.factor   | 66 +++++++++++++++++++
 extra/game/models/half-edge/half-edge.factor  | 51 ++++++++++++++
 extra/game/models/half-edge/summary.txt       |  1 +
 4 files changed, 119 insertions(+)
 create mode 100644 extra/game/models/half-edge/authors.txt
 create mode 100644 extra/game/models/half-edge/half-edge-tests.factor
 create mode 100644 extra/game/models/half-edge/half-edge.factor
 create mode 100644 extra/game/models/half-edge/summary.txt

diff --git a/extra/game/models/half-edge/authors.txt b/extra/game/models/half-edge/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/game/models/half-edge/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/game/models/half-edge/half-edge-tests.factor b/extra/game/models/half-edge/half-edge-tests.factor
new file mode 100644
index 0000000000..5431fcb077
--- /dev/null
+++ b/extra/game/models/half-edge/half-edge-tests.factor
@@ -0,0 +1,66 @@
+USING: accessors game.models.half-edge kernel sequences
+tools.test ;
+IN: game.models.half-edge.tests
+
+CONSTANT: cube-edges
+    {
+        T{ edge { face 0 } { vertex  0 } { opposite-edge  6 } { next-edge  1 } }
+        T{ edge { face 0 } { vertex  1 } { opposite-edge 19 } { next-edge  2 } }
+        T{ edge { face 0 } { vertex  3 } { opposite-edge 12 } { next-edge  3 } }
+        T{ edge { face 0 } { vertex  2 } { opposite-edge 21 } { next-edge  0 } }
+
+        T{ edge { face 1 } { vertex  4 } { opposite-edge 10 } { next-edge  5 } }
+        T{ edge { face 1 } { vertex  5 } { opposite-edge 16 } { next-edge  6 } }
+        T{ edge { face 1 } { vertex  1 } { opposite-edge  0 } { next-edge  7 } }
+        T{ edge { face 1 } { vertex  0 } { opposite-edge 20 } { next-edge  4 } }
+
+        T{ edge { face 2 } { vertex  6 } { opposite-edge 14 } { next-edge  9 } }
+        T{ edge { face 2 } { vertex  7 } { opposite-edge 17 } { next-edge 10 } }
+        T{ edge { face 2 } { vertex  5 } { opposite-edge  4 } { next-edge 11 } }
+        T{ edge { face 2 } { vertex  4 } { opposite-edge 23 } { next-edge  8 } }
+
+        T{ edge { face 3 } { vertex  2 } { opposite-edge  2 } { next-edge 13 } }
+        T{ edge { face 3 } { vertex  3 } { opposite-edge 22 } { next-edge 14 } }
+        T{ edge { face 3 } { vertex  7 } { opposite-edge  8 } { next-edge 15 } }
+        T{ edge { face 3 } { vertex  6 } { opposite-edge 18 } { next-edge 12 } }
+
+        T{ edge { face 4 } { vertex  1 } { opposite-edge  5 } { next-edge 17 } }
+        T{ edge { face 4 } { vertex  5 } { opposite-edge  9 } { next-edge 18 } }
+        T{ edge { face 4 } { vertex  7 } { opposite-edge 13 } { next-edge 19 } }
+        T{ edge { face 4 } { vertex  3 } { opposite-edge  1 } { next-edge 16 } }
+
+        T{ edge { face 5 } { vertex  4 } { opposite-edge  7 } { next-edge 21 } }
+        T{ edge { face 5 } { vertex  0 } { opposite-edge  3 } { next-edge 22 } }
+        T{ edge { face 5 } { vertex  2 } { opposite-edge 15 } { next-edge 23 } }
+        T{ edge { face 5 } { vertex  6 } { opposite-edge 11 } { next-edge 20 } }
+    }
+
+: connect-cube-edges ( -- )
+    cube-edges [
+        [ cube-edges nth ] change-opposite-edge
+        [ cube-edges nth ] change-next-edge
+        drop
+    ] each ;
+
+connect-cube-edges
+
+[ 0 1 ]
+[ cube-edges first edge-vertices ] unit-test
+
+[ { 0 0 0 } ]
+[ cube-edges first vertex-edges [ vertex>> ] map ] unit-test
+
+[ 3 ]
+[ cube-edges first vertex-valence ] unit-test
+
+[ { 0 1 3 2 } ]
+[ cube-edges first face-edges [ vertex>> ] map ] unit-test
+
+[ 4 ]
+[ cube-edges first face-sides ] unit-test
+
+[ { 1 4 2 } ]
+[ cube-edges first vertex-neighbors ] unit-test
+
+[ { 1 4 3 5 } ]
+[ cube-edges first face-neighbors ] unit-test
diff --git a/extra/game/models/half-edge/half-edge.factor b/extra/game/models/half-edge/half-edge.factor
new file mode 100644
index 0000000000..1b799bb4b3
--- /dev/null
+++ b/extra/game/models/half-edge/half-edge.factor
@@ -0,0 +1,51 @@
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays fry kernel locals math sequences ;
+IN: game.models.half-edge
+
+TUPLE: edge < identity-tuple face vertex opposite-edge next-edge ;
+
+: edge-vertices ( edge -- start end )
+    [ vertex>> ] [ opposite-edge>> vertex>> ] bi ;
+
+! building blocks for edge loop iteration
+
+: (collect) ( in quot iterator -- out )
+    [ collector ] dip dip >array ; inline
+
+: (reduce) ( in initial quot iterator -- accum )
+    [ swap ] 2dip call ; inline
+
+: (count) ( in iterator -- count )
+    [ 0 [ drop 1 + ] ] dip (reduce) ; inline
+
+: edge-loop ( ..a edge quot: ( ..a edge -- ..b ) next-edge-quot: ( ..b edge -- ..a edge' ) -- ..a )
+    pick '[ _ _ bi dup _ eq? not ] loop drop ; inline
+
+! iterate over related edges
+
+: each-vertex-edge ( ... edge quot: ( ... edge -- ... ) -- ... )
+    [ opposite-edge>> next-edge>> ] edge-loop ; inline
+
+: each-face-edge ( ... edge quot: ( ... edge -- ... ) -- ... )
+    [ next-edge>> ] edge-loop ; inline
+
+! 
+
+: vertex-edges ( edge -- edges )
+    [ ] [ each-vertex-edge ] (collect) ;
+
+: vertex-neighbors ( edge -- edges )
+    [ opposite-edge>> vertex>> ] [ each-vertex-edge ] (collect) ;
+
+: vertex-valence ( edge -- count )
+    [ each-vertex-edge ] (count) ;
+
+: face-edges ( edge -- edges )
+    [ ] [ each-face-edge ] (collect) ;
+
+: face-neighbors ( edge -- edges )
+    [ opposite-edge>> face>> ] [ each-face-edge ] (collect) ;
+
+: face-sides ( edge -- count )
+    [ each-face-edge ] (count) ;
+
diff --git a/extra/game/models/half-edge/summary.txt b/extra/game/models/half-edge/summary.txt
new file mode 100644
index 0000000000..6f0aac5c4a
--- /dev/null
+++ b/extra/game/models/half-edge/summary.txt
@@ -0,0 +1 @@
+Iterators for half-edge geometry structures

From 0aff35bfeece4d7d6c2edf742838a1f758031f3b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 28 Apr 2010 18:52:40 -0700
Subject: [PATCH 078/158] game.models.half-edge: additional vertex-diagonals
 word

---
 extra/game/models/half-edge/half-edge-tests.factor | 3 +++
 extra/game/models/half-edge/half-edge.factor       | 3 +++
 2 files changed, 6 insertions(+)

diff --git a/extra/game/models/half-edge/half-edge-tests.factor b/extra/game/models/half-edge/half-edge-tests.factor
index 5431fcb077..cbfe514d7e 100644
--- a/extra/game/models/half-edge/half-edge-tests.factor
+++ b/extra/game/models/half-edge/half-edge-tests.factor
@@ -62,5 +62,8 @@ connect-cube-edges
 [ { 1 4 2 } ]
 [ cube-edges first vertex-neighbors ] unit-test
 
+[ { 3 5 6 } ]
+[ cube-edges first vertex-diagonals ] unit-test
+
 [ { 1 4 3 5 } ]
 [ cube-edges first face-neighbors ] unit-test
diff --git a/extra/game/models/half-edge/half-edge.factor b/extra/game/models/half-edge/half-edge.factor
index 1b799bb4b3..eeb3e6116f 100644
--- a/extra/game/models/half-edge/half-edge.factor
+++ b/extra/game/models/half-edge/half-edge.factor
@@ -37,6 +37,9 @@ TUPLE: edge < identity-tuple face vertex opposite-edge next-edge ;
 : vertex-neighbors ( edge -- edges )
     [ opposite-edge>> vertex>> ] [ each-vertex-edge ] (collect) ;
 
+: vertex-diagonals ( edge -- edges )
+    [ next-edge>> opposite-edge>> vertex>> ] [ each-vertex-edge ] (collect) ;
+
 : vertex-valence ( edge -- count )
     [ each-vertex-edge ] (count) ;
 

From 91507274762c06b14398e6f99b2cec11a188f207 Mon Sep 17 00:00:00 2001
From: Sheepson Apprentice <sheeple@freebsd-x86-64.(none)>
Date: Thu, 29 Apr 2010 00:23:03 -0500
Subject: [PATCH 079/158] Fix echo bug again

---
 build-support/factor.sh | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/build-support/factor.sh b/build-support/factor.sh
index d8b547d8d6..9da4ae295a 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -195,8 +195,9 @@ find_architecture() {
 }
 
 write_test_program() {
-    $ECHO "#include <stdio.h>" > $C_WORD.c
-    $ECHO "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c
+    #! Must be 'echo'
+    echo "#include <stdio.h>" > $C_WORD.c
+    echo "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c
 }
 
 c_find_word_size() {

From 0c8ed1b9d73fa09e5df72273cfb5d5fbdaff546f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 29 Apr 2010 01:43:40 -0400
Subject: [PATCH 080/158] bootstrap.handbook: fix typo

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

diff --git a/basis/bootstrap/handbook/handbook.factor b/basis/bootstrap/handbook/handbook.factor
index ef7a456b7b..f680c0e328 100644
--- a/basis/bootstrap/handbook/handbook.factor
+++ b/basis/bootstrap/handbook/handbook.factor
@@ -1,4 +1,4 @@
 USING: vocabs.loader vocabs kernel ;
 IN: bootstrap.handbook
 
-{ "boostrap.handbook" "bootstrap.help" } "help.handbook" require-when
+{ "bootstrap.handbook" "bootstrap.help" } "help.handbook" require-when

From 4ee9e5336f4070f52a213e51d0613c2d0e98d15f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 29 Apr 2010 01:58:56 -0400
Subject: [PATCH 081/158] math.vectors.simd.cords: a dash of inline sauce

---
 basis/math/vectors/simd/cords/cords.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/math/vectors/simd/cords/cords.factor b/basis/math/vectors/simd/cords/cords.factor
index 815b34a90d..df7fbe9ecd 100644
--- a/basis/math/vectors/simd/cords/cords.factor
+++ b/basis/math/vectors/simd/cords/cords.factor
@@ -35,10 +35,10 @@ WHERE
 BOA-EFFECT define-inline
 
 : A-with ( n -- v )
-    [ A/2-with ] [ A/2-with ] bi cord-append ;
+    [ A/2-with ] [ A/2-with ] bi cord-append ; inline
 
 : A-cast ( v -- v' )
-    [ A/2-cast ] cord-map ;
+    [ A/2-cast ] cord-map ; inline
 
 M: A >pprint-sequence ;
 M: A pprint* pprint-object ;

From cea21f6a3db597d4232c59412703390661d3c2ca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 29 Apr 2010 02:28:05 -0400
Subject: [PATCH 082/158] math.vectors: (vmerge) shouldn't be generic

---
 basis/math/vectors/vectors.factor | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor
index 6cb16e5efc..cf3d339562 100644
--- a/basis/math/vectors/vectors.factor
+++ b/basis/math/vectors/vectors.factor
@@ -135,8 +135,7 @@ M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep conc
 GENERIC: (vmerge-tail) ( u v -- t )
 M: object (vmerge-tail) over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ; inline
 
-GENERIC: (vmerge) ( u v -- h t )
-M: object (vmerge)
+: (vmerge) ( u v -- h t )
     [ (vmerge-head) ] [ (vmerge-tail) ] 2bi ; inline
 
 GENERIC: vmerge ( u v -- w )

From 1672c34f9ff3171fd2981b966ce15729b59c824a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 29 Apr 2010 02:52:32 -0400
Subject: [PATCH 083/158] ui: use scroll delta information for smoother mouse
 scrolling on Windows and Mac OS X

---
 basis/ui/backend/cocoa/views/views.factor | 10 +++++-----
 basis/ui/backend/windows/windows.factor   |  7 ++++---
 basis/ui/backend/x11/x11.factor           |  4 ++--
 basis/ui/gadgets/sliders/sliders.factor   |  4 ++--
 basis/ui/gestures/gestures.factor         |  4 ++--
 basis/x11/events/events.factor            |  8 ++++----
 6 files changed, 19 insertions(+), 18 deletions(-)

diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor
index 19c451d909..331f26aa32 100644
--- a/basis/ui/backend/cocoa/views/views.factor
+++ b/basis/ui/backend/cocoa/views/views.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.data alien.strings
 arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
@@ -90,11 +90,11 @@ CONSTANT: key-codes
     [ drop window ]
     2tri send-button-up ;
 
-: send-wheel$ ( view event -- )
-    [ nip [ -> deltaX ] [ -> deltaY ] bi [ sgn neg ] bi@ 2array ]
+: send-scroll$ ( view event -- )
+    [ nip [ -> deltaX ] [ -> deltaY ] bi [ neg ] bi@ 2array ]
     [ mouse-location ]
     [ drop window ]
-    2tri send-wheel ;
+    2tri send-scroll ;
 
 : send-action$ ( view event gesture -- junk )
     [ drop window ] dip send-action f ;
@@ -206,7 +206,7 @@ CLASS: {
 }
 
 { "scrollWheel:" void { id SEL id }
-    [ nip send-wheel$ ]
+    [ nip send-scroll$ ]
 }
 
 { "keyDown:" void { id SEL id }
diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index 4e271a8280..9fa73d0311 100755
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -1,5 +1,5 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
-! Portions copyright (C) 2007, 2009 Slava Pestov.
+! Portions copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings arrays assocs ui
 ui.private ui.gadgets ui.gadgets.private ui.backend
@@ -475,7 +475,8 @@ SYMBOL: nc-buttons
     message>button nc-buttons get
     swap [ push ] [ remove! drop ] if ;
 
-: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
+: mouse-wheel ( wParam -- array )
+    >lo-hi [ -120 /f ] map ;
 
 : mouse-event>gesture ( uMsg -- button )
     key-modifiers swap message>button
@@ -534,7 +535,7 @@ SYMBOL: nc-buttons
     >lo-hi swap window move-hand fire-motion ;
 
 :: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
-    wParam mouse-wheel hand-loc get hWnd window send-wheel ;
+    wParam mouse-scroll hand-loc get hWnd window send-scroll ;
 
 : handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
     #! message sent if windows needs application to stop dragging
diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor
index fc7943efb0..ae849610a7 100644
--- a/basis/ui/backend/x11/x11.factor
+++ b/basis/ui/backend/x11/x11.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2010 Eduardo Cavazos and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types ascii assocs classes.struct combinators
 combinators.short-circuit command-line environment io.encodings.ascii
@@ -151,7 +151,7 @@ M: world button-up-event
 
 M: world wheel-event
     [ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
-    send-wheel ;
+    send-scroll ;
 
 M: world enter-event motion-event ;
 
diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor
index 6851ff4be7..867a53eb68 100644
--- a/basis/ui/gadgets/sliders/sliders.factor
+++ b/basis/ui/gadgets/sliders/sliders.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs kernel math namespaces sequences
 vectors models models.range math.vectors math.functions quotations
@@ -234,7 +234,7 @@ PRIVATE>
 : <slider> ( range orientation -- slider )
     slider new-track
         swap >>model
-        32 >>line
+        16 >>line
         dup orientation>> {
             [ <slider-pen> >>interior ]
             [ <thumb> >>thumb ]
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index 6e8e73ab55..c3e51c39ed 100644
--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs kernel math math.order models
 namespaces make sequences words strings system hashtables math.parser
@@ -304,7 +304,7 @@ SYMBOL: drag-timer
     stop-drag-timer
     button-gesture ;
 
-: send-wheel ( direction loc world -- )
+: send-scroll ( direction loc world -- )
     move-hand
     scroll-direction set-global
     mouse-scroll hand-gadget get-global propagate-gesture ;
diff --git a/basis/x11/events/events.factor b/basis/x11/events/events.factor
index febbbfa135..1a5b94c241 100644
--- a/basis/x11/events/events.factor
+++ b/basis/x11/events/events.factor
@@ -16,7 +16,7 @@ GENERIC: enter-event ( event window -- )
 
 GENERIC: leave-event ( event window -- )
 
-GENERIC: wheel-event ( event window -- )
+GENERIC: scroll-event ( event window -- )
 
 GENERIC: motion-event ( event window -- )
 
@@ -42,13 +42,13 @@ GENERIC: client-event ( event window -- )
 
 : events-queued ( mode -- n ) [ dpy get ] dip XEventsQueued ;
 
-: wheel? ( event -- ? ) button>> 4 7 between? ;
+: mouse-scroll? ( event -- ? ) button>> 4 7 between? ;
 
 : button-down-event$ ( event window -- )
-    over wheel? [ wheel-event ] [ button-down-event ] if ;
+    over mouse-scroll? [ scroll-event ] [ button-down-event ] if ;
 
 : button-up-event$ ( event window -- )
-    over wheel? [ 2drop ] [ button-up-event ] if ;
+    over mouse-scroll? [ 2drop ] [ button-up-event ] if ;
 
 : handle-event ( event window -- )
     swap dup XAnyEvent>> type>> {

From e82bbc54121f383ec9d36e215761d44315dd9953 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 29 Apr 2010 02:20:17 -0500
Subject: [PATCH 084/158] ui.backend.windows: fix compile error

---
 basis/ui/backend/windows/windows.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index 9fa73d0311..15f9cd263a 100755
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -475,7 +475,7 @@ SYMBOL: nc-buttons
     message>button nc-buttons get
     swap [ push ] [ remove! drop ] if ;
 
-: mouse-wheel ( wParam -- array )
+: mouse-scroll ( wParam -- array )
     >lo-hi [ -120 /f ] map ;
 
 : mouse-event>gesture ( uMsg -- button )

From aec2570cd336a0bd2cd72db7121ee324001149c5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 29 Apr 2010 03:59:31 -0400
Subject: [PATCH 085/158] ui.backend.x11: fix load error

---
 basis/ui/backend/x11/x11.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor
index ae849610a7..1cb1738007 100644
--- a/basis/ui/backend/x11/x11.factor
+++ b/basis/ui/backend/x11/x11.factor
@@ -149,7 +149,7 @@ M: world button-up-event
         { 7 { 1 0 } }
     } at ;
 
-M: world wheel-event
+M: world scroll-event
     [ [ mouse-event>scroll-direction ] [ event-loc ] bi ] dip
     send-scroll ;
 

From 79a3b71f47f955580a22371ed5561ea805885e54 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 29 Apr 2010 19:57:07 -0500
Subject: [PATCH 086/158] Demonstrate smart-if and smart-if* combinators

---
 basis/combinators/smart/smart-tests.factor | 10 +++++++++
 basis/combinators/smart/smart.factor       | 25 ++++++++++++++++++++--
 2 files changed, 33 insertions(+), 2 deletions(-)

diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor
index 11624dcf10..ec05bd67c3 100644
--- a/basis/combinators/smart/smart-tests.factor
+++ b/basis/combinators/smart/smart-tests.factor
@@ -63,3 +63,13 @@ IN: combinators.smart.tests
 
 [ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 3 smart-apply ] unit-test
 [ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 2 smart-apply ] unit-test
+
+[ 4 ] [ 2 [ even? ] [ 2 + ] smart-when ] unit-test
+[ 3 ] [ 3 [ even? ] [ 2 + ] smart-when ] unit-test
+[ 4 ] [ 2 [ odd? ] [ 2 + ] smart-unless ] unit-test
+[ 3 ] [ 3 [ odd? ] [ 2 + ] smart-unless ] unit-test
+
+[ 4 ] [ 2 [ even? ] [ 2 + ] smart-when* ] unit-test
+[ ] [ 3 [ even? ] [ 2 + ] smart-when* ] unit-test
+[ 3 ] [ 2 [ odd? ] [ 3 ] smart-unless* ] unit-test
+[ 3 ] [ 3 [ odd? ] [ 5 ] smart-unless* ] unit-test
diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor
index 5576421742..c4bb35ef4e 100644
--- a/basis/combinators/smart/smart.factor
+++ b/basis/combinators/smart/smart.factor
@@ -49,8 +49,29 @@ MACRO: preserving ( quot -- )
 MACRO: nullary ( quot -- quot' )
     dup outputs '[ @ _ ndrop ] ;
 
-MACRO: smart-if ( pred true false -- )
+MACRO: dropping ( quot -- quot' )
+    outputs '[ [ _ ndrop ] ] ;
+
+MACRO: balancing ( quot -- quot' )
+    '[ _ [ preserving ] [ dropping ] bi ] ;
+
+MACRO: smart-if ( pred true false -- quot )
     '[ _ preserving _ _ if ] ;
 
-MACRO: smart-apply ( quot n -- )
+MACRO: smart-when ( pred true -- quot )
+    '[ _ _ [ ] smart-if ] ;
+
+MACRO: smart-unless ( pred false -- quot )
+    '[ _ [ ] _ smart-if ] ;
+
+MACRO: smart-if* ( pred true false -- quot )
+    '[ _ balancing _ swap _ compose if ] ;
+
+MACRO: smart-when* ( pred true -- quot )
+    '[ _ _ [ ] smart-if* ] ;
+
+MACRO: smart-unless* ( pred false -- quot )
+    '[ _ [ ] _ smart-if* ] ;
+
+MACRO: smart-apply ( quot n -- quot )
     [ dup inputs ] dip '[ _ _ _ mnapply ] ;

From 242f8490c5ef71843709d242e0616e68c697c5b9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 29 Apr 2010 20:21:53 -0500
Subject: [PATCH 087/158] Fix smart-if* for multiple inputs and test. oops

---
 basis/combinators/smart/smart-tests.factor | 3 +++
 basis/combinators/smart/smart.factor       | 2 +-
 2 files changed, 4 insertions(+), 1 deletion(-)

diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor
index ec05bd67c3..8933c4bb39 100644
--- a/basis/combinators/smart/smart-tests.factor
+++ b/basis/combinators/smart/smart-tests.factor
@@ -73,3 +73,6 @@ IN: combinators.smart.tests
 [ ] [ 3 [ even? ] [ 2 + ] smart-when* ] unit-test
 [ 3 ] [ 2 [ odd? ] [ 3 ] smart-unless* ] unit-test
 [ 3 ] [ 3 [ odd? ] [ 5 ] smart-unless* ] unit-test
+
+[ -1 ] [ 1 2 [ + odd? ] [ - ] smart-when* ] unit-test
+[ ] [ 2 2 [ + odd? ] [ ] smart-unless* ] unit-test
diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor
index c4bb35ef4e..a907d2d297 100644
--- a/basis/combinators/smart/smart.factor
+++ b/basis/combinators/smart/smart.factor
@@ -50,7 +50,7 @@ MACRO: nullary ( quot -- quot' )
     dup outputs '[ @ _ ndrop ] ;
 
 MACRO: dropping ( quot -- quot' )
-    outputs '[ [ _ ndrop ] ] ;
+    inputs '[ [ _ ndrop ] ] ;
 
 MACRO: balancing ( quot -- quot' )
     '[ _ [ preserving ] [ dropping ] bi ] ;

From c02bb4bd17c354d41187d0d1ad474603721c56c0 Mon Sep 17 00:00:00 2001
From: unknown <erg@.(none)>
Date: Fri, 30 Apr 2010 08:06:06 -0500
Subject: [PATCH 088/158] Fix enter-fullscreen on windows

---
 basis/ui/backend/windows/windows.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index 15f9cd263a..c8fcabf2c6 100755
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -812,7 +812,7 @@ M: windows-ui-backend (ungrab-input) ( handle -- )
     f ClipCursor drop
     1 ShowCursor drop ;
 
-CONSTANT: fullscreen-flags { WS_CAPTION WS_BORDER WS_THICKFRAME }
+CONSTANT: fullscreen-flags flags{ WS_CAPTION WS_BORDER WS_THICKFRAME }
 
 : enter-fullscreen ( world -- )
     handle>> hWnd>>

From e15c02f3085e7f283ff693e8e559030452b93360 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 30 Apr 2010 08:42:29 -0500
Subject: [PATCH 089/158] Clean up math.polynomials some

---
 basis/math/polynomials/polynomials.factor | 24 +++++++++++------------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor
index 31152016ea..57c3c5b8ef 100644
--- a/basis/math/polynomials/polynomials.factor
+++ b/basis/math/polynomials/polynomials.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel make math math.order math.vectors sequences
-splitting vectors macros combinators math.bits ;
+USING: arrays combinators fry kernel macros make math math.bits
+math.order math.vectors sequences splitting vectors ;
 IN: math.polynomials
 
 <PRIVATE
@@ -26,17 +26,19 @@ PRIVATE>
 : 2ptrim ( p q -- p' q' ) [ ptrim ] bi@ ;
 : p+ ( p q -- r ) pextend v+ ;
 : p- ( p q -- r ) pextend v- ;
-: n*p ( n p -- n*p ) n*v ;
+ALIAS: n*p n*v
 
 : pextend-conv ( p q -- p' q' )
-    2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
+    2dup [ length ] bi@ + 1 - 2pad-tail ;
 
 : p* ( p q -- r )
-    2unempty pextend-conv <reversed> dup length iota
-    [ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
+    2unempty pextend-conv 
+    [ drop length [ iota ] keep ]
+    [ nip <reversed> ]
+    [ drop ] 2tri
+    '[ _ _ <slice> _ v* sum ] map reverse ;
 
-: p-sq ( p -- p^2 )
-    dup p* ;
+: p-sq ( p -- p^2 ) dup p* ; inline
 
 ERROR: negative-power-polynomial p n ;
 
@@ -56,9 +58,7 @@ ERROR: negative-power-polynomial p n ;
     dup 1 < [ drop 1 ] when
     [ over length + 0 pad-head pextend ] keep 1 + ;
 
-: /-last ( seq seq -- a )
-    #! divide the last two numbers in the sequences
-    [ last ] bi@ / ;
+: /-last ( seq1 seq2 -- x ) [ last ] bi@ / ;
 
 : (p/mod) ( p p -- p p )
     2dup /-last
@@ -75,7 +75,7 @@ PRIVATE>
 <PRIVATE
 
 : (pgcd) ( b a y x -- a d )
-    dup V{ 0 } clone p= [
+    dup V{ 0 } p= [
         drop nip
     ] [
         [ nip ] [ p/mod ] 2bi

From f67c62b0e4f66b221325e0a95995ec8ec3acbed7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 30 Apr 2010 14:04:45 -0500
Subject: [PATCH 090/158] Fix help lint for math.polynomials

---
 basis/math/polynomials/polynomials-docs.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor
index 3b8885cc88..dd55c3dd3f 100644
--- a/basis/math/polynomials/polynomials-docs.factor
+++ b/basis/math/polynomials/polynomials-docs.factor
@@ -56,14 +56,14 @@ HELP: p-
 { $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 } { 0 1 } p- ." "{ 1 0 1 }" } } ;
 
 HELP: n*p
-{ $values { "n" number } { "p" "a polynomial" } { "n*p" "a polynomial" } }
+{ $values { "n" number } { "v" "a polynomial" } { "w" "a polynomial" } }
 { $description "Multiplies each element of " { $snippet "p" } " by " { $snippet "n" } "." }
 { $examples { $example "USING: math.polynomials prettyprint ;" "4 { 3 0 1 } n*p ." "{ 12 0 4 }" } } ;
 
 HELP: pextend-conv
 { $values { "p" "a polynomial" } { "q" "a polynomial" } { "p'" "a polynomial" } { "q'" "a polynomial" } }
 { $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." }
-{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv [ . ] bi@" "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ;
+{ $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv [ . ] bi@" "{ 1 0 1 0 }\n{ 0 1 0 0 }" } } ;
 
 HELP: p*
 { $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }

From 64b248c5d504ee5e5814f6204ac4dba58977e137 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 1 May 2010 17:11:11 -0500
Subject: [PATCH 091/158] move images.bitmap.loading to images.bitmap

---
 basis/images/bitmap/bitmap-tests.factor    |   2 +-
 basis/images/bitmap/bitmap.factor          | 371 ++++++++++++++++++++-
 basis/images/bitmap/loading/loading.factor | 365 --------------------
 3 files changed, 368 insertions(+), 370 deletions(-)

diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor
index cebbe2f510..2ac2fed4d1 100644
--- a/basis/images/bitmap/bitmap-tests.factor
+++ b/basis/images/bitmap/bitmap-tests.factor
@@ -1,4 +1,4 @@
-USING: images.bitmap images.bitmap.loading images.testing kernel ;
+USING: images.bitmap images.testing kernel ;
 IN: images.bitmap.tests
 
 ! "vocab:images/testing/bmp/1bit.bmp" decode-test
diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor
index fa12aaa320..aa500e53fb 100644
--- a/basis/images/bitmap/bitmap.factor
+++ b/basis/images/bitmap/bitmap.factor
@@ -3,19 +3,382 @@
 USING: accessors alien alien.c-types arrays byte-arrays columns
 combinators compression.run-length endian fry grouping images
 images.loader images.normalization io io.binary
-io.encodings.binary io.encodings.string io.files
-io.streams.limited kernel locals macros math math.bitwise
-math.functions namespaces sequences specialized-arrays
-strings summary ;
+io.encodings.8-bit.latin1 io.encodings.binary
+io.encodings.string io.files io.streams.limited kernel locals
+macros math math.bitwise math.functions namespaces sequences
+specialized-arrays summary ;
+QUALIFIED-WITH: bitstreams b
 SPECIALIZED-ARRAYS: uint ushort ;
 IN: images.bitmap
 
+! http://www.fileformat.info/format/bmp/egff.htm
+! http://www.digicamsoft.com/bmp/bmp.html
+
 SINGLETON: bmp-image
 "bmp" bmp-image register-image-class
 
 : write2 ( n -- ) 2 >le write ;
 : write4 ( n -- ) 4 >le write ;
 
+ERROR: unknown-component-order bitmap ;
+ERROR: unknown-bitmap-header n ;
+
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
+
+TUPLE: loading-bitmap
+    file-header header
+    color-palette color-index bitfields ;
+
+TUPLE: file-header
+    { magic initial: "BM" }
+    { size }
+    { reserved1 initial: 0 }
+    { reserved2 initial: 0 }
+    { offset }
+    { header-length } ;
+
+TUPLE: v3-header
+    { width initial: 0 }
+    { height initial: 0 }
+    { planes initial: 0 }
+    { bit-count initial: 0 }
+    { compression initial: 0 }
+    { image-size initial: 0 }
+    { x-resolution initial: 0 }
+    { y-resolution initial: 0 }
+    { colors-used initial: 0 }
+    { colors-important initial: 0 } ;
+
+TUPLE: v4-header < v3-header
+    { red-mask initial: 0 }
+    { green-mask initial: 0 }
+    { blue-mask initial: 0 }
+    { alpha-mask initial: 0 }
+    { cs-type initial: 0 }
+    { end-points initial: 0 }
+    { gamma-red initial: 0 }
+    { gamma-green initial: 0 }
+    { gamma-blue initial: 0 } ;
+
+TUPLE: v5-header < v4-header
+    { intent initial: 0 }
+    { profile-data initial: 0 }
+    { profile-size initial: 0 }
+    { reserved3 initial: 0 } ;
+
+TUPLE: os2v1-header
+    { width initial: 0 }
+    { height initial: 0 }
+    { planes initial: 0 }
+    { bit-count initial: 0 } ;
+
+TUPLE: os2v2-header < os2v1-header
+    { compression initial: 0 }
+    { image-size initial: 0 }
+    { x-resolution initial: 0 }
+    { y-resolution initial: 0 }
+    { colors-used initial: 0 }
+    { colors-important initial: 0 }
+    { units initial: 0 }
+    { reserved initial: 0 }
+    { recording initial: 0 }
+    { rendering initial: 0 }
+    { size1 initial: 0 }
+    { size2 initial: 0 }
+    { color-encoding initial: 0 }
+    { identifier initial: 0 } ;
+
+UNION: v-header v3-header v4-header v5-header ;
+UNION: os2-header os2v1-header os2v2-header ;
+
+: parse-file-header ( -- file-header )
+    \ file-header new
+        2 read latin1 decode >>magic
+        read4 >>size
+        read2 >>reserved1
+        read2 >>reserved2
+        read4 >>offset
+        read4 >>header-length ;
+
+: read-v3-header-data ( header -- header )
+    read4 >>width
+    read4 32 >signed >>height
+    read2 >>planes
+    read2 >>bit-count
+    read4 >>compression
+    read4 >>image-size
+    read4 >>x-resolution
+    read4 >>y-resolution
+    read4 >>colors-used
+    read4 >>colors-important ;
+
+: read-v3-header ( -- header )
+    \ v3-header new
+        read-v3-header-data ;
+
+: read-v4-header-data ( header -- header )
+    read4 >>red-mask
+    read4 >>green-mask
+    read4 >>blue-mask
+    read4 >>alpha-mask
+    read4 >>cs-type
+    read4 read4 read4 3array >>end-points
+    read4 >>gamma-red
+    read4 >>gamma-green
+    read4 >>gamma-blue ;
+
+: read-v4-header ( -- v4-header )
+    \ v4-header new
+        read-v3-header-data
+        read-v4-header-data ;
+
+: read-v5-header-data ( v5-header -- v5-header )
+    read4 >>intent
+    read4 >>profile-data
+    read4 >>profile-size
+    read4 >>reserved3 ;
+
+: read-v5-header ( -- loading-bitmap )
+    \ v5-header new
+        read-v3-header-data
+        read-v4-header-data
+        read-v5-header-data ;
+
+: read-os2v1-header ( -- os2v1-header )
+    \ os2v1-header new
+        read2 >>width
+        read2 16 >signed >>height
+        read2 >>planes
+        read2 >>bit-count ;
+
+: read-os2v2-header-data ( os2v2-header -- os2v2-header )
+    read4 >>width
+    read4 32 >signed >>height
+    read2 >>planes
+    read2 >>bit-count
+    read4 >>compression
+    read4 >>image-size
+    read4 >>x-resolution
+    read4 >>y-resolution
+    read4 >>colors-used
+    read4 >>colors-important
+    read2 >>units
+    read2 >>reserved
+    read2 >>recording
+    read2 >>rendering
+    read4 >>size1
+    read4 >>size2
+    read4 >>color-encoding
+    read4 >>identifier ;
+
+: read-os2v2-header ( -- os2v2-header )
+    \ os2v2-header new
+        read-os2v2-header-data ;
+
+: parse-header ( n -- header )
+    {
+        { 12 [ read-os2v1-header ] }
+        { 64 [ read-os2v2-header ] }
+        { 40 [ read-v3-header ] }
+        { 108 [ read-v4-header ] }
+        { 124 [ read-v5-header ] }
+        [ unknown-bitmap-header ]
+    } case ;
+
+: color-index-length ( header -- n )
+    {
+        [ width>> ]
+        [ planes>> * ]
+        [ bit-count>> * 31 + 32 /i 4 * ]
+        [ height>> abs * ]
+    } cleave ;
+
+: color-palette-length ( loading-bitmap -- n )
+    file-header>>
+    [ offset>> 14 - ] [ header-length>> ] bi - ;
+
+: parse-color-palette ( loading-bitmap -- loading-bitmap )
+    dup color-palette-length read >>color-palette ;
+
+GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
+
+: parse-color-data ( loading-bitmap -- loading-bitmap )
+    dup header>> parse-color-data* ;
+
+M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
+    color-index-length read >>color-index ;
+
+M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
+    dup image-size>> [ 0 ] unless* dup 0 >
+    [ nip ] [ drop color-index-length ] if read >>color-index ;
+
+: alpha-used? ( loading-bitmap -- ? )
+    color-index>> 4 <sliced-groups> [ fourth 0 = ] all? not ;
+
+GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
+
+: bitmap>component-order ( loading-bitmap -- object )
+    dup header>> bitmap>component-order* ;
+
+: simple-bitmap>component-order ( loading-bitamp -- object )
+    header>> bit-count>> {
+        { 32 [ BGRX ] }
+        { 24 [ BGR ] }
+        { 16 [ BGR ] }
+        { 8 [ BGR ] }
+        { 4 [ BGR ] }
+        { 1 [ BGR ] }
+        [ unknown-component-order ]
+    } case ;
+
+: advanced-bitmap>component-order ( loading-bitmap -- object )
+    [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
+        { { 32 t } [ drop BGRA ] }
+        { { 32 f } [ drop BGRX ] }
+        [ drop simple-bitmap>component-order ]
+    } case ;
+
+: color-lookup3 ( loading-bitmap -- seq )
+    [ color-index>> >array ]
+    [ color-palette>> 3 <sliced-groups> ] bi
+    '[ _ nth ] map concat ;
+
+: color-lookup4 ( loading-bitmap -- seq )
+    [ color-index>> >array ]
+    [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
+    '[ _ nth ] map concat ;
+
+! os2v1 is 3bytes each, all others are 3 + 1 unused
+: color-lookup ( loading-bitmap -- seq )
+    dup file-header>> header-length>> {
+        { 12 [ color-lookup3 ] }
+        { 64 [ color-lookup4 ] }
+        { 40 [ color-lookup4 ] }
+        { 108 [ color-lookup4 ] }
+        { 124 [ color-lookup4 ] }
+    } case ;
+
+M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
+M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
+
+: uncompress-bitfield ( seq masks -- bytes' )
+    '[
+        _ [
+            [ bitand ] [ bit-count ] [ log2 ] tri - shift
+        ] with map
+    ] { } map-as B{ } concat-as ;
+
+ERROR: bmp-not-supported n ;
+
+: bitmap>bytes ( loading-bitmap -- byte-array )
+    dup header>> bit-count>>
+    {
+        { 32 [ color-index>> ] }
+        { 24 [ color-index>> ] }
+        { 16 [
+            [
+                ! byte-array>ushort-array
+                2 group [ le> ] map
+                ! 5 6 5
+                ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
+                ! 5 5 5
+                { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
+            ] change-color-index
+            color-index>>
+        ] }
+        { 8 [ color-lookup ] }
+        { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
+        { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
+        [ bmp-not-supported ]
+    } case >byte-array ;
+
+: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+    dup header>> bit-count>> {
+        { 16 [ dup color-palette>> 4 group [ le> ] map ] }
+        { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
+    } case reverse >>bitfields ;
+
+ERROR: unsupported-bitfield-widths n ;
+
+M: unsupported-bitfield-widths summary
+    drop "Bitmaps only support bitfield compression in 16/32bit images" ;
+
+: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+    set-bitfield-widths
+    dup header>> bit-count>> {
+        { 16 [
+            dup bitfields>> '[
+                byte-array>ushort-array _ uncompress-bitfield
+            ] change-color-index
+        ] }
+        { 32 [ ] }
+        [ unsupported-bitfield-widths ]
+    } case ;
+
+ERROR: unsupported-bitmap-compression compression ;
+
+GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
+
+: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
+    dup header>> uncompress-bitmap* ;
+
+M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+    drop ;
+
+: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
+    dupd '[
+        _ header>> [ width>> ] [ height>> ] bi
+        _ execute
+    ] change-color-index ; inline
+
+M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+    compression>> {
+        { f [ ] }
+        { 0 [ ] }
+        { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
+        { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
+        { 3 [ uncompress-bitfield-widths ] }
+        { 4 [ "jpeg" unsupported-bitmap-compression ] }
+        { 5 [ "png" unsupported-bitmap-compression ] }
+    } case ;
+
+ERROR: unsupported-bitmap-file magic ;
+
+: load-bitmap ( stream -- loading-bitmap )
+    [
+        \ loading-bitmap new
+        parse-file-header [ >>file-header ] [ ] bi magic>> {
+            { "BM" [
+                dup file-header>> header-length>> parse-header >>header
+                parse-color-palette
+                parse-color-data
+            ] }
+            ! { "BA" [ parse-os2-bitmap-array ] }
+            ! { "CI" [ parse-os2-color-icon ] }
+            ! { "CP" [ parse-os2-color-pointer ] }
+            ! { "IC" [ parse-os2-icon ] }
+            ! { "PT" [ parse-os2-pointer ] }
+            [ unsupported-bitmap-file ]
+        } case
+    ] with-input-stream ;
+
+: loading-bitmap>bytes ( loading-bitmap -- byte-array )
+    uncompress-bitmap bitmap>bytes ;
+
+M: bmp-image stream>image ( stream bmp-image -- bitmap )
+    drop load-bitmap
+    [ image new ] dip
+    {
+        [ loading-bitmap>bytes >>bitmap ]
+        [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
+        [ header>> height>> 0 < not >>upside-down? ]
+        [ bitmap>component-order >>component-order ubyte-components >>component-type ]
+    } cleave ;
+
 : output-width-and-height ( image -- )
     [ dim>> first write4 ]
     [
diff --git a/basis/images/bitmap/loading/loading.factor b/basis/images/bitmap/loading/loading.factor
index 702fd14472..16e0e459f5 100644
--- a/basis/images/bitmap/loading/loading.factor
+++ b/basis/images/bitmap/loading/loading.factor
@@ -5,368 +5,3 @@ compression.run-length fry grouping images images.loader io
 io.binary io.encodings.binary
 io.encodings.string io.streams.limited kernel math math.bitwise
 io.encodings.8-bit.latin1 sequences specialized-arrays summary images.bitmap ;
-QUALIFIED-WITH: bitstreams b
-SPECIALIZED-ARRAY: ushort
-IN: images.bitmap.loading
-
-! http://www.fileformat.info/format/bmp/egff.htm
-! http://www.digicamsoft.com/bmp/bmp.html
-
-ERROR: unknown-component-order bitmap ;
-ERROR: unknown-bitmap-header n ;
-
-: read2 ( -- n ) 2 read le> ;
-: read4 ( -- n ) 4 read le> ;
-
-TUPLE: loading-bitmap
-    file-header header
-    color-palette color-index bitfields ;
-
-TUPLE: file-header
-    { magic initial: "BM" }
-    { size }
-    { reserved1 initial: 0 }
-    { reserved2 initial: 0 }
-    { offset }
-    { header-length } ;
-
-TUPLE: v3-header
-    { width initial: 0 }
-    { height initial: 0 }
-    { planes initial: 0 }
-    { bit-count initial: 0 }
-    { compression initial: 0 }
-    { image-size initial: 0 }
-    { x-resolution initial: 0 }
-    { y-resolution initial: 0 }
-    { colors-used initial: 0 }
-    { colors-important initial: 0 } ;
-
-TUPLE: v4-header < v3-header
-    { red-mask initial: 0 }
-    { green-mask initial: 0 }
-    { blue-mask initial: 0 }
-    { alpha-mask initial: 0 }
-    { cs-type initial: 0 }
-    { end-points initial: 0 }
-    { gamma-red initial: 0 }
-    { gamma-green initial: 0 }
-    { gamma-blue initial: 0 } ;
-
-TUPLE: v5-header < v4-header
-    { intent initial: 0 }
-    { profile-data initial: 0 }
-    { profile-size initial: 0 }
-    { reserved3 initial: 0 } ;
-
-TUPLE: os2v1-header
-    { width initial: 0 }
-    { height initial: 0 }
-    { planes initial: 0 }
-    { bit-count initial: 0 } ;
-
-TUPLE: os2v2-header < os2v1-header
-    { compression initial: 0 }
-    { image-size initial: 0 }
-    { x-resolution initial: 0 }
-    { y-resolution initial: 0 }
-    { colors-used initial: 0 }
-    { colors-important initial: 0 }
-    { units initial: 0 }
-    { reserved initial: 0 }
-    { recording initial: 0 }
-    { rendering initial: 0 }
-    { size1 initial: 0 }
-    { size2 initial: 0 }
-    { color-encoding initial: 0 }
-    { identifier initial: 0 } ;
-
-UNION: v-header v3-header v4-header v5-header ;
-UNION: os2-header os2v1-header os2v2-header ;
-
-: parse-file-header ( -- file-header )
-    \ file-header new
-        2 read latin1 decode >>magic
-        read4 >>size
-        read2 >>reserved1
-        read2 >>reserved2
-        read4 >>offset
-        read4 >>header-length ;
-
-: read-v3-header-data ( header -- header )
-    read4 >>width
-    read4 32 >signed >>height
-    read2 >>planes
-    read2 >>bit-count
-    read4 >>compression
-    read4 >>image-size
-    read4 >>x-resolution
-    read4 >>y-resolution
-    read4 >>colors-used
-    read4 >>colors-important ;
-
-: read-v3-header ( -- header )
-    \ v3-header new
-        read-v3-header-data ;
-
-: read-v4-header-data ( header -- header )
-    read4 >>red-mask
-    read4 >>green-mask
-    read4 >>blue-mask
-    read4 >>alpha-mask
-    read4 >>cs-type
-    read4 read4 read4 3array >>end-points
-    read4 >>gamma-red
-    read4 >>gamma-green
-    read4 >>gamma-blue ;
-
-: read-v4-header ( -- v4-header )
-    \ v4-header new
-        read-v3-header-data
-        read-v4-header-data ;
-
-: read-v5-header-data ( v5-header -- v5-header )
-    read4 >>intent
-    read4 >>profile-data
-    read4 >>profile-size
-    read4 >>reserved3 ;
-
-: read-v5-header ( -- loading-bitmap )
-    \ v5-header new
-        read-v3-header-data
-        read-v4-header-data
-        read-v5-header-data ;
-
-: read-os2v1-header ( -- os2v1-header )
-    \ os2v1-header new
-        read2 >>width
-        read2 16 >signed >>height
-        read2 >>planes
-        read2 >>bit-count ;
-
-: read-os2v2-header-data ( os2v2-header -- os2v2-header )
-    read4 >>width
-    read4 32 >signed >>height
-    read2 >>planes
-    read2 >>bit-count
-    read4 >>compression
-    read4 >>image-size
-    read4 >>x-resolution
-    read4 >>y-resolution
-    read4 >>colors-used
-    read4 >>colors-important
-    read2 >>units
-    read2 >>reserved
-    read2 >>recording
-    read2 >>rendering
-    read4 >>size1
-    read4 >>size2
-    read4 >>color-encoding
-    read4 >>identifier ;
-
-: read-os2v2-header ( -- os2v2-header )
-    \ os2v2-header new
-        read-os2v2-header-data ;
-
-: parse-header ( n -- header )
-    {
-        { 12 [ read-os2v1-header ] }
-        { 64 [ read-os2v2-header ] }
-        { 40 [ read-v3-header ] }
-        { 108 [ read-v4-header ] }
-        { 124 [ read-v5-header ] }
-        [ unknown-bitmap-header ]
-    } case ;
-
-: color-index-length ( header -- n )
-    {
-        [ width>> ]
-        [ planes>> * ]
-        [ bit-count>> * 31 + 32 /i 4 * ]
-        [ height>> abs * ]
-    } cleave ;
-
-: color-palette-length ( loading-bitmap -- n )
-    file-header>>
-    [ offset>> 14 - ] [ header-length>> ] bi - ;
-
-: parse-color-palette ( loading-bitmap -- loading-bitmap )
-    dup color-palette-length read >>color-palette ;
-
-GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
-
-: parse-color-data ( loading-bitmap -- loading-bitmap )
-    dup header>> parse-color-data* ;
-
-M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
-    color-index-length read >>color-index ;
-
-M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
-    dup image-size>> [ 0 ] unless* dup 0 >
-    [ nip ] [ drop color-index-length ] if read >>color-index ;
-
-: alpha-used? ( loading-bitmap -- ? )
-    color-index>> 4 <sliced-groups> [ fourth 0 = ] all? not ;
-
-GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
-
-: bitmap>component-order ( loading-bitmap -- object )
-    dup header>> bitmap>component-order* ;
-
-: simple-bitmap>component-order ( loading-bitamp -- object )
-    header>> bit-count>> {
-        { 32 [ BGRX ] }
-        { 24 [ BGR ] }
-        { 16 [ BGR ] }
-        { 8 [ BGR ] }
-        { 4 [ BGR ] }
-        { 1 [ BGR ] }
-        [ unknown-component-order ]
-    } case ;
-
-: advanced-bitmap>component-order ( loading-bitmap -- object )
-    [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
-        { { 32 t } [ drop BGRA ] }
-        { { 32 f } [ drop BGRX ] }
-        [ drop simple-bitmap>component-order ]
-    } case ;
-
-: color-lookup3 ( loading-bitmap -- seq )
-    [ color-index>> >array ]
-    [ color-palette>> 3 <sliced-groups> ] bi
-    '[ _ nth ] map concat ;
-
-: color-lookup4 ( loading-bitmap -- seq )
-    [ color-index>> >array ]
-    [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
-    '[ _ nth ] map concat ;
-
-! os2v1 is 3bytes each, all others are 3 + 1 unused
-: color-lookup ( loading-bitmap -- seq )
-    dup file-header>> header-length>> {
-        { 12 [ color-lookup3 ] }
-        { 64 [ color-lookup4 ] }
-        { 40 [ color-lookup4 ] }
-        { 108 [ color-lookup4 ] }
-        { 124 [ color-lookup4 ] }
-    } case ;
-
-M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
-M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
-M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
-M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
-M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
-
-: uncompress-bitfield ( seq masks -- bytes' )
-    '[
-        _ [
-            [ bitand ] [ bit-count ] [ log2 ] tri - shift
-        ] with map
-    ] { } map-as B{ } concat-as ;
-
-ERROR: bmp-not-supported n ;
-
-: bitmap>bytes ( loading-bitmap -- byte-array )
-    dup header>> bit-count>>
-    {
-        { 32 [ color-index>> ] }
-        { 24 [ color-index>> ] }
-        { 16 [
-            [
-                ! byte-array>ushort-array
-                2 group [ le> ] map
-                ! 5 6 5
-                ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
-                ! 5 5 5
-                { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
-            ] change-color-index
-            color-index>>
-        ] }
-        { 8 [ color-lookup ] }
-        { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
-        { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
-        [ bmp-not-supported ]
-    } case >byte-array ;
-
-: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
-    dup header>> bit-count>> {
-        { 16 [ dup color-palette>> 4 group [ le> ] map ] }
-        { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
-    } case reverse >>bitfields ;
-
-ERROR: unsupported-bitfield-widths n ;
-
-M: unsupported-bitfield-widths summary
-    drop "Bitmaps only support bitfield compression in 16/32bit images" ;
-
-: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
-    set-bitfield-widths
-    dup header>> bit-count>> {
-        { 16 [
-            dup bitfields>> '[
-                byte-array>ushort-array _ uncompress-bitfield
-            ] change-color-index
-        ] }
-        { 32 [ ] }
-        [ unsupported-bitfield-widths ]
-    } case ;
-
-ERROR: unsupported-bitmap-compression compression ;
-
-GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
-
-: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
-    dup header>> uncompress-bitmap* ;
-
-M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
-    drop ;
-
-: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
-    dupd '[
-        _ header>> [ width>> ] [ height>> ] bi
-        _ execute
-    ] change-color-index ; inline
-
-M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
-    compression>> {
-        { f [ ] }
-        { 0 [ ] }
-        { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
-        { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
-        { 3 [ uncompress-bitfield-widths ] }
-        { 4 [ "jpeg" unsupported-bitmap-compression ] }
-        { 5 [ "png" unsupported-bitmap-compression ] }
-    } case ;
-
-ERROR: unsupported-bitmap-file magic ;
-
-: load-bitmap ( stream -- loading-bitmap )
-    [
-        \ loading-bitmap new
-        parse-file-header [ >>file-header ] [ ] bi magic>> {
-            { "BM" [
-                dup file-header>> header-length>> parse-header >>header
-                parse-color-palette
-                parse-color-data
-            ] }
-            ! { "BA" [ parse-os2-bitmap-array ] }
-            ! { "CI" [ parse-os2-color-icon ] }
-            ! { "CP" [ parse-os2-color-pointer ] }
-            ! { "IC" [ parse-os2-icon ] }
-            ! { "PT" [ parse-os2-pointer ] }
-            [ unsupported-bitmap-file ]
-        } case
-    ] with-input-stream ;
-
-: loading-bitmap>bytes ( loading-bitmap -- byte-array )
-    uncompress-bitmap bitmap>bytes ;
-
-M: bmp-image stream>image ( stream bmp-image -- bitmap )
-    drop load-bitmap
-    [ image new ] dip
-    {
-        [ loading-bitmap>bytes >>bitmap ]
-        [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
-        [ header>> height>> 0 < not >>upside-down? ]
-        [ bitmap>component-order >>component-order ubyte-components >>component-type ]
-    } cleave ;

From 155ede5ad7b6f37e6739b7db9e3ddfc904134a78 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sat, 1 May 2010 18:37:59 -0500
Subject: [PATCH 092/158] Fix normalization to take stride/padding bytes into
 account

---
 .../normalization/normalization-tests.factor  | 55 ++++++++++++-------
 .../images/normalization/normalization.factor | 16 ++++--
 2 files changed, 46 insertions(+), 25 deletions(-)

diff --git a/basis/images/normalization/normalization-tests.factor b/basis/images/normalization/normalization-tests.factor
index c85aed413f..3dd270f2c2 100644
--- a/basis/images/normalization/normalization-tests.factor
+++ b/basis/images/normalization/normalization-tests.factor
@@ -7,72 +7,87 @@ IN: images.normalization.tests
 ! 1>x
 
 [ B{ 255 255 } ]
-[ B{ 0 1 } A L permute ] unit-test
+[ B{ 0 1 } 2 2 A L permute ] unit-test
 
 [ B{ 255 255 255 255 } ]
-[ B{ 0 1 } A RG permute ] unit-test
+[ B{ 0 1 } 2 2 A RG permute ] unit-test
 
 [ B{ 255 255 255 255 255 255 } ]
-[ B{ 0 1 } A BGR permute ] unit-test
+[ B{ 0 1 } 2 2 A BGR permute ] unit-test
 
 [ B{ 0 255 255 255 1 255 255 255 } ]
-[ B{ 0 1 } A ABGR permute ] unit-test
+[ B{ 0 1 } 2 2 A ABGR permute ] unit-test
+
+! Difference stride
+! The last byte is padding, so it should not end up in the image
+
+[ B{ 255 255 } ]
+[ B{ 0 1 0 } 2 3 A L permute ] unit-test
+
+[ B{ 255 255 255 255 } ]
+[ B{ 0 1 0 } 2 3 A RG permute ] unit-test
+
+[ B{ 255 255 255 255 255 255 } ]
+[ B{ 0 1 0 } 2 3 A BGR permute ] unit-test
+
+[ B{ 0 255 255 255 1 255 255 255 } ]
+[ B{ 0 1 0 } 2 3 A ABGR permute ] unit-test
 
 ! 2>x
 
 [ B{ 0 2 } ]
-[ B{ 0 1 2 3 } LA L permute ] unit-test
+[ B{ 0 1 2 3 } 2 4 LA L permute ] unit-test
 
 [ B{ 255 255 255 255 } ]
-[ B{ 0 1 2 3 } LA RG permute ] unit-test
+[ B{ 0 1 2 3 } 2 4 LA RG permute ] unit-test
 
 [ B{ 255 255 255 255 255 255 } ]
-[ B{ 0 1 2 3 } LA BGR permute ] unit-test
+[ B{ 0 1 2 3 } 2 4 LA BGR permute ] unit-test
 
 [ B{ 1 255 255 255 3 255 255 255 } ]
-[ B{ 0 1 2 3 } LA ABGR permute ] unit-test
+[ B{ 0 1 2 3 } 2 4 LA ABGR permute ] unit-test
 
 ! 3>x
 
 [ B{ 255 255 } ]
-[ B{ 0 1 2 3 4 5 } RGB L permute ] unit-test
+[ B{ 0 1 2 3 4 5 } 2 6 RGB L permute ] unit-test
 
 [ B{ 0 1 3 4 } ]
-[ B{ 0 1 2 3 4 5 } RGB RG permute ] unit-test
+[ B{ 0 1 2 3 4 5 } 2 6 RGB RG permute ] unit-test
 
 [ B{ 2 1 0 5 4 3 } ]
-[ B{ 0 1 2 3 4 5 } RGB BGR permute ] unit-test
+[ B{ 0 1 2 3 4 5 } 2 6 RGB BGR permute ] unit-test
 
 [ B{ 255 2 1 0 255 5 4 3 } ]
-[ B{ 0 1 2 3 4 5 } RGB ABGR permute ] unit-test
+[ B{ 0 1 2 3 4 5 } 2 6 RGB ABGR permute ] unit-test
 
 ! 4>x
 
 [ B{ 255 255 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA L permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA L permute ] unit-test
 
 [ B{ 0 1 4 5 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA RG permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA RG permute ] unit-test
 
 [ B{ 2 1 0 6 5 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA BGR permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA BGR permute ] unit-test
 
 [ B{ 3 2 1 0 7 6 5 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA ABGR permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA ABGR permute ] unit-test
 
 ! Edge cases
 
 [ B{ 0 4 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA R permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA R permute ] unit-test
 
 [ B{ 255 0 1 2 255 4 5 6 } ]
-[ B{ 0 1 2 3 4 5 6 7 } RGBA XRGB permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 RGBA XRGB permute ] unit-test
 
 [ B{ 1 2 3 255 5 6 7 255 } ]
-[ B{ 0 1 2 3 4 5 6 7 } XRGB RGBA permute ] unit-test
+[ B{ 0 1 2 3 4 5 6 7 } 2 8 XRGB RGBA permute ] unit-test
 
 [ B{ 255 255 255 255 255 255 255 255 } ]
-[ B{ 0 1 } L RGBA permute ] unit-test
+[ B{ 0 1 } 2 2 L RGBA permute ] unit-test
 
 ! Invalid inputs
 
diff --git a/basis/images/normalization/normalization.factor b/basis/images/normalization/normalization.factor
index db68e4bad6..a73de4f7b8 100644
--- a/basis/images/normalization/normalization.factor
+++ b/basis/images/normalization/normalization.factor
@@ -25,15 +25,21 @@ CONSTANT: fill-value 255
         dup 4 >= [ drop fill-value ] [ _ nth ] if
     ] B{ } map-as ;
 
-:: permute ( bytes src-order dst-order -- new-bytes )
+:: permute ( bytes width stride src-order dst-order -- new-bytes )
     src-order name>> :> src
     dst-order name>> :> dst
-    bytes src length group
-    [ pad4 src dst permutation shuffle dst length head ]
-    map concat ;
+    bytes stride group
+    [
+        src length group width head
+        [ pad4 src dst permutation shuffle dst length head ] map concat
+    ] map concat ;
+
+: stride ( image -- n )
+    [ bitmap>> length ] [ dim>> second ] bi / ;
 
 : (reorder-components) ( image src-order dest-order -- image )
-    [ permute ] 2curry change-bitmap ;
+    [ [ ] [ dim>> first ] [ stride ] tri ] 2dip
+    '[ _ _ _ _ permute ] change-bitmap ;
 
 GENERIC: normalize-component-type* ( image component-type -- image )
 

From 0b025c61fc817a18d97a00bcce2397383ef857bd Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 1 May 2010 17:03:03 -0700
Subject: [PATCH 093/158] kernel: update *dip docs to match stack effects and
 not mention retain stack

---
 core/kernel/kernel-docs.factor | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index f977a0487b..8d63dfdf54 100644
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -792,14 +792,14 @@ HELP: prepose
 
 HELP: dip
 { $values { "x" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
+{ $description "Removes " { $snippet "x" } " from the datastack, calls " { $snippet "quot" } ", and restores " { $snippet "x" } " to the top of the datastack when " { $snippet "quot" } " is finished." }
 { $examples
     { $example "USING: arrays kernel math prettyprint ;" "10 20 30 [ / ] dip 2array ." "{ 1/2 30 }" }
 } ;
 
 HELP: 2dip
 { $values { "x" object } { "y" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "x" } " and " { $snippet "y" } " hidden on the retain stack." }
+{ $description "Removes " { $snippet "x" } " and " { $snippet "y" } " from the datastack, calls " { $snippet "quot" } ", and restores the removed objects to the top of the datastack when " { $snippet "quot" } " is finished." }
 { $notes "The following are equivalent:"
     { $code "[ [ foo bar ] dip ] dip" }
     { $code "[ foo bar ] 2dip" }
@@ -807,7 +807,7 @@ HELP: 2dip
 
 HELP: 3dip
 { $values { "x" object } { "y" object } { "z" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." }
+{ $description "Removes " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } " from the datastack, calls " { $snippet "quot" } ", and restores the removed objects to the top of the datastack when " { $snippet "quot" } " is finished." }
 { $notes "The following are equivalent:"
     { $code "[ [ [ foo bar ] dip ] dip ] dip" }
     { $code "[ foo bar ] 3dip" }
@@ -815,7 +815,7 @@ HELP: 3dip
 
 HELP: 4dip
 { $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" quotation } }
-{ $description "Calls " { $snippet "quot" } " with " { $snippet "w" } ", " { $snippet "x" } ", " { $snippet "y" } " and " { $snippet "z" } " hidden on the retain stack." }
+{ $description "Removes " { $snippet "w" } ", " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } " from the datastack, calls " { $snippet "quot" } ", and restores the removed objects to the top of the datastack when " { $snippet "quot" } " is finished." }
 { $notes "The following are equivalent:"
     { $code "[ [ [ [ foo bar ] dip ] dip ] dip ] dip" }
     { $code "[ foo bar ] 4dip" }

From 719a7d6ffd2c67955ff4ab4b2e12b1fa9a665585 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 2 May 2010 00:38:37 -0700
Subject: [PATCH 094/158] Use dinput as default windows game.input backend

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

diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor
index 9b514e77e0..213b638574 100644
--- a/basis/game/input/input.factor
+++ b/basis/game/input/input.factor
@@ -106,7 +106,7 @@ SYMBOLS: pressed released ;
     { } buttons-delta-as ; inline
 
 {
-    { [ os windows? ] [ "game.input.xinput" require ] }
+    { [ os windows? ] [ "game.input.dinput" require ] }
     { [ os macosx? ] [ "game.input.iokit" require ] }
     { [ os linux? ] [ "game.input.x11" require ] }
     [ ]

From 338c56847874fb145c65cc8cea49492bf1a9ad1a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 2 May 2010 01:25:46 -0700
Subject: [PATCH 095/158] joystick-demo: missing iota

---
 extra/joystick-demo/joystick-demo.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/joystick-demo/joystick-demo.factor b/extra/joystick-demo/joystick-demo.factor
index 05440c8ae4..63814dfbf8 100644
--- a/extra/joystick-demo/joystick-demo.factor
+++ b/extra/joystick-demo/joystick-demo.factor
@@ -88,7 +88,7 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
     <axis-gadget> [ >>raxis ] [ add-gadget-with-border ] bi-curry bi* ;
 
 :: (add-button-gadgets) ( gadget shelf -- )
-    gadget controller>> read-controller buttons>> length [
+    gadget controller>> read-controller buttons>> length iota [
         number>string [ drop ] <border-button>
         shelf over add-gadget drop
     ] map gadget (>>buttons) ;

From 3e3b85d27963efd0f5579f9a6f0ca62eccb2d12a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 2 May 2010 01:27:07 -0700
Subject: [PATCH 096/158] windows.directx.dinput: use macros to define format
 constants to avoid holding onto a bunch of useless symbols after deployment

---
 .../directx/dinput/constants/constants.factor | 80 +++++++++----------
 1 file changed, 40 insertions(+), 40 deletions(-)

diff --git a/basis/windows/directx/dinput/constants/constants.factor b/basis/windows/directx/dinput/constants/constants.factor
index ba4d750174..18f391a285 100644
--- a/basis/windows/directx/dinput/constants/constants.factor
+++ b/basis/windows/directx/dinput/constants/constants.factor
@@ -3,7 +3,7 @@ windows.com.syntax alien alien.c-types alien.data alien.syntax
 kernel system namespaces combinators sequences fry math accessors
 macros words quotations libc continuations generalizations
 splitting locals assocs init specialized-arrays memoize
-classes.struct strings arrays ;
+classes.struct strings arrays literals ;
 SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT
 IN: windows.directx.dinput.constants
 
@@ -20,12 +20,13 @@ SYMBOLS:
 
 <PRIVATE
 
+<<
+
 MEMO: c-type* ( name -- c-type ) c-type ;
 MEMO: heap-size* ( c-type -- n ) heap-size ;
 
 GENERIC: array-base-type ( c-type -- c-type' )
 M: object array-base-type ;
-M: string array-base-type "[" split1 drop ;
 M: array array-base-type first ;
 
 : (field-spec-of) ( field struct -- field-spec )
@@ -45,61 +46,59 @@ M: array array-base-type first ;
 : (flags) ( array -- n )
     0 [ (flag) bitor ] reduce ;
 
-: <DIOBJECTDATAFORMAT> ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- alien )
+: <DIOBJECTDATAFORMAT>-quot ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- quot )
     {
-        [ first dup word? [ get ] when ]
+        [ first dup word? [ '[ _ get ] ] [ drop [ f ] ] if ]
         [ second rot [ (offsetof) ] [ (sizeof) ] 2bi ]
         [ third * + ]
         [ fourth (flags) ]
         [ 4 swap nth (flag) ]
     } cleave
-    DIOBJECTDATAFORMAT <struct-boa> ;
+    '[ @ _ _ _ DIOBJECTDATAFORMAT <struct-boa> ] ;
 
-:: make-DIOBJECTDATAFORMAT-array ( struct array -- alien )
-    array length malloc-DIOBJECTDATAFORMAT-array :> alien
+:: make-DIOBJECTDATAFORMAT-array-quot ( struct array -- quot )
+    array length '[ _ malloc-DIOBJECTDATAFORMAT-array ]
     array [| args i |
-        struct args <DIOBJECTDATAFORMAT>
-        i alien set-nth
-    ] each-index
-    alien ;
+        struct args <DIOBJECTDATAFORMAT>-quot
+        i '[ _ pick set-nth ] compose compose
+    ] each-index ;
 
-: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
+>>
+
+MACRO: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
     [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
-    [ nip length ] [ make-DIOBJECTDATAFORMAT-array ] 2bi
-    DIDATAFORMAT <struct-boa> ;
-
-: initialize ( symbol quot -- )
-    call swap set-global ; inline
+    [ nip length ] [ make-DIOBJECTDATAFORMAT-array-quot ] 2bi
+    '[ _ _ _ _ _ @ DIDATAFORMAT <struct-boa> ] ;
 
 : (malloc-guid-symbol) ( symbol guid -- )
-    '[ _ execute( -- value ) malloc-byte-array ] initialize ;
+    '[ _ malloc-byte-array ] initialize ;
 
 : define-guid-constants ( -- )
     {
-        { GUID_XAxis_malloced          GUID_XAxis }
-        { GUID_YAxis_malloced          GUID_YAxis }
-        { GUID_ZAxis_malloced          GUID_ZAxis }
-        { GUID_RxAxis_malloced         GUID_RxAxis }
-        { GUID_RyAxis_malloced         GUID_RyAxis }
-        { GUID_RzAxis_malloced         GUID_RzAxis }
-        { GUID_Slider_malloced         GUID_Slider }
-        { GUID_Button_malloced         GUID_Button }
-        { GUID_Key_malloced            GUID_Key }
-        { GUID_POV_malloced            GUID_POV }
-        { GUID_Unknown_malloced        GUID_Unknown }
-        { GUID_SysMouse_malloced       GUID_SysMouse }
-        { GUID_SysKeyboard_malloced    GUID_SysKeyboard }
-        { GUID_Joystick_malloced       GUID_Joystick }
-        { GUID_SysMouseEm_malloced     GUID_SysMouseEm }
-        { GUID_SysMouseEm2_malloced    GUID_SysMouseEm2 }
-        { GUID_SysKeyboardEm_malloced  GUID_SysKeyboardEm }
-        { GUID_SysKeyboardEm2_malloced GUID_SysKeyboardEm2 }
+        { GUID_XAxis_malloced          $ GUID_XAxis }
+        { GUID_YAxis_malloced          $ GUID_YAxis }
+        { GUID_ZAxis_malloced          $ GUID_ZAxis }
+        { GUID_RxAxis_malloced         $ GUID_RxAxis }
+        { GUID_RyAxis_malloced         $ GUID_RyAxis }
+        { GUID_RzAxis_malloced         $ GUID_RzAxis }
+        { GUID_Slider_malloced         $ GUID_Slider }
+        { GUID_Button_malloced         $ GUID_Button }
+        { GUID_Key_malloced            $ GUID_Key }
+        { GUID_POV_malloced            $ GUID_POV }
+        { GUID_Unknown_malloced        $ GUID_Unknown }
+        { GUID_SysMouse_malloced       $ GUID_SysMouse }
+        { GUID_SysKeyboard_malloced    $ GUID_SysKeyboard }
+        { GUID_Joystick_malloced       $ GUID_Joystick }
+        { GUID_SysMouseEm_malloced     $ GUID_SysMouseEm }
+        { GUID_SysMouseEm2_malloced    $ GUID_SysMouseEm2 }
+        { GUID_SysKeyboardEm_malloced  $ GUID_SysKeyboardEm }
+        { GUID_SysKeyboardEm2_malloced $ GUID_SysKeyboardEm2 }
     } [ first2 (malloc-guid-symbol) ] each ;
 
 : define-joystick-format-constant ( -- )
     c_dfDIJoystick2 [
         DIDF_ABSAXIS
-        DIJOYSTATE2 heap-size
+        $[ DIJOYSTATE2 heap-size ]
         DIJOYSTATE2 {
             { GUID_XAxis_malloced  "lX"           0 { DIDFT_OPTIONAL DIDFT_AXIS   DIDFT_ANYINSTANCE } 0 }
             { GUID_YAxis_malloced  "lY"           0 { DIDFT_OPTIONAL DIDFT_AXIS   DIDFT_ANYINSTANCE } 0 }
@@ -271,7 +270,7 @@ M: array array-base-type first ;
 : define-mouse-format-constant ( -- )
     c_dfDIMouse2 [
         DIDF_RELAXIS
-        DIMOUSESTATE2 heap-size
+        $[ DIMOUSESTATE2 heap-size ]
         DIMOUSESTATE2 {
             { GUID_XAxis_malloced  "lX"         0 {                DIDFT_ANYINSTANCE DIDFT_AXIS   } 0 }
             { GUID_YAxis_malloced  "lY"         0 {                DIDFT_ANYINSTANCE DIDFT_AXIS   } 0 }
@@ -828,10 +827,11 @@ M: array array-base-type first ;
     define-guid-constants
     define-format-constants ;
 
-[ define-constants ] "windows.directx.dinput.constants" add-startup-hook
+! [ define-constants ] "windows.directx.dinput.constants" add-startup-hook
 
 : uninitialize ( variable quot -- )
-    '[ _ when* f ] change-global ; inline
+    [ '[ _ when* f ] change-global ]
+    [ drop global delete-at ] 2bi ; inline
 
 : free-dinput-constants ( -- )
     {

From 515296892ba9c411749940f501ec5a5bed4b29af Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 2 May 2010 11:23:51 -0700
Subject: [PATCH 097/158] windows.directx.dinput: forgot to reenable constant
 initialization

---
 basis/windows/directx/dinput/constants/constants.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/windows/directx/dinput/constants/constants.factor b/basis/windows/directx/dinput/constants/constants.factor
index 18f391a285..34ab130b59 100644
--- a/basis/windows/directx/dinput/constants/constants.factor
+++ b/basis/windows/directx/dinput/constants/constants.factor
@@ -827,7 +827,7 @@ MACRO: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
     define-guid-constants
     define-format-constants ;
 
-! [ define-constants ] "windows.directx.dinput.constants" add-startup-hook
+[ define-constants ] "windows.directx.dinput.constants" add-startup-hook
 
 : uninitialize ( variable quot -- )
     [ '[ _ when* f ] change-global ]

From c167646e3b0ab705dca8595fbe7400bf4425e236 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 2 May 2010 18:14:30 -0700
Subject: [PATCH 098/158] windows.directx.dinput: pre-construct some
 intermediate structs to slightly improve horrible compilation time on the
 gigantic macro expansions

---
 basis/windows/directx/dinput/constants/constants.factor | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/basis/windows/directx/dinput/constants/constants.factor b/basis/windows/directx/dinput/constants/constants.factor
index 34ab130b59..6a2d9b148d 100644
--- a/basis/windows/directx/dinput/constants/constants.factor
+++ b/basis/windows/directx/dinput/constants/constants.factor
@@ -48,13 +48,15 @@ M: array array-base-type first ;
 
 : <DIOBJECTDATAFORMAT>-quot ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- quot )
     {
-        [ first dup word? [ '[ _ get ] ] [ drop [ f ] ] if ]
+        [ drop f ]
         [ second rot [ (offsetof) ] [ (sizeof) ] 2bi ]
         [ third * + ]
         [ fourth (flags) ]
         [ 4 swap nth (flag) ]
+        [ first dup word? [ '[ _ get ] ] [ drop [ f ] ] if ]
     } cleave
-    '[ @ _ _ _ DIOBJECTDATAFORMAT <struct-boa> ] ;
+    [ DIOBJECTDATAFORMAT <struct-boa> ] dip
+    '[ _ clone @ >>pguid ] ;
 
 :: make-DIOBJECTDATAFORMAT-array-quot ( struct array -- quot )
     array length '[ _ malloc-DIOBJECTDATAFORMAT-array ]

From 7e2d32b7d2f6af7067dd1951f667f3448085f9e8 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 2 May 2010 22:29:59 -0700
Subject: [PATCH 099/158] windows.errors, debugger.windows: improve description
 of Windows error objects

---
 basis/debugger/windows/windows.factor | 16 ++++++++++++++--
 basis/windows/errors/errors.factor    | 10 ++++++----
 2 files changed, 20 insertions(+), 6 deletions(-)

diff --git a/basis/debugger/windows/windows.factor b/basis/debugger/windows/windows.factor
index 73c6b0e795..662d07d037 100644
--- a/basis/debugger/windows/windows.factor
+++ b/basis/debugger/windows/windows.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs debugger io kernel literals math.parser namespaces
-prettyprint sequences system windows.kernel32 ;
+USING: accessors assocs debugger io kernel literals math.parser
+namespaces prettyprint sequences system windows.kernel32
+windows.ole32 windows.errors math ;
 IN: debugger.windows
 
 CONSTANT: seh-names
@@ -41,3 +42,14 @@ CONSTANT: seh-names
 M: windows signal-error.
     "Windows exception 0x" write
     third [ >hex write ] [ seh-name. ] bi nl ;
+
+M: ole32-error error.
+    "COM error 0x" write
+    dup code>> HEX: ffff,ffff bitand >hex write ": " write
+    message>> write ;
+
+M: windows-error error.
+    "Win32 error 0x" write
+    dup n>> HEX: ffff,ffff bitand >hex write ": " write
+    string>> write ;
+
diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor
index a3dbaf40ff..a4943ef877 100755
--- a/basis/windows/errors/errors.factor
+++ b/basis/windows/errors/errors.factor
@@ -1,7 +1,8 @@
 USING: alien.data kernel locals math math.bitwise
 windows.kernel32 sequences byte-arrays unicode.categories
 io.encodings.string io.encodings.utf16n alien.strings
-arrays literals windows.types specialized-arrays ;
+arrays literals windows.types specialized-arrays
+math.parser ;
 SPECIALIZED-ARRAY: TCHAR
 IN: windows.errors
 
@@ -703,7 +704,6 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK   HEX: 000000FF
 : make-lang-id ( lang1 lang2 -- n )
     10 shift bitor ; inline
 
-ERROR: error-message-failed id ;
 :: n>win32-error-string ( id -- string )
     flags{
         FORMAT_MESSAGE_FROM_SYSTEM
@@ -713,8 +713,10 @@ ERROR: error-message-failed id ;
     id
     LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
     32768 [ TCHAR <c-array> ] [ ] bi
-    f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip
-    utf16n alien>string [ blank? ] trim ;
+    f pick [ FormatMessage ] dip
+    swap zero?
+    [ drop "Unknown error 0x" id HEX: ffff,ffff bitand >hex append ]
+    [ utf16n alien>string [ blank? ] trim ] if ;
 
 : win32-error-string ( -- str )
     GetLastError n>win32-error-string ;

From 8e3323003915734fb9cb75c97090cdeb3577a299 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 2 May 2010 22:40:54 -0700
Subject: [PATCH 100/158] tools.deploy.shaker: adjust fallback error handler
 message so it looks better in a Win32 MessageBox

---
 basis/tools/deploy/shaker/strip-ui-error-hook.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/tools/deploy/shaker/strip-ui-error-hook.factor b/basis/tools/deploy/shaker/strip-ui-error-hook.factor
index 2525145828..0664dc5e8e 100644
--- a/basis/tools/deploy/shaker/strip-ui-error-hook.factor
+++ b/basis/tools/deploy/shaker/strip-ui-error-hook.factor
@@ -1,7 +1,7 @@
 USING: namespaces tools.deploy.config fry sequences system kernel ui ui.gadgets.worlds ;
 
 deploy-name get "Factor" or '[
-    _ " encountered an unhandled error." append
-    "The application will now exit."
+    _ " encountered an error." append
+    "The application encountered an error it cannot recover from and will now exit."
     system-alert die
 ] ui-error-hook set-global

From 503c0fcfde968d1604e90aa4837bf4e2188b498e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 19 Apr 2010 14:05:55 -0500
Subject: [PATCH 101/158] compiler: Start using tagged-rep for stuff, and split
 up compiler.cfg.representations into several sub-vocabularies

---
 .../cfg/alias-analysis/alias-analysis.factor  |   2 +-
 basis/compiler/cfg/gc-checks/gc-checks.factor |   4 +-
 .../cfg/instructions/instructions.factor      | 266 ++++++-------
 .../linear-scan/assignment/assignment.factor  |   4 +-
 .../representations/conversion/authors.txt    |   1 +
 .../conversion/conversion.factor              |  75 ++++
 .../representations/representations.factor    | 360 +-----------------
 .../cfg/representations/rewrite/authors.txt   |   1 +
 .../representations/rewrite/rewrite.factor    | 149 ++++++++
 .../cfg/representations/selection/authors.txt |   1 +
 .../selection/selection.factor                | 143 +++++++
 .../cfg/save-contexts/save-contexts.factor    |   4 +-
 basis/cpu/ppc/ppc.factor                      |   1 +
 basis/cpu/x86/64/64.factor                    |   4 +-
 14 files changed, 516 insertions(+), 499 deletions(-)
 create mode 100644 basis/compiler/cfg/representations/conversion/authors.txt
 create mode 100644 basis/compiler/cfg/representations/conversion/conversion.factor
 create mode 100644 basis/compiler/cfg/representations/rewrite/authors.txt
 create mode 100644 basis/compiler/cfg/representations/rewrite/rewrite.factor
 create mode 100644 basis/compiler/cfg/representations/selection/authors.txt
 create mode 100644 basis/compiler/cfg/representations/selection/selection.factor

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 2e0684c5d0..d34d40f341 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -238,7 +238,7 @@ M: insn analyze-aliases*
     ! a new value, except boxing instructions haven't been
     ! inserted yet.
     dup defs-vreg [
-        over defs-vreg-rep int-rep eq?
+        over defs-vreg-rep { int-rep tagged-rep } member?
         [ set-heap-ac ] [ set-new-ac ] if
     ] when* ;
 
diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor
index 6d192ec54a..d151c725e2 100644
--- a/basis/compiler/cfg/gc-checks/gc-checks.factor
+++ b/basis/compiler/cfg/gc-checks/gc-checks.factor
@@ -32,8 +32,8 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
 
 : insert-gc-check ( bb -- )
     dup dup '[
-        int-rep next-vreg-rep
-        int-rep next-vreg-rep
+        tagged-rep next-vreg-rep
+        tagged-rep next-vreg-rep
         _ allocation-size
         f
         f
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 5ddf7b4db5..6d18b05740 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -22,15 +22,15 @@ TUPLE: pure-insn < insn ;
 
 ! Stack operations
 INSN: ##load-immediate
-def: dst/int-rep
+def: dst/tagged-rep
 constant: val ;
 
 INSN: ##load-reference
-def: dst/int-rep
+def: dst/tagged-rep
 constant: obj ;
 
 INSN: ##load-constant
-def: dst/int-rep
+def: dst/tagged-rep
 constant: obj ;
 
 INSN: ##load-double
@@ -38,11 +38,11 @@ def: dst/double-rep
 constant: val ;
 
 INSN: ##peek
-def: dst/int-rep
+def: dst/tagged-rep
 literal: loc ;
 
 INSN: ##replace
-use: src/int-rep
+use: src/tagged-rep
 literal: loc ;
 
 INSN: ##inc-d
@@ -65,34 +65,34 @@ INSN: ##no-tco ;
 
 ! Jump tables
 INSN: ##dispatch
-use: src/int-rep
+use: src/tagged-rep
 temp: temp/int-rep ;
 
 ! Slot access
 INSN: ##slot
-def: dst/int-rep
-use: obj/int-rep slot/int-rep ;
+def: dst/tagged-rep
+use: obj/tagged-rep slot/tagged-rep ;
 
 INSN: ##slot-imm
-def: dst/int-rep
-use: obj/int-rep
+def: dst/tagged-rep
+use: obj/tagged-rep
 literal: slot tag ;
 
 INSN: ##set-slot
-use: src/int-rep obj/int-rep slot/int-rep ;
+use: src/tagged-rep obj/tagged-rep slot/tagged-rep ;
 
 INSN: ##set-slot-imm
-use: src/int-rep obj/int-rep
+use: src/tagged-rep obj/tagged-rep
 literal: slot tag ;
 
 ! String element access
 INSN: ##string-nth
-def: dst/int-rep
-use: obj/int-rep index/int-rep
+def: dst/tagged-rep
+use: obj/tagged-rep index/tagged-rep
 temp: temp/int-rep ;
 
 INSN: ##set-string-nth-fast
-use: src/int-rep obj/int-rep index/int-rep
+use: src/tagged-rep obj/tagged-rep index/tagged-rep
 temp: temp/int-rep ;
 
 PURE-INSN: ##copy
@@ -102,105 +102,105 @@ literal: rep ;
 
 ! Integer arithmetic
 PURE-INSN: ##add
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 PURE-INSN: ##add-imm
-def: dst/int-rep
-use: src1/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
 constant: src2 ;
 
 PURE-INSN: ##sub
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 PURE-INSN: ##sub-imm
-def: dst/int-rep
-use: src1/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
 constant: src2 ;
 
 PURE-INSN: ##mul
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 PURE-INSN: ##mul-imm
-def: dst/int-rep
-use: src1/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
 constant: src2 ;
 
 PURE-INSN: ##and
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 PURE-INSN: ##and-imm
-def: dst/int-rep
-use: src1/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
 constant: src2 ;
 
 PURE-INSN: ##or
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 PURE-INSN: ##or-imm
-def: dst/int-rep
-use: src1/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
 constant: src2 ;
 
 PURE-INSN: ##xor
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 PURE-INSN: ##xor-imm
-def: dst/int-rep
-use: src1/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
 constant: src2 ;
 
 PURE-INSN: ##shl
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 PURE-INSN: ##shl-imm
-def: dst/int-rep
-use: src1/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
 constant: src2 ;
 
 PURE-INSN: ##shr
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 PURE-INSN: ##shr-imm
-def: dst/int-rep
-use: src1/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
 constant: src2 ;
 
 PURE-INSN: ##sar
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 PURE-INSN: ##sar-imm
-def: dst/int-rep
-use: src1/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
 constant: src2 ;
 
 PURE-INSN: ##min
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 PURE-INSN: ##max
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 PURE-INSN: ##not
-def: dst/int-rep
-use: src/int-rep ;
+def: dst/tagged-rep
+use: src/tagged-rep ;
 
 PURE-INSN: ##neg
-def: dst/int-rep
-use: src/int-rep ;
+def: dst/tagged-rep
+use: src/tagged-rep ;
 
 PURE-INSN: ##log2
-def: dst/int-rep
-use: src/int-rep ;
+def: dst/tagged-rep
+use: src/tagged-rep ;
 
 ! Float arithmetic
 PURE-INSN: ##add-float
@@ -253,12 +253,12 @@ use: src/double-rep ;
 
 ! Float/integer conversion
 PURE-INSN: ##float>integer
-def: dst/int-rep
+def: dst/tagged-rep
 use: src/double-rep ;
 
 PURE-INSN: ##integer>float
 def: dst/double-rep
-use: src/int-rep ;
+use: src/tagged-rep ;
 
 ! SIMD operations
 PURE-INSN: ##zero-vector
@@ -340,7 +340,7 @@ use: src1 src2
 literal: rep cc ;
 
 PURE-INSN: ##test-vector
-def: dst/int-rep
+def: dst/tagged-rep
 use: src1
 temp: temp/int-rep
 literal: rep vcc ;
@@ -508,13 +508,13 @@ literal: rep ;
 
 ! Scalar/vector conversion
 PURE-INSN: ##scalar>integer
-def: dst/int-rep
+def: dst/tagged-rep
 use: src
 literal: rep ;
 
 PURE-INSN: ##integer>scalar
 def: dst
-use: src/int-rep
+use: src/tagged-rep
 literal: rep ;
 
 PURE-INSN: ##vector>scalar
@@ -529,26 +529,26 @@ literal: rep ;
 
 ! Boxing and unboxing aliens
 PURE-INSN: ##box-alien
-def: dst/int-rep
-use: src/int-rep
+def: dst/tagged-rep
+use: src/tagged-rep
 temp: temp/int-rep ;
 
 PURE-INSN: ##box-displaced-alien
-def: dst/int-rep
-use: displacement/int-rep base/int-rep
+def: dst/tagged-rep
+use: displacement/tagged-rep base/tagged-rep
 temp: temp/int-rep
 literal: base-class ;
 
 PURE-INSN: ##unbox-any-c-ptr
-def: dst/int-rep
-use: src/int-rep ;
+def: dst/tagged-rep
+use: src/tagged-rep ;
 
 : ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
 : ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
 
 PURE-INSN: ##unbox-alien
-def: dst/int-rep
-use: src/int-rep ;
+def: dst/tagged-rep
+use: src/tagged-rep ;
 
 : ##unbox-c-ptr ( dst src class -- )
     {
@@ -560,116 +560,116 @@ use: src/int-rep ;
 
 ! Alien accessors
 INSN: ##alien-unsigned-1
-def: dst/int-rep
-use: src/int-rep
+def: dst/tagged-rep
+use: src/tagged-rep
 literal: offset ;
 
 INSN: ##alien-unsigned-2
-def: dst/int-rep
-use: src/int-rep
+def: dst/tagged-rep
+use: src/tagged-rep
 literal: offset ;
 
 INSN: ##alien-unsigned-4
-def: dst/int-rep
-use: src/int-rep
+def: dst/tagged-rep
+use: src/tagged-rep
 literal: offset ;
 
 INSN: ##alien-signed-1
-def: dst/int-rep
-use: src/int-rep
+def: dst/tagged-rep
+use: src/tagged-rep
 literal: offset ;
 
 INSN: ##alien-signed-2
-def: dst/int-rep
-use: src/int-rep
+def: dst/tagged-rep
+use: src/tagged-rep
 literal: offset ;
 
 INSN: ##alien-signed-4
-def: dst/int-rep
-use: src/int-rep
+def: dst/tagged-rep
+use: src/tagged-rep
 literal: offset ;
 
 INSN: ##alien-cell
-def: dst/int-rep
-use: src/int-rep
+def: dst/tagged-rep
+use: src/tagged-rep
 literal: offset ;
 
 INSN: ##alien-float
 def: dst/float-rep
-use: src/int-rep
+use: src/tagged-rep
 literal: offset ;
 
 INSN: ##alien-double
 def: dst/double-rep
-use: src/int-rep
+use: src/tagged-rep
 literal: offset ;
 
 INSN: ##alien-vector
 def: dst
-use: src/int-rep
+use: src/tagged-rep
 literal: offset rep ;
 
 INSN: ##set-alien-integer-1
-use: src/int-rep
+use: src/tagged-rep
 literal: offset
-use: value/int-rep ;
+use: value/tagged-rep ;
 
 INSN: ##set-alien-integer-2
-use: src/int-rep
+use: src/tagged-rep
 literal: offset
-use: value/int-rep ;
+use: value/tagged-rep ;
 
 INSN: ##set-alien-integer-4
-use: src/int-rep
+use: src/tagged-rep
 literal: offset
-use: value/int-rep ;
+use: value/tagged-rep ;
 
 INSN: ##set-alien-cell
-use: src/int-rep
+use: src/tagged-rep
 literal: offset
-use: value/int-rep ;
+use: value/tagged-rep ;
 
 INSN: ##set-alien-float
-use: src/int-rep
+use: src/tagged-rep
 literal: offset
 use: value/float-rep ;
 
 INSN: ##set-alien-double
-use: src/int-rep
+use: src/tagged-rep
 literal: offset
 use: value/double-rep ;
 
 INSN: ##set-alien-vector
-use: src/int-rep
+use: src/tagged-rep
 literal: offset
 use: value
 literal: rep ;
 
 ! Memory allocation
 INSN: ##allot
-def: dst/int-rep
+def: dst/tagged-rep
 literal: size class
 temp: temp/int-rep ;
 
 INSN: ##write-barrier
-use: src/int-rep slot/int-rep
+use: src/tagged-rep slot/tagged-rep
 temp: temp1/int-rep temp2/int-rep ;
 
 INSN: ##write-barrier-imm
-use: src/int-rep
+use: src/tagged-rep
 literal: slot
 temp: temp1/int-rep temp2/int-rep ;
 
 INSN: ##alien-global
-def: dst/int-rep
+def: dst/tagged-rep
 literal: symbol library ;
 
 INSN: ##vm-field
-def: dst/int-rep
+def: dst/tagged-rep
 literal: offset ;
 
 INSN: ##set-vm-field
-use: src/int-rep
+use: src/tagged-rep
 literal: offset ;
 
 ! FFI
@@ -697,23 +697,23 @@ literal: inputs ;
 
 ! Conditionals
 INSN: ##compare-branch
-use: src1/int-rep src2/int-rep
+use: src1/tagged-rep src2/tagged-rep
 literal: cc ;
 
 INSN: ##compare-imm-branch
-use: src1/int-rep
+use: src1/tagged-rep
 constant: src2
 literal: cc ;
 
 PURE-INSN: ##compare
-def: dst/int-rep
-use: src1/int-rep src2/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep
 literal: cc
 temp: temp/int-rep ;
 
 PURE-INSN: ##compare-imm
-def: dst/int-rep
-use: src1/int-rep
+def: dst/tagged-rep
+use: src1/tagged-rep
 constant: src2
 literal: cc
 temp: temp/int-rep ;
@@ -727,29 +727,29 @@ use: src1/double-rep src2/double-rep
 literal: cc ;
 
 PURE-INSN: ##compare-float-ordered
-def: dst/int-rep
+def: dst/tagged-rep
 use: src1/double-rep src2/double-rep
 literal: cc
 temp: temp/int-rep ;
 
 PURE-INSN: ##compare-float-unordered
-def: dst/int-rep
+def: dst/tagged-rep
 use: src1/double-rep src2/double-rep
 literal: cc
 temp: temp/int-rep ;
 
 ! Overflowing arithmetic
 INSN: ##fixnum-add
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 INSN: ##fixnum-sub
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 INSN: ##fixnum-mul
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 INSN: ##gc
 temp: temp1/int-rep temp2/int-rep
@@ -774,7 +774,7 @@ literal: label ;
 INSN: _loop-entry ;
 
 INSN: _dispatch
-use: src/int-rep
+use: src/tagged-rep
 temp: temp ;
 
 INSN: _dispatch-label
@@ -782,40 +782,40 @@ literal: label ;
 
 INSN: _compare-branch
 literal: label
-use: src1/int-rep src2/int-rep
+use: src1/tagged-rep src2/tagged-rep
 literal: cc ;
 
 INSN: _compare-imm-branch
 literal: label
-use: src1/int-rep
+use: src1/tagged-rep
 constant: src2
 literal: cc ;
 
 INSN: _compare-float-unordered-branch
 literal: label
-use: src1/int-rep src2/int-rep
+use: src1/tagged-rep src2/tagged-rep
 literal: cc ;
 
 INSN: _compare-float-ordered-branch
 literal: label
-use: src1/int-rep src2/int-rep
+use: src1/tagged-rep src2/tagged-rep
 literal: cc ;
 
 ! Overflowing arithmetic
 INSN: _fixnum-add
 literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 INSN: _fixnum-sub
 literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 INSN: _fixnum-mul
 literal: label
-def: dst/int-rep
-use: src1/int-rep src2/int-rep ;
+def: dst/tagged-rep
+use: src1/tagged-rep src2/tagged-rep ;
 
 TUPLE: spill-slot { n integer } ;
 C: <spill-slot> spill-slot
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 6acb9169ec..c79aa36af1 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -121,10 +121,10 @@ M: vreg-insn assign-registers-in-insn
 : trace-on-gc ( assoc -- assoc' )
     ! When a GC occurs, virtual registers which contain tagged data
     ! are traced by the GC. Outputs a sequence physical registers.
-    [ drop rep-of int-rep eq? ] { } assoc-filter-as values ;
+    [ drop rep-of tagged-rep eq? ] { } assoc-filter-as values ;
 
 : spill-on-gc? ( vreg reg -- ? )
-    [ rep-of int-rep? not ] [ spill-slot? not ] bi* and ;
+    [ rep-of tagged-rep? not ] [ spill-slot? not ] bi* and ;
 
 : spill-on-gc ( assoc -- assoc' )
     ! When a GC occurs, virtual registers which contain untagged data,
diff --git a/basis/compiler/cfg/representations/conversion/authors.txt b/basis/compiler/cfg/representations/conversion/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/representations/conversion/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/representations/conversion/conversion.factor b/basis/compiler/cfg/representations/conversion/conversion.factor
new file mode 100644
index 0000000000..071adea76d
--- /dev/null
+++ b/basis/compiler/cfg/representations/conversion/conversion.factor
@@ -0,0 +1,75 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays combinators compiler.cfg.instructions
+compiler.cfg.registers compiler.constants cpu.architecture
+kernel layouts locals math namespaces ;
+IN: compiler.cfg.representations.conversion
+
+ERROR: bad-conversion dst src dst-rep src-rep ;
+
+GENERIC: emit-box ( dst src rep -- )
+GENERIC: emit-unbox ( dst src rep -- )
+
+M: int-rep emit-box ( dst src rep -- )
+    drop tag-bits get ##shl-imm ;
+
+M: int-rep emit-unbox ( dst src rep -- )
+    drop tag-bits get ##sar-imm ;
+
+M:: float-rep emit-box ( dst src rep -- )
+    double-rep next-vreg-rep :> temp
+    temp src ##single>double-float
+    dst temp double-rep emit-box ;
+
+M:: float-rep emit-unbox ( dst src rep -- )
+    double-rep next-vreg-rep :> temp
+    temp src double-rep emit-unbox
+    dst temp ##double>single-float ;
+
+M: double-rep emit-box
+    drop
+    [ drop 16 float tagged-rep next-vreg-rep ##allot ]
+    [ float-offset swap ##set-alien-double ]
+    2bi ;
+
+M: double-rep emit-unbox
+    drop float-offset ##alien-double ;
+
+M:: vector-rep emit-box ( dst src rep -- )
+    tagged-rep next-vreg-rep :> temp
+    dst 16 2 cells + byte-array tagged-rep next-vreg-rep ##allot
+    temp 16 tag-fixnum ##load-immediate
+    temp dst 1 byte-array type-number ##set-slot-imm
+    dst byte-array-offset src rep ##set-alien-vector ;
+
+M: vector-rep emit-unbox
+    [ byte-array-offset ] dip ##alien-vector ;
+
+M:: scalar-rep emit-box ( dst src rep -- )
+    tagged-rep next-vreg-rep :> temp
+    temp src rep ##scalar>integer
+    dst temp int-rep emit-box ;
+
+M:: scalar-rep emit-unbox ( dst src rep -- )
+    tagged-rep next-vreg-rep :> temp
+    temp src int-rep emit-unbox
+    dst temp rep ##integer>scalar ;
+
+: emit-conversion ( dst src dst-rep src-rep -- )
+    {
+        { [ 2dup eq? ] [ drop ##copy ] }
+        { [ dup tagged-rep eq? ] [ drop emit-unbox ] }
+        { [ over tagged-rep eq? ] [ nip emit-box ] }
+        [
+            2dup 2array {
+                { { double-rep float-rep } [ 2drop ##single>double-float ] }
+                { { float-rep double-rep } [ 2drop ##double>single-float ] }
+                ! Punning SIMD vector types? Naughty naughty! But
+                ! it is allowed... otherwise bail out.
+                [
+                    drop 2dup [ reg-class-of ] bi@ eq?
+                    [ drop ##copy ] [ bad-conversion ] if
+                ]
+            } case
+        ]
+    } cond ;
diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor
index f202dc4c6a..d4c500291e 100644
--- a/basis/compiler/cfg/representations/representations.factor
+++ b/basis/compiler/cfg/representations/representations.factor
@@ -1,365 +1,13 @@
 ! Copyright (C) 2009, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel fry accessors sequences assocs sets namespaces
-arrays combinators combinators.short-circuit math make locals
-deques dlists layouts byte-arrays cpu.architecture
-compiler.utilities
-compiler.constants
-compiler.cfg
-compiler.cfg.rpo
-compiler.cfg.hats
-compiler.cfg.registers
-compiler.cfg.instructions
-compiler.cfg.def-use
-compiler.cfg.utilities
-compiler.cfg.loop-detection
-compiler.cfg.renaming.functor
-compiler.cfg.representations.preferred ;
-FROM: namespaces => set ;
+USING: accessors combinators compiler.cfg
+compiler.cfg.loop-detection compiler.cfg.registers
+compiler.cfg.representations.rewrite
+compiler.cfg.representations.selection namespaces ;
 IN: compiler.cfg.representations
 
 ! Virtual register representation selection.
 
-ERROR: bad-conversion dst src dst-rep src-rep ;
-
-GENERIC: emit-box ( dst src rep -- )
-GENERIC: emit-unbox ( dst src rep -- )
-
-M:: float-rep emit-box ( dst src rep -- )
-    double-rep next-vreg-rep :> temp
-    temp src ##single>double-float
-    dst temp double-rep emit-box ;
-
-M:: float-rep emit-unbox ( dst src rep -- )
-    double-rep next-vreg-rep :> temp
-    temp src double-rep emit-unbox
-    dst temp ##double>single-float ;
-
-M: double-rep emit-box
-    drop
-    [ drop 16 float int-rep next-vreg-rep ##allot ]
-    [ float-offset swap ##set-alien-double ]
-    2bi ;
-
-M: double-rep emit-unbox
-    drop float-offset ##alien-double ;
-
-M:: vector-rep emit-box ( dst src rep -- )
-    int-rep next-vreg-rep :> temp
-    dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
-    temp 16 tag-fixnum ##load-immediate
-    temp dst 1 byte-array type-number ##set-slot-imm
-    dst byte-array-offset src rep ##set-alien-vector ;
-
-M: vector-rep emit-unbox
-    [ byte-array-offset ] dip ##alien-vector ;
-
-M:: scalar-rep emit-box ( dst src rep -- )
-    int-rep next-vreg-rep :> temp
-    temp src rep ##scalar>integer
-    dst temp tag-bits get ##shl-imm ;
-
-M:: scalar-rep emit-unbox ( dst src rep -- )
-    int-rep next-vreg-rep :> temp
-    temp src tag-bits get ##sar-imm
-    dst temp rep ##integer>scalar ;
-
-: emit-conversion ( dst src dst-rep src-rep -- )
-    {
-        { [ 2dup eq? ] [ drop ##copy ] }
-        { [ dup int-rep eq? ] [ drop emit-unbox ] }
-        { [ over int-rep eq? ] [ nip emit-box ] }
-        [
-            2dup 2array {
-                { { double-rep float-rep } [ 2drop ##single>double-float ] }
-                { { float-rep double-rep } [ 2drop ##double>single-float ] }
-                ! Punning SIMD vector types? Naughty naughty! But
-                ! it is allowed... otherwise bail out.
-                [
-                    drop 2dup [ reg-class-of ] bi@ eq?
-                    [ drop ##copy ] [ bad-conversion ] if
-                ]
-            } case
-        ]
-    } cond ;
-
-<PRIVATE
-
-! For every vreg, compute possible representations.
-SYMBOL: possibilities
-
-: possible ( vreg -- reps ) possibilities get at ;
-
-: compute-possibilities ( cfg -- )
-    H{ } clone [ '[ swap _ adjoin-at ] with-vreg-reps ] keep
-    [ members ] assoc-map possibilities set ;
-
-! Compute vregs which must remain tagged for their lifetime.
-SYMBOL: always-boxed
-
-:: (compute-always-boxed) ( vreg rep assoc -- )
-    rep int-rep eq? [
-        int-rep vreg assoc set-at
-    ] when ;
-
-: compute-always-boxed ( cfg -- assoc )
-    H{ } clone [
-        '[
-            [
-                dup [ ##load-reference? ] [ ##load-constant? ] bi or
-                [ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
-            ] each-non-phi
-        ] each-basic-block
-    ] keep ;
-
-! For every vreg, compute the cost of keeping it in every possible
-! representation.
-
-! Cost map maps vreg to representation to cost.
-SYMBOL: costs
-
-: init-costs ( -- )
-    possibilities get [ drop H{ } clone ] assoc-map costs set ;
-
-: record-possibility ( rep vreg -- )
-    costs get at [ 0 or ] change-at ;
-
-: increase-cost ( rep vreg -- )
-    ! Increase cost of keeping vreg in rep, making a choice of rep less
-    ! likely.
-    costs get at [ 0 or basic-block get loop-nesting-at 1 + + ] change-at ;
-
-: maybe-increase-cost ( possible vreg preferred -- )
-    pick eq? [ record-possibility ] [ increase-cost ] if ;
-
-: representation-cost ( vreg preferred -- )
-    ! 'preferred' is a representation that the instruction can accept with no cost.
-    ! So, for each representation that's not preferred, increase the cost of keeping
-    ! the vreg in that representation.
-    [ drop possible ]
-    [ '[ _ _ maybe-increase-cost ] ]
-    2bi each ;
-
-GENERIC: compute-insn-costs ( insn -- )
-
-M: ##load-constant compute-insn-costs
-    ! There's no cost to unboxing the result of a ##load-constant
-    drop ;
-
-M: insn compute-insn-costs [ representation-cost ] each-rep ;
-
-: compute-costs ( cfg -- costs )
-    init-costs
-    [
-        [ basic-block set ]
-        [
-            [
-                compute-insn-costs
-            ] each-non-phi
-        ] bi
-    ] each-basic-block
-    costs get ;
-
-! For every vreg, compute preferred representation, that minimizes costs.
-: minimize-costs ( costs -- representations )
-    [ nip assoc-empty? not ] assoc-filter
-    [ >alist alist-min first ] assoc-map ;
-
-: compute-representations ( cfg -- )
-    [ compute-costs minimize-costs ]
-    [ compute-always-boxed ]
-    bi assoc-union
-    representations set ;
-
-! PHI nodes require special treatment
-! If the output of a phi instruction is only used as the input to another
-! phi instruction, then we want to use the same representation for both
-! if possible.
-SYMBOL: phis
-
-: collect-phis ( cfg -- )
-    H{ } clone phis set
-    [
-        phis get
-        '[ [ inputs>> values ] [ dst>> ] bi _ set-at ] each-phi
-    ] each-basic-block ;
-
-SYMBOL: work-list
-
-: add-to-work-list ( vregs -- )
-    work-list get push-all-front ;
-
-: rep-assigned ( vregs -- vregs' )
-    representations get '[ _ key? ] filter ;
-
-: rep-not-assigned ( vregs -- vregs' )
-    representations get '[ _ key? not ] filter ;
-
-: add-ready-phis ( -- )
-    phis get keys rep-assigned add-to-work-list ;
-
-: process-phi ( dst -- )
-    ! If dst = phi(src1,src2,...) and dst's representation has been
-    ! determined, assign that representation to each one of src1,...
-    ! that does not have a representation yet, and process those, too.
-    dup phis get at* [
-        [ rep-of ] [ rep-not-assigned ] bi*
-        [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
-    ] [ 2drop ] if ;
-
-: remaining-phis ( -- )
-    phis get keys rep-not-assigned { } assert-sequence= ;
-
-: process-phis ( -- )
-    <hashed-dlist> work-list set
-    add-ready-phis
-    work-list get [ process-phi ] slurp-deque
-    remaining-phis ;
-
-: compute-phi-representations ( cfg -- )
-    collect-phis process-phis ;
-
-! Insert conversions. This introduces new temporaries, so we need
-! to rename opearands too.
-
-! Mapping from vreg,rep pairs to vregs
-SYMBOL: alternatives
-
-:: emit-def-conversion ( dst preferred required -- new-dst' )
-    ! If an instruction defines a register with representation 'required',
-    ! but the register has preferred representation 'preferred', then
-    ! we rename the instruction's definition to a new register, which
-    ! becomes the input of a conversion instruction.
-    dst required next-vreg-rep [ preferred required emit-conversion ] keep ;
-
-:: emit-use-conversion ( src preferred required -- new-src' )
-    ! If an instruction uses a register with representation 'required',
-    ! but the register has preferred representation 'preferred', then
-    ! we rename the instruction's input to a new register, which
-    ! becomes the output of a conversion instruction.
-    preferred required eq? [ src ] [
-        src required alternatives get [
-            required next-vreg-rep :> new-src
-            [ new-src ] 2dip preferred emit-conversion
-            new-src
-        ] 2cache
-    ] if ;
-
-SYMBOLS: renaming-set needs-renaming? ;
-
-: init-renaming-set ( -- )
-    needs-renaming? off
-    V{ } clone renaming-set set ;
-
-: no-renaming ( vreg -- )
-    dup 2array renaming-set get push ;
-
-: record-renaming ( from to -- )
-    2array renaming-set get push needs-renaming? on ;
-
-:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- new-vreg ) -- )
-    vreg rep-of :> preferred
-    preferred required eq?
-    [ vreg no-renaming ]
-    [ vreg vreg preferred required quot call record-renaming ] if ; inline
-
-: compute-renaming-set ( insn -- )
-    ! temp vregs don't need conversions since they're always in their
-    ! preferred representation
-    init-renaming-set
-    [ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ]
-    [ , ]
-    [ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ]
-    tri ;
-
-: converted-value ( vreg -- vreg' )
-    renaming-set get pop first2 [ assert= ] dip ;
-
-RENAMING: convert [ converted-value ] [ converted-value ] [ ]
-
-: perform-renaming ( insn -- )
-    needs-renaming? get [
-        renaming-set get reverse! drop
-        [ convert-insn-uses ] [ convert-insn-defs ] bi
-        renaming-set get length 0 assert=
-    ] [ drop ] if ;
-
-GENERIC: conversions-for-insn ( insn -- )
-
-M: ##phi conversions-for-insn , ;
-
-! When a float is unboxed, we replace the ##load-constant with a ##load-double
-! if the architecture supports it
-: convert-to-load-double? ( insn -- ? )
-    {
-        [ drop load-double? ]
-        [ dst>> rep-of double-rep? ]
-        [ obj>> float? ]
-    } 1&& ;
-
-! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
-! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
-: convert-to-zero-vector? ( insn -- ? )
-    {
-        [ dst>> rep-of vector-rep? ]
-        [ obj>> B{ 0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 } = ]
-    } 1&& ;
-
-: convert-to-fill-vector? ( insn -- ? )
-    {
-        [ dst>> rep-of vector-rep? ]
-        [ obj>> B{ 255 255 255 255  255 255 255 255  255 255 255 255  255 255 255 255 } = ]
-    } 1&& ;
-
-: (convert-to-load-double) ( insn -- dst val )
-    [ dst>> ] [ obj>> ] bi ; inline
-
-: (convert-to-zero/fill-vector) ( insn -- dst rep )
-    dst>> dup rep-of ; inline
-
-: conversions-for-load-insn ( insn -- ?insn )
-    {
-        {
-            [ dup convert-to-load-double? ]
-            [ (convert-to-load-double) ##load-double f ]
-        }
-        {
-            [ dup convert-to-zero-vector? ]
-            [ (convert-to-zero/fill-vector) ##zero-vector f ]
-        }
-        {
-            [ dup convert-to-fill-vector? ]
-            [ (convert-to-zero/fill-vector) ##fill-vector f ]
-        }
-        [ ]
-    } cond ;
-
-M: ##load-reference conversions-for-insn
-    conversions-for-load-insn [ call-next-method ] when* ;
-
-M: ##load-constant conversions-for-insn
-    conversions-for-load-insn [ call-next-method ] when* ;
-
-M: vreg-insn conversions-for-insn
-    [ compute-renaming-set ] [ perform-renaming ] bi ;
-
-M: insn conversions-for-insn , ;
-
-: conversions-for-block ( bb -- )
-    dup kill-block? [ drop ] [
-        [
-            [
-                H{ } clone alternatives set
-                [ conversions-for-insn ] each
-            ] V{ } make
-        ] change-instructions drop
-    ] if ;
-
-: insert-conversions ( cfg -- )
-    [ conversions-for-block ] each-basic-block ;
-
-PRIVATE>
-
 : select-representations ( cfg -- cfg' )
     needs-loops
 
diff --git a/basis/compiler/cfg/representations/rewrite/authors.txt b/basis/compiler/cfg/representations/rewrite/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/representations/rewrite/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/representations/rewrite/rewrite.factor b/basis/compiler/cfg/representations/rewrite/rewrite.factor
new file mode 100644
index 0000000000..7b9164ce78
--- /dev/null
+++ b/basis/compiler/cfg/representations/rewrite/rewrite.factor
@@ -0,0 +1,149 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators
+combinators.short-circuit compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.renaming.functor
+compiler.cfg.representations.conversion
+compiler.cfg.representations.preferred compiler.cfg.rpo
+compiler.cfg.utilities cpu.architecture kernel locals make math
+namespaces sequences ;
+IN: compiler.cfg.representations.rewrite
+
+! Insert conversions. This introduces new temporaries, so we need
+! to rename opearands too.
+
+! Mapping from vreg,rep pairs to vregs
+SYMBOL: alternatives
+
+:: emit-def-conversion ( dst preferred required -- new-dst' )
+    ! If an instruction defines a register with representation 'required',
+    ! but the register has preferred representation 'preferred', then
+    ! we rename the instruction's definition to a new register, which
+    ! becomes the input of a conversion instruction.
+    dst required next-vreg-rep [ preferred required emit-conversion ] keep ;
+
+:: emit-use-conversion ( src preferred required -- new-src' )
+    ! If an instruction uses a register with representation 'required',
+    ! but the register has preferred representation 'preferred', then
+    ! we rename the instruction's input to a new register, which
+    ! becomes the output of a conversion instruction.
+    preferred required eq? [ src ] [
+        src required alternatives get [
+            required next-vreg-rep :> new-src
+            [ new-src ] 2dip preferred emit-conversion
+            new-src
+        ] 2cache
+    ] if ;
+
+SYMBOLS: renaming-set needs-renaming? ;
+
+: init-renaming-set ( -- )
+    needs-renaming? off
+    V{ } clone renaming-set set ;
+
+: no-renaming ( vreg -- )
+    dup 2array renaming-set get push ;
+
+: record-renaming ( from to -- )
+    2array renaming-set get push needs-renaming? on ;
+
+:: (compute-renaming-set) ( vreg required quot: ( vreg preferred required -- new-vreg ) -- )
+    vreg rep-of :> preferred
+    preferred required eq?
+    [ vreg no-renaming ]
+    [ vreg vreg preferred required quot call record-renaming ] if ; inline
+
+: compute-renaming-set ( insn -- )
+    ! temp vregs don't need conversions since they're always in their
+    ! preferred representation
+    init-renaming-set
+    [ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ]
+    [ , ]
+    [ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ]
+    tri ;
+
+: converted-value ( vreg -- vreg' )
+    renaming-set get pop first2 [ assert= ] dip ;
+
+RENAMING: convert [ converted-value ] [ converted-value ] [ ]
+
+: perform-renaming ( insn -- )
+    needs-renaming? get [
+        renaming-set get reverse! drop
+        [ convert-insn-uses ] [ convert-insn-defs ] bi
+        renaming-set get length 0 assert=
+    ] [ drop ] if ;
+
+GENERIC: conversions-for-insn ( insn -- )
+
+M: ##phi conversions-for-insn , ;
+
+! When a float is unboxed, we replace the ##load-constant with a ##load-double
+! if the architecture supports it
+: convert-to-load-double? ( insn -- ? )
+    {
+        [ drop load-double? ]
+        [ dst>> rep-of double-rep? ]
+        [ obj>> float? ]
+    } 1&& ;
+
+! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
+! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
+: convert-to-zero-vector? ( insn -- ? )
+    {
+        [ dst>> rep-of vector-rep? ]
+        [ obj>> B{ 0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 } = ]
+    } 1&& ;
+
+: convert-to-fill-vector? ( insn -- ? )
+    {
+        [ dst>> rep-of vector-rep? ]
+        [ obj>> B{ 255 255 255 255  255 255 255 255  255 255 255 255  255 255 255 255 } = ]
+    } 1&& ;
+
+: (convert-to-load-double) ( insn -- dst val )
+    [ dst>> ] [ obj>> ] bi ; inline
+
+: (convert-to-zero/fill-vector) ( insn -- dst rep )
+    dst>> dup rep-of ; inline
+
+: conversions-for-load-insn ( insn -- ?insn )
+    {
+        {
+            [ dup convert-to-load-double? ]
+            [ (convert-to-load-double) ##load-double f ]
+        }
+        {
+            [ dup convert-to-zero-vector? ]
+            [ (convert-to-zero/fill-vector) ##zero-vector f ]
+        }
+        {
+            [ dup convert-to-fill-vector? ]
+            [ (convert-to-zero/fill-vector) ##fill-vector f ]
+        }
+        [ ]
+    } cond ;
+
+M: ##load-reference conversions-for-insn
+    conversions-for-load-insn [ call-next-method ] when* ;
+
+M: ##load-constant conversions-for-insn
+    conversions-for-load-insn [ call-next-method ] when* ;
+
+M: vreg-insn conversions-for-insn
+    [ compute-renaming-set ] [ perform-renaming ] bi ;
+
+M: insn conversions-for-insn , ;
+
+: conversions-for-block ( bb -- )
+    dup kill-block? [ drop ] [
+        [
+            [
+                H{ } clone alternatives set
+                [ conversions-for-insn ] each
+            ] V{ } make
+        ] change-instructions drop
+    ] if ;
+
+: insert-conversions ( cfg -- )
+    [ conversions-for-block ] each-basic-block ;
diff --git a/basis/compiler/cfg/representations/selection/authors.txt b/basis/compiler/cfg/representations/selection/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/representations/selection/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/representations/selection/selection.factor b/basis/compiler/cfg/representations/selection/selection.factor
new file mode 100644
index 0000000000..4178101ddd
--- /dev/null
+++ b/basis/compiler/cfg/representations/selection/selection.factor
@@ -0,0 +1,143 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs compiler.cfg compiler.cfg.instructions
+compiler.cfg.loop-detection compiler.cfg.registers
+compiler.cfg.representations.preferred compiler.cfg.rpo
+compiler.cfg.utilities compiler.utilities cpu.architecture
+deques dlists fry kernel locals math namespaces sequences sets ;
+FROM: namespaces => set ;
+IN: compiler.cfg.representations.selection
+
+! For every vreg, compute possible representations.
+SYMBOL: possibilities
+
+: possible ( vreg -- reps ) possibilities get at ;
+
+: compute-possibilities ( cfg -- )
+    H{ } clone [ '[ swap _ adjoin-at ] with-vreg-reps ] keep
+    [ members ] assoc-map possibilities set ;
+
+! Compute vregs which must remain tagged for their lifetime.
+SYMBOL: always-boxed
+
+:: (compute-always-boxed) ( vreg rep assoc -- )
+    rep tagged-rep eq? [
+        tagged-rep vreg assoc set-at
+    ] when ;
+
+: compute-always-boxed ( cfg -- assoc )
+    H{ } clone [
+        '[
+            [
+                dup [ ##load-reference? ] [ ##load-constant? ] bi or
+                [ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
+            ] each-non-phi
+        ] each-basic-block
+    ] keep ;
+
+! For every vreg, compute the cost of keeping it in every possible
+! representation.
+
+! Cost map maps vreg to representation to cost.
+SYMBOL: costs
+
+: init-costs ( -- )
+    possibilities get [ drop H{ } clone ] assoc-map costs set ;
+
+: record-possibility ( rep vreg -- )
+    costs get at [ 0 or ] change-at ;
+
+: increase-cost ( rep vreg -- )
+    ! Increase cost of keeping vreg in rep, making a choice of rep less
+    ! likely.
+    costs get at [ 0 or basic-block get loop-nesting-at 1 + + ] change-at ;
+
+: maybe-increase-cost ( possible vreg preferred -- )
+    pick eq? [ record-possibility ] [ increase-cost ] if ;
+
+: representation-cost ( vreg preferred -- )
+    ! 'preferred' is a representation that the instruction can accept with no cost.
+    ! So, for each representation that's not preferred, increase the cost of keeping
+    ! the vreg in that representation.
+    [ drop possible ]
+    [ '[ _ _ maybe-increase-cost ] ]
+    2bi each ;
+
+GENERIC: compute-insn-costs ( insn -- )
+
+M: ##load-constant compute-insn-costs
+    ! There's no cost to unboxing the result of a ##load-constant
+    drop ;
+
+M: insn compute-insn-costs [ representation-cost ] each-rep ;
+
+: compute-costs ( cfg -- costs )
+    init-costs
+    [
+        [ basic-block set ]
+        [
+            [
+                compute-insn-costs
+            ] each-non-phi
+        ] bi
+    ] each-basic-block
+    costs get ;
+
+! For every vreg, compute preferred representation, that minimizes costs.
+: minimize-costs ( costs -- representations )
+    [ nip assoc-empty? not ] assoc-filter
+    [ >alist alist-min first ] assoc-map ;
+
+: compute-representations ( cfg -- )
+    [ compute-costs minimize-costs ]
+    [ compute-always-boxed ]
+    bi assoc-union
+    representations set ;
+
+! PHI nodes require special treatment
+! If the output of a phi instruction is only used as the input to another
+! phi instruction, then we want to use the same representation for both
+! if possible.
+SYMBOL: phis
+
+: collect-phis ( cfg -- )
+    H{ } clone phis set
+    [
+        phis get
+        '[ [ inputs>> values ] [ dst>> ] bi _ set-at ] each-phi
+    ] each-basic-block ;
+
+SYMBOL: work-list
+
+: add-to-work-list ( vregs -- )
+    work-list get push-all-front ;
+
+: rep-assigned ( vregs -- vregs' )
+    representations get '[ _ key? ] filter ;
+
+: rep-not-assigned ( vregs -- vregs' )
+    representations get '[ _ key? not ] filter ;
+
+: add-ready-phis ( -- )
+    phis get keys rep-assigned add-to-work-list ;
+
+: process-phi ( dst -- )
+    ! If dst = phi(src1,src2,...) and dst's representation has been
+    ! determined, assign that representation to each one of src1,...
+    ! that does not have a representation yet, and process those, too.
+    dup phis get at* [
+        [ rep-of ] [ rep-not-assigned ] bi*
+        [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
+    ] [ 2drop ] if ;
+
+: remaining-phis ( -- )
+    phis get keys rep-not-assigned { } assert-sequence= ;
+
+: process-phis ( -- )
+    <hashed-dlist> work-list set
+    add-ready-phis
+    work-list get [ process-phi ] slurp-deque
+    remaining-phis ;
+
+: compute-phi-representations ( cfg -- )
+    collect-phis process-phis ;
diff --git a/basis/compiler/cfg/save-contexts/save-contexts.factor b/basis/compiler/cfg/save-contexts/save-contexts.factor
index c7b6db0671..e2ccf943ad 100644
--- a/basis/compiler/cfg/save-contexts/save-contexts.factor
+++ b/basis/compiler/cfg/save-contexts/save-contexts.factor
@@ -20,8 +20,8 @@ IN: compiler.cfg.save-contexts
 
 : insert-save-context ( bb -- )
     dup instructions>> dup needs-save-context? [
-        int-rep next-vreg-rep
-        int-rep next-vreg-rep
+        tagged-rep next-vreg-rep
+        tagged-rep next-vreg-rep
         \ ##save-context new-insn prefix
         >>instructions drop
     ] [ 2drop ] if ;
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 8adae2ae99..6f9354a767 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -224,6 +224,7 @@ M:: ppc %float>integer ( dst src -- )
 M: ppc %copy ( dst src rep -- )
     2over eq? [ 3drop ] [
         {
+            { tagged-rep [ MR ] }
             { int-rep [ MR ] }
             { double-rep [ FMR ] }
         } case
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 432d210bec..d1c71f3cd4 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -168,9 +168,7 @@ M:: x86.64 %box ( n rep func -- )
     ] [
         rep load-return-value
     ] if
-    rep int-rep?
-    cpu x86.64? os windows? and or
-    param-reg-1 param-reg-0 ? %mov-vm-ptr
+    rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
     func f %alien-invoke ;
 
 : box-struct-field@ ( i -- operand ) 1 + cells param@ ;

From 5d3a7a7362527516adcb9cf45e6bda996e8b0e2e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 21 Apr 2010 02:08:52 -0500
Subject: [PATCH 102/158] Untagged fixnums work in progress

---
 .../cfg/alias-analysis/alias-analysis.factor  |  20 +-
 basis/compiler/cfg/dce/dce-tests.factor       |  24 +-
 basis/compiler/cfg/hats/hats.factor           |  27 +-
 .../cfg/instructions/instructions.factor      | 216 +++---
 .../cfg/instructions/syntax/syntax.factor     |  12 +-
 .../cfg/intrinsics/alien/alien.factor         |  24 +-
 .../cfg/intrinsics/fixnum/fixnum.factor       |  24 +-
 .../cfg/intrinsics/float/float.factor         |   4 +-
 .../compiler/cfg/intrinsics/intrinsics.factor |  24 +-
 .../compiler/cfg/intrinsics/misc/misc.factor  |   7 +-
 .../cfg/intrinsics/simd/simd-tests.factor     |  12 +-
 .../compiler/cfg/intrinsics/simd/simd.factor  |  24 +-
 .../cfg/intrinsics/slots/slots.factor         |   5 +-
 .../cfg/linear-scan/linear-scan-tests.factor  |   4 +-
 .../conversion/conversion.factor              |  53 +-
 .../representations-tests.factor              |  61 +-
 .../representations/rewrite/rewrite.factor    |  41 +-
 .../selection/selection.factor                |   8 +-
 .../construction/construction-tests.factor    |  12 +-
 basis/compiler/cfg/ssa/cssa/cssa.factor       |   2 +-
 .../cfg/value-numbering/alien/alien.factor    |  50 ++
 .../cfg/value-numbering/alien/authors.txt     |   1 +
 .../value-numbering/comparisons/authors.txt   |   1 +
 .../comparisons/comparisons.factor            | 167 ++++
 .../expressions/expressions.factor            |  93 ++-
 .../cfg/value-numbering/folding/authors.txt   |   1 +
 .../value-numbering/folding/folding.factor    |  39 +
 .../cfg/value-numbering/graph/graph.factor    |   6 +-
 .../cfg/value-numbering/math/authors.txt      |   1 +
 .../cfg/value-numbering/math/math.factor      | 196 +++++
 .../value-numbering/rewrite/rewrite.factor    | 473 +-----------
 .../cfg/value-numbering/simd/simd.factor      |  11 +-
 .../value-numbering/simplify/simplify.factor  |  15 +-
 .../value-numbering-tests.factor              | 724 +++++++++---------
 .../value-numbering/value-numbering.factor    |   9 +-
 basis/compiler/codegen/codegen.factor         |   5 +-
 basis/cpu/x86/x86.factor                      |   2 +-
 37 files changed, 1239 insertions(+), 1159 deletions(-)
 create mode 100644 basis/compiler/cfg/value-numbering/alien/alien.factor
 create mode 100644 basis/compiler/cfg/value-numbering/alien/authors.txt
 create mode 100644 basis/compiler/cfg/value-numbering/comparisons/authors.txt
 create mode 100644 basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
 create mode 100644 basis/compiler/cfg/value-numbering/folding/authors.txt
 create mode 100644 basis/compiler/cfg/value-numbering/folding/folding.factor
 create mode 100644 basis/compiler/cfg/value-numbering/math/authors.txt
 create mode 100644 basis/compiler/cfg/value-numbering/math/math.factor

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index d34d40f341..4a2f2bf9aa 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math namespaces assocs hashtables sequences arrays
 accessors words vectors combinators combinators.short-circuit
@@ -187,19 +187,12 @@ SYMBOL: heap-ac
         [ kill-constant-set-slot ] 2bi
     ] [ nip kill-computed-set-slot ] if ;
 
-SYMBOL: constants
-
-: constant ( vreg -- n/f )
-    #! Return a ##load-immediate value, or f if the vreg was not
-    #! assigned by an ##load-immediate.
-    resolve constants get at ;
-
 GENERIC: insn-slot# ( insn -- slot#/f )
 GENERIC: insn-object ( insn -- vreg )
 
-M: ##slot insn-slot# slot>> constant ;
+M: ##slot insn-slot# drop f ;
 M: ##slot-imm insn-slot# slot>> ;
-M: ##set-slot insn-slot# slot>> constant ;
+M: ##set-slot insn-slot# drop f ;
 M: ##set-slot-imm insn-slot# slot>> ;
 M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
 M: ##vm-field insn-slot# offset>> ;
@@ -218,7 +211,6 @@ M: ##set-vm-field insn-object drop \ ##vm-field ;
     H{ } clone vregs>acs set
     H{ } clone acs>vregs set
     H{ } clone live-slots set
-    H{ } clone constants set
     H{ } clone copies set
 
     0 ac-counter set
@@ -245,10 +237,6 @@ M: insn analyze-aliases*
 M: ##phi analyze-aliases*
     dup defs-vreg set-heap-ac ;
 
-M: ##load-immediate analyze-aliases*
-    call-next-method
-    dup [ val>> ] [ dst>> ] bi constants get set-at ;
-
 M: ##allocation analyze-aliases*
     #! A freshly allocated object is distinct from any other
     #! object.
@@ -287,7 +275,7 @@ M: ##copy analyze-aliases*
 M: ##compare analyze-aliases*
     call-next-method
     dup useless-compare? [
-        dst>> f \ ##load-constant new-insn
+        dst>> f \ ##load-reference new-insn
         analyze-aliases*
     ] when ;
 
diff --git a/basis/compiler/cfg/dce/dce-tests.factor b/basis/compiler/cfg/dce/dce-tests.factor
index 6a7ef08257..460d1a53d1 100644
--- a/basis/compiler/cfg/dce/dce-tests.factor
+++ b/basis/compiler/cfg/dce/dce-tests.factor
@@ -11,41 +11,41 @@ IN: compiler.cfg.dce.tests
     entry>> instructions>> ; 
 
 [ V{
-    T{ ##load-immediate { dst 1 } { val 8 } }
-    T{ ##load-immediate { dst 2 } { val 16 } }
+    T{ ##load-integer { dst 1 } { val 8 } }
+    T{ ##load-integer { dst 2 } { val 16 } }
     T{ ##add { dst 3 } { src1 1 } { src2 2 } }
     T{ ##replace { src 3 } { loc D 0 } }
 } ] [ V{
-    T{ ##load-immediate { dst 1 } { val 8 } }
-    T{ ##load-immediate { dst 2 } { val 16 } }
+    T{ ##load-integer { dst 1 } { val 8 } }
+    T{ ##load-integer { dst 2 } { val 16 } }
     T{ ##add { dst 3 } { src1 1 } { src2 2 } }
     T{ ##replace { src 3 } { loc D 0 } }
 } test-dce ] unit-test
 
 [ V{ } ] [ V{
-    T{ ##load-immediate { dst 1 } { val 8 } }
-    T{ ##load-immediate { dst 2 } { val 16 } }
+    T{ ##load-integer { dst 1 } { val 8 } }
+    T{ ##load-integer { dst 2 } { val 16 } }
     T{ ##add { dst 3 } { src1 1 } { src2 2 } }
 } test-dce ] unit-test
 
 [ V{ } ] [ V{
-    T{ ##load-immediate { dst 3 } { val 8 } }
+    T{ ##load-integer { dst 3 } { val 8 } }
     T{ ##allot { dst 1 } { temp 2 } }
 } test-dce ] unit-test
 
 [ V{ } ] [ V{
-    T{ ##load-immediate { dst 3 } { val 8 } }
+    T{ ##load-integer { dst 3 } { val 8 } }
     T{ ##allot { dst 1 } { temp 2 } }
     T{ ##set-slot-imm { obj 1 } { src 3 } }
 } test-dce ] unit-test
 
 [ V{
-    T{ ##load-immediate { dst 3 } { val 8 } }
+    T{ ##load-integer { dst 3 } { val 8 } }
     T{ ##allot { dst 1 } { temp 2 } }
     T{ ##set-slot-imm { obj 1 } { src 3 } }
     T{ ##replace { src 1 } { loc D 0 } }
 } ] [ V{
-    T{ ##load-immediate { dst 3 } { val 8 } }
+    T{ ##load-integer { dst 3 } { val 8 } }
     T{ ##allot { dst 1 } { temp 2 } }
     T{ ##set-slot-imm { obj 1 } { src 3 } }
     T{ ##replace { src 1 } { loc D 0 } }
@@ -62,11 +62,11 @@ IN: compiler.cfg.dce.tests
 [ V{
     T{ ##allot { dst 1 } { temp 2 } }
     T{ ##replace { src 1 } { loc D 0 } }
-    T{ ##load-immediate { dst 3 } { val 8 } }
+    T{ ##load-integer { dst 3 } { val 8 } }
     T{ ##set-slot-imm { obj 1 } { src 3 } }
 } ] [ V{
     T{ ##allot { dst 1 } { temp 2 } }
     T{ ##replace { src 1 } { loc D 0 } }
-    T{ ##load-immediate { dst 3 } { val 8 } }
+    T{ ##load-integer { dst 3 } { val 8 } }
     T{ ##set-slot-imm { obj 1 } { src 3 } }
 } test-dce ] unit-test
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index fb89b36efa..f11ffb10d4 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -41,21 +41,22 @@ insn-classes get [
 
 >>
 
-: immutable? ( obj -- ? )
-    { [ float? ] [ word? ] [ not ] } 1|| ; inline
-
 : ^^load-literal ( obj -- dst )
-    [ next-vreg dup ] dip {
-        { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
-        { [ dup immutable? ] [ ##load-constant ] }
-        [ ##load-reference ]
-    } cond ;
+    dup fixnum? [ ^^load-integer ] [ ^^load-reference ] if ;
 
 : ^^offset>slot ( slot -- vreg' )
-    cell 4 = 2 1 ? ^^shr-imm ;
+    cell 4 = 2 3 ? ^^shl-imm ;
 
-: ^^tag-fixnum ( src -- dst )
-    tag-bits get ^^shl-imm ;
+: ^^unbox-f ( src -- dst )
+    drop 0 ^^load-literal ;
 
-: ^^untag-fixnum ( src -- dst )
-    tag-bits get ^^sar-imm ;
+: ^^unbox-byte-array ( src -- dst )
+    ^^tagged>integer byte-array-offset ^^add-imm ;
+
+: ^^unbox-c-ptr ( src class -- dst )
+    {
+        { [ dup \ f class<= ] [ drop ^^unbox-f ] }
+        { [ dup alien class<= ] [ drop ^^unbox-alien ] }
+        { [ dup byte-array class<= ] [ drop ^^unbox-byte-array ] }
+        [ drop ^^unbox-any-c-ptr ]
+    } cond ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 6d18b05740..f7800ab6be 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -20,23 +20,25 @@ TUPLE: insn ;
 ! value numbering
 TUPLE: pure-insn < insn ;
 
-! Stack operations
-INSN: ##load-immediate
-def: dst/tagged-rep
+! Constants
+INSN: ##load-integer
+def: dst/int-rep
 constant: val ;
 
 INSN: ##load-reference
 def: dst/tagged-rep
 constant: obj ;
 
-INSN: ##load-constant
+! These two are inserted by representation selection
+INSN: ##load-tagged
 def: dst/tagged-rep
-constant: obj ;
+constant: val ;
 
 INSN: ##load-double
 def: dst/double-rep
 constant: val ;
 
+! Stack operations
 INSN: ##peek
 def: dst/tagged-rep
 literal: loc ;
@@ -65,13 +67,13 @@ INSN: ##no-tco ;
 
 ! Jump tables
 INSN: ##dispatch
-use: src/tagged-rep
+use: src/int-rep
 temp: temp/int-rep ;
 
 ! Slot access
 INSN: ##slot
 def: dst/tagged-rep
-use: obj/tagged-rep slot/tagged-rep ;
+use: obj/tagged-rep slot/int-rep ;
 
 INSN: ##slot-imm
 def: dst/tagged-rep
@@ -79,7 +81,7 @@ use: obj/tagged-rep
 literal: slot tag ;
 
 INSN: ##set-slot
-use: src/tagged-rep obj/tagged-rep slot/tagged-rep ;
+use: src/tagged-rep obj/tagged-rep slot/int-rep ;
 
 INSN: ##set-slot-imm
 use: src/tagged-rep obj/tagged-rep
@@ -87,120 +89,125 @@ literal: slot tag ;
 
 ! String element access
 INSN: ##string-nth
-def: dst/tagged-rep
-use: obj/tagged-rep index/tagged-rep
+def: dst/int-rep
+use: obj/tagged-rep index/int-rep
 temp: temp/int-rep ;
 
 INSN: ##set-string-nth-fast
-use: src/tagged-rep obj/tagged-rep index/tagged-rep
+use: src/int-rep obj/tagged-rep index/int-rep
 temp: temp/int-rep ;
 
+! Register transfers
 PURE-INSN: ##copy
 def: dst
 use: src
 literal: rep ;
 
+PURE-INSN: ##tagged>integer
+def: dst/int-rep
+use: src/tagged-rep ;
+
 ! Integer arithmetic
 PURE-INSN: ##add
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
 
 PURE-INSN: ##add-imm
-def: dst/tagged-rep
-use: src1/tagged-rep
+def: dst/int-rep
+use: src1/int-rep
 constant: src2 ;
 
 PURE-INSN: ##sub
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
 
 PURE-INSN: ##sub-imm
-def: dst/tagged-rep
-use: src1/tagged-rep
+def: dst/int-rep
+use: src1/int-rep
 constant: src2 ;
 
 PURE-INSN: ##mul
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
 
 PURE-INSN: ##mul-imm
-def: dst/tagged-rep
-use: src1/tagged-rep
+def: dst/int-rep
+use: src1/int-rep
 constant: src2 ;
 
 PURE-INSN: ##and
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
 
 PURE-INSN: ##and-imm
-def: dst/tagged-rep
-use: src1/tagged-rep
+def: dst/int-rep
+use: src1/int-rep
 constant: src2 ;
 
 PURE-INSN: ##or
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
 
 PURE-INSN: ##or-imm
-def: dst/tagged-rep
-use: src1/tagged-rep
+def: dst/int-rep
+use: src1/int-rep
 constant: src2 ;
 
 PURE-INSN: ##xor
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
 
 PURE-INSN: ##xor-imm
-def: dst/tagged-rep
-use: src1/tagged-rep
+def: dst/int-rep
+use: src1/int-rep
 constant: src2 ;
 
 PURE-INSN: ##shl
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
 
 PURE-INSN: ##shl-imm
-def: dst/tagged-rep
-use: src1/tagged-rep
+def: dst/int-rep
+use: src1/int-rep
 constant: src2 ;
 
 PURE-INSN: ##shr
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
 
 PURE-INSN: ##shr-imm
-def: dst/tagged-rep
-use: src1/tagged-rep
+def: dst/int-rep
+use: src1/int-rep
 constant: src2 ;
 
 PURE-INSN: ##sar
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
 
 PURE-INSN: ##sar-imm
-def: dst/tagged-rep
-use: src1/tagged-rep
+def: dst/int-rep
+use: src1/int-rep
 constant: src2 ;
 
 PURE-INSN: ##min
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
 
 PURE-INSN: ##max
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
 
 PURE-INSN: ##not
-def: dst/tagged-rep
-use: src/tagged-rep ;
+def: dst/int-rep
+use: src/int-rep ;
 
 PURE-INSN: ##neg
-def: dst/tagged-rep
-use: src/tagged-rep ;
+def: dst/int-rep
+use: src/int-rep ;
 
 PURE-INSN: ##log2
-def: dst/tagged-rep
-use: src/tagged-rep ;
+def: dst/int-rep
+use: src/int-rep ;
 
 ! Float arithmetic
 PURE-INSN: ##add-float
@@ -253,12 +260,12 @@ use: src/double-rep ;
 
 ! Float/integer conversion
 PURE-INSN: ##float>integer
-def: dst/tagged-rep
+def: dst/int-rep
 use: src/double-rep ;
 
 PURE-INSN: ##integer>float
 def: dst/double-rep
-use: src/tagged-rep ;
+use: src/int-rep ;
 
 ! SIMD operations
 PURE-INSN: ##zero-vector
@@ -508,13 +515,13 @@ literal: rep ;
 
 ! Scalar/vector conversion
 PURE-INSN: ##scalar>integer
-def: dst/tagged-rep
+def: dst/int-rep
 use: src
 literal: rep ;
 
 PURE-INSN: ##integer>scalar
 def: dst
-use: src/tagged-rep
+use: src/int-rep
 literal: rep ;
 
 PURE-INSN: ##vector>scalar
@@ -530,117 +537,106 @@ literal: rep ;
 ! Boxing and unboxing aliens
 PURE-INSN: ##box-alien
 def: dst/tagged-rep
-use: src/tagged-rep
+use: src/int-rep
 temp: temp/int-rep ;
 
 PURE-INSN: ##box-displaced-alien
 def: dst/tagged-rep
-use: displacement/tagged-rep base/tagged-rep
+use: displacement/int-rep base/int-rep
 temp: temp/int-rep
 literal: base-class ;
 
 PURE-INSN: ##unbox-any-c-ptr
-def: dst/tagged-rep
+def: dst/int-rep
 use: src/tagged-rep ;
 
-: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
-: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
-
 PURE-INSN: ##unbox-alien
-def: dst/tagged-rep
+def: dst/int-rep
 use: src/tagged-rep ;
 
-: ##unbox-c-ptr ( dst src class -- )
-    {
-        { [ dup \ f class<= ] [ drop ##unbox-f ] }
-        { [ dup alien class<= ] [ drop ##unbox-alien ] }
-        { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
-        [ drop ##unbox-any-c-ptr ]
-    } cond ;
-
 ! Alien accessors
 INSN: ##alien-unsigned-1
-def: dst/tagged-rep
-use: src/tagged-rep
+def: dst/int-rep
+use: src/int-rep
 literal: offset ;
 
 INSN: ##alien-unsigned-2
-def: dst/tagged-rep
-use: src/tagged-rep
+def: dst/int-rep
+use: src/int-rep
 literal: offset ;
 
 INSN: ##alien-unsigned-4
-def: dst/tagged-rep
-use: src/tagged-rep
+def: dst/int-rep
+use: src/int-rep
 literal: offset ;
 
 INSN: ##alien-signed-1
-def: dst/tagged-rep
-use: src/tagged-rep
+def: dst/int-rep
+use: src/int-rep
 literal: offset ;
 
 INSN: ##alien-signed-2
-def: dst/tagged-rep
-use: src/tagged-rep
+def: dst/int-rep
+use: src/int-rep
 literal: offset ;
 
 INSN: ##alien-signed-4
-def: dst/tagged-rep
-use: src/tagged-rep
+def: dst/int-rep
+use: src/int-rep
 literal: offset ;
 
 INSN: ##alien-cell
-def: dst/tagged-rep
-use: src/tagged-rep
+def: dst/int-rep
+use: src/int-rep
 literal: offset ;
 
 INSN: ##alien-float
 def: dst/float-rep
-use: src/tagged-rep
+use: src/int-rep
 literal: offset ;
 
 INSN: ##alien-double
 def: dst/double-rep
-use: src/tagged-rep
+use: src/int-rep
 literal: offset ;
 
 INSN: ##alien-vector
 def: dst
-use: src/tagged-rep
+use: src/int-rep
 literal: offset rep ;
 
 INSN: ##set-alien-integer-1
-use: src/tagged-rep
+use: src/int-rep
 literal: offset
-use: value/tagged-rep ;
+use: value/int-rep ;
 
 INSN: ##set-alien-integer-2
-use: src/tagged-rep
+use: src/int-rep
 literal: offset
-use: value/tagged-rep ;
+use: value/int-rep ;
 
 INSN: ##set-alien-integer-4
-use: src/tagged-rep
+use: src/int-rep
 literal: offset
-use: value/tagged-rep ;
+use: value/int-rep ;
 
 INSN: ##set-alien-cell
-use: src/tagged-rep
+use: src/int-rep
 literal: offset
-use: value/tagged-rep ;
+use: value/int-rep ;
 
 INSN: ##set-alien-float
-use: src/tagged-rep
+use: src/int-rep
 literal: offset
 use: value/float-rep ;
 
 INSN: ##set-alien-double
-use: src/tagged-rep
+use: src/int-rep
 literal: offset
 use: value/double-rep ;
 
 INSN: ##set-alien-vector
-use: src/tagged-rep
+use: src/int-rep
 literal: offset
 use: value
 literal: rep ;
@@ -652,7 +648,7 @@ literal: size class
 temp: temp/int-rep ;
 
 INSN: ##write-barrier
-use: src/tagged-rep slot/tagged-rep
+use: src/tagged-rep slot/int-rep
 temp: temp1/int-rep temp2/int-rep ;
 
 INSN: ##write-barrier-imm
@@ -661,7 +657,7 @@ literal: slot
 temp: temp1/int-rep temp2/int-rep ;
 
 INSN: ##alien-global
-def: dst/tagged-rep
+def: dst/int-rep
 literal: symbol library ;
 
 INSN: ##vm-field
@@ -669,7 +665,7 @@ def: dst/tagged-rep
 literal: offset ;
 
 INSN: ##set-vm-field
-use: src/tagged-rep
+use: src/int-rep
 literal: offset ;
 
 ! FFI
@@ -749,7 +745,7 @@ use: src1/tagged-rep src2/tagged-rep ;
 
 INSN: ##fixnum-mul
 def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+use: src1/tagged-rep src2/int-rep ;
 
 INSN: ##gc
 temp: temp1/int-rep temp2/int-rep
@@ -774,7 +770,7 @@ literal: label ;
 INSN: _loop-entry ;
 
 INSN: _dispatch
-use: src/tagged-rep
+use: src/int-rep
 temp: temp ;
 
 INSN: _dispatch-label
@@ -815,7 +811,7 @@ use: src1/tagged-rep src2/tagged-rep ;
 INSN: _fixnum-mul
 literal: label
 def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+use: src1/tagged-rep src2/int-rep ;
 
 TUPLE: spill-slot { n integer } ;
 C: <spill-slot> spill-slot
diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor
index cd76652d06..afca252bdc 100644
--- a/basis/compiler/cfg/instructions/syntax/syntax.factor
+++ b/basis/compiler/cfg/instructions/syntax/syntax.factor
@@ -37,17 +37,17 @@ TUPLE: insn-slot-spec type name rep ;
         ] reduce drop
     ] { } make ;
 
-: insn-def-slot ( class -- slot/f )
-    "insn-slots" word-prop
+: find-def-slot ( slots -- slot/f )
     [ type>> def eq? ] find nip ;
 
+: insn-def-slot ( class -- slot/f )
+    "insn-slots" word-prop find-def-slot ;
+
 : insn-use-slots ( class -- slots )
-    "insn-slots" word-prop
-    [ type>> use eq? ] filter ;
+    "insn-slots" word-prop [ type>> use eq? ] filter ;
 
 : insn-temp-slots ( class -- slots )
-    "insn-slots" word-prop
-    [ type>> temp eq? ] filter ;
+    "insn-slots" word-prop [ type>> temp eq? ] filter ;
 
 ! We cannot reference words in compiler.cfg.instructions directly
 ! since that would create circularity.
diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor
index 320a0a08f7..8ef51f6478 100644
--- a/basis/compiler/cfg/intrinsics/alien/alien.factor
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@@ -16,7 +16,7 @@ IN: compiler.cfg.intrinsics.alien
 
 : emit-<displaced-alien> ( node -- )
     dup emit-<displaced-alien>? [
-        [ 2inputs [ ^^untag-fixnum ] dip ] dip
+        [ 2inputs ] dip
         node-input-infos second class>>
         ^^box-displaced-alien ds-push
     ] [ emit-primitive ] if ;
@@ -32,11 +32,8 @@ IN: compiler.cfg.intrinsics.alien
     [ second class>> fixnum class<= ]
     bi and ;
 
-: ^^unbox-c-ptr ( src class -- dst )
-    [ next-vreg dup ] 2dip ##unbox-c-ptr ;
-
 : prepare-alien-accessor ( info -- ptr-vreg offset )
-    class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add 0 ;
+    class>> [ 2inputs swap ] dip ^^unbox-c-ptr ^^add 0 ;
 
 : prepare-alien-getter ( infos -- ptr-vreg offset )
     first prepare-alien-accessor ;
@@ -54,8 +51,8 @@ IN: compiler.cfg.intrinsics.alien
 : prepare-alien-setter ( infos -- ptr-vreg offset )
     second prepare-alien-accessor ;
 
-: inline-alien-integer-setter ( node quot -- )
-    '[ prepare-alien-setter ds-pop ^^untag-fixnum @ ]
+: inline-alien-setter ( node quot -- )
+    '[ prepare-alien-setter ds-pop @ ]
     [ fixnum inline-alien-setter? ]
     inline-alien ; inline
 
@@ -64,18 +61,13 @@ IN: compiler.cfg.intrinsics.alien
     [ pinned-c-ptr inline-alien-setter? ]
     inline-alien ; inline
 
-: inline-alien-float-setter ( node quot -- )
-    '[ prepare-alien-setter ds-pop @ ]
-    [ float inline-alien-setter? ]
-    inline-alien ; inline
-
 : emit-alien-unsigned-getter ( node n -- )
     '[
         _ {
             { 1 [ ^^alien-unsigned-1 ] }
             { 2 [ ^^alien-unsigned-2 ] }
             { 4 [ ^^alien-unsigned-4 ] }
-        } case ^^tag-fixnum
+        } case
     ] inline-alien-getter ;
 
 : emit-alien-signed-getter ( node n -- )
@@ -84,7 +76,7 @@ IN: compiler.cfg.intrinsics.alien
             { 1 [ ^^alien-signed-1 ] }
             { 2 [ ^^alien-signed-2 ] }
             { 4 [ ^^alien-signed-4 ] }
-        } case ^^tag-fixnum
+        } case
     ] inline-alien-getter ;
 
 : emit-alien-integer-setter ( node n -- )
@@ -94,7 +86,7 @@ IN: compiler.cfg.intrinsics.alien
             { 2 [ ##set-alien-integer-2 ] }
             { 4 [ ##set-alien-integer-4 ] }
         } case
-    ] inline-alien-integer-setter ;
+    ] inline-alien-setter ;
 
 : emit-alien-cell-getter ( node -- )
     [ ^^alien-cell ^^box-alien ] inline-alien-getter ;
@@ -116,4 +108,4 @@ IN: compiler.cfg.intrinsics.alien
             { float-rep [ ##set-alien-float ] }
             { double-rep [ ##set-alien-double ] }
         } case
-    ] inline-alien-float-setter ;
+    ] inline-alien-setter ;
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index ad7e02df8a..3f86332dcb 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences accessors layouts kernel math math.intervals
 namespaces combinators fry arrays
@@ -20,14 +20,17 @@ IN: compiler.cfg.intrinsics.fixnum
     0 cc= ^^compare-imm
     ds-push ;
 
-: emit-fixnum-op ( insn -- )
+: binary-fixnum-op ( quot -- )
     [ 2inputs ] dip call ds-push ; inline
 
+: unary-fixnum-op ( quot -- )
+    [ ds-pop ] dip call ds-push ; inline
+
 : emit-fixnum-left-shift ( -- )
-    [ ^^untag-fixnum ^^shl ] emit-fixnum-op ;
+    [ ^^shl ] binary-fixnum-op ;
 
 : emit-fixnum-right-shift ( -- )
-    [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
+    [ ^^sar ] binary-fixnum-op ;
 
 : emit-fixnum-shift-general ( -- )
     ds-peek 0 cc> ##compare-imm-branch
@@ -42,17 +45,8 @@ IN: compiler.cfg.intrinsics.fixnum
         [ drop emit-fixnum-shift-general ]
     } cond ;
 
-: emit-fixnum-bitnot ( -- )
-    ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
-
-: emit-fixnum-log2 ( -- )
-    ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
-
-: emit-fixnum*fast ( -- )
-    2inputs ^^untag-fixnum ^^mul ds-push ;
-
 : emit-fixnum-comparison ( cc -- )
-    '[ _ ^^compare ] emit-fixnum-op ;
+    '[ _ ^^compare ] binary-fixnum-op ;
 
 : emit-no-overflow-case ( dst -- final-bb )
     [ ds-drop ds-drop ds-push ] with-branch ;
@@ -80,4 +74,4 @@ IN: compiler.cfg.intrinsics.fixnum
     [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
 
 : emit-fixnum* ( -- )
-    [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
\ No newline at end of file
+    [ ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor
index 8a65de5805..39dc80cf28 100644
--- a/basis/compiler/cfg/intrinsics/float/float.factor
+++ b/basis/compiler/cfg/intrinsics/float/float.factor
@@ -14,10 +14,10 @@ IN: compiler.cfg.intrinsics.float
     [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
 
 : emit-float>fixnum ( -- )
-    ds-pop ^^float>integer ^^tag-fixnum ds-push ;
+    ds-pop ^^float>integer ds-push ;
 
 : emit-fixnum>float ( -- )
-    ds-pop ^^untag-fixnum ^^integer>float ds-push ;
+    ds-pop ^^integer>float ds-push ;
 
 : emit-fsqrt ( -- )
     ds-pop ^^sqrt ds-push ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 2b2ae7d160..35832d282e 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
+! Copyright (C) 2008, 2010 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel combinators cpu.architecture assocs
 compiler.cfg.hats
@@ -38,14 +38,14 @@ IN: compiler.cfg.intrinsics
     { math.private:fixnum+ [ drop emit-fixnum+ ] }
     { math.private:fixnum- [ drop emit-fixnum- ] }
     { math.private:fixnum* [ drop emit-fixnum* ] }
-    { math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
-    { math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
-    { math.private:fixnum*fast [ drop emit-fixnum*fast ] }
-    { math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
-    { math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
-    { math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
+    { math.private:fixnum+fast [ drop [ ^^add ] binary-fixnum-op ] }
+    { math.private:fixnum-fast [ drop [ ^^sub ] binary-fixnum-op ] }
+    { math.private:fixnum*fast [ drop [ ^^mul ] binary-fixnum-op ] }
+    { math.private:fixnum-bitand [ drop [ ^^and ] binary-fixnum-op ] }
+    { math.private:fixnum-bitor [ drop [ ^^or ] binary-fixnum-op ] }
+    { math.private:fixnum-bitxor [ drop [ ^^xor ] binary-fixnum-op ] }
     { math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
-    { math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+    { math.private:fixnum-bitnot [ drop [ ^^not ] unary-fixnum-op ] }
     { math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
     { math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
     { math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
@@ -143,13 +143,13 @@ IN: compiler.cfg.intrinsics
 
 : enable-min/max ( -- )
     {
-        { math.integers.private:fixnum-min [ drop [ ^^min ] emit-fixnum-op ] }
-        { math.integers.private:fixnum-max [ drop [ ^^max ] emit-fixnum-op ] }
+        { math.integers.private:fixnum-min [ drop [ ^^min ] binary-fixnum-op ] }
+        { math.integers.private:fixnum-max [ drop [ ^^max ] binary-fixnum-op ] }
     } enable-intrinsics ;
 
-: enable-fixnum-log2 ( -- )
+: enable-log2 ( -- )
     {
-        { math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
+        { math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-fixnum-op ] }
     } enable-intrinsics ;
 
 : emit-intrinsic ( node word -- )
diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor
index da77bcaa09..028b6ad990 100644
--- a/basis/compiler/cfg/intrinsics/misc/misc.factor
+++ b/basis/compiler/cfg/intrinsics/misc/misc.factor
@@ -9,7 +9,7 @@ FROM: vm => context-field-offset vm-field-offset ;
 IN: compiler.cfg.intrinsics.misc
 
 : emit-tag ( -- )
-    ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
+    ds-pop ^^tagged>integer tag-mask get ^^and-imm ds-push ;
 
 : special-object-offset ( n -- offset )
     cells "special-objects" vm-field-offset + ;
@@ -37,7 +37,8 @@ IN: compiler.cfg.intrinsics.misc
     ] [ emit-primitive ] ?if ;
 
 : emit-identity-hashcode ( -- )
-    ds-pop tag-mask get bitnot ^^load-immediate ^^and 0 0 ^^slot-imm
+    ds-pop ^^tagged>integer
+    tag-mask get bitnot ^^load-integer ^^and
+    0 ^^alien-cell
     hashcode-shift ^^shr-imm
-    ^^tag-fixnum
     ds-push ;
diff --git a/basis/compiler/cfg/intrinsics/simd/simd-tests.factor b/basis/compiler/cfg/intrinsics/simd/simd-tests.factor
index 8bd936c4f6..96c8da8ace 100644
--- a/basis/compiler/cfg/intrinsics/simd/simd-tests.factor
+++ b/basis/compiler/cfg/intrinsics/simd/simd-tests.factor
@@ -127,7 +127,7 @@ unit-test
 unit-test
 
 ! vneg
-[ { ##load-constant ##sub-vector } ]
+[ { ##load-reference ##sub-vector } ]
 [ simple-ops-cpu float-4-rep [ emit-simd-vneg ] test-emit ]
 unit-test
 
@@ -153,11 +153,11 @@ M: addsub-cpu %add-sub-vector-reps { int-4-rep float-4-rep } ;
 [ addsub-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
 unit-test
 
-[ { ##load-constant ##xor-vector ##add-vector } ]
+[ { ##load-reference ##xor-vector ##add-vector } ]
 [ simple-ops-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
 unit-test
 
-[ { ##load-constant ##xor-vector ##sub-vector ##add-vector } ]
+[ { ##load-reference ##xor-vector ##sub-vector ##add-vector } ]
 [ simple-ops-cpu int-4-rep [ emit-simd-v+- ] test-emit ]
 unit-test
 
@@ -301,7 +301,7 @@ unit-test
 [ abs-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
 unit-test
 
-[ { ##load-constant ##andn-vector } ]
+[ { ##load-reference ##andn-vector } ]
 [ simple-ops-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
 unit-test
 
@@ -388,7 +388,7 @@ TUPLE: shuffle-cpu < simple-ops-cpu ;
 M: shuffle-cpu %shuffle-vector-reps signed-reps ;
 
 ! vshuffle-elements
-[ { ##load-constant ##shuffle-vector } ]
+[ { ##load-reference ##shuffle-vector } ]
 [ shuffle-cpu { 0 1 2 3 } int-4-rep [ emit-simd-vshuffle-elements ] test-emit-literal ]
 unit-test
 
@@ -420,7 +420,7 @@ unit-test
 [ minmax-cpu int-4-rep [ emit-simd-v<= ] test-emit ]
 unit-test
 
-[ { ##load-constant ##xor-vector ##xor-vector ##compare-vector } ]
+[ { ##load-reference ##xor-vector ##xor-vector ##compare-vector } ]
 [ compare-cpu uint-4-rep [ emit-simd-v<= ] test-emit ]
 unit-test
 
diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor
index 0d413f1346..eebd76a38c 100644
--- a/basis/compiler/cfg/intrinsics/simd/simd.factor
+++ b/basis/compiler/cfg/intrinsics/simd/simd.factor
@@ -43,24 +43,24 @@ IN: compiler.cfg.intrinsics.simd
 
 : ^load-neg-zero-vector ( rep -- dst )
     {
-        { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
-        { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
+        { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-literal ] }
+        { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-literal ] }
     } case ;
 
 : ^load-add-sub-vector ( rep -- dst )
     signed-rep {
-        { float-4-rep    [ float-array{ -0.0  0.0 -0.0  0.0 } underlying>> ^^load-constant ] }
-        { double-2-rep   [ double-array{ -0.0  0.0 } underlying>> ^^load-constant ] }
-        { char-16-rep    [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
-        { short-8-rep    [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
-        { int-4-rep      [ int-array{ -1 0 -1 0 } underlying>> ^^load-constant ] }
-        { longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-constant ] }
+        { float-4-rep    [ float-array{ -0.0  0.0 -0.0  0.0 } underlying>> ^^load-literal ] }
+        { double-2-rep   [ double-array{ -0.0  0.0 } underlying>> ^^load-literal ] }
+        { char-16-rep    [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-literal ] }
+        { short-8-rep    [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-literal ] }
+        { int-4-rep      [ int-array{ -1 0 -1 0 } underlying>> ^^load-literal ] }
+        { longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-literal ] }
     } case ;
 
 : ^load-half-vector ( rep -- dst )
     {
-        { float-4-rep  [ float-array{  0.5 0.5 0.5 0.5 } underlying>> ^^load-constant ] }
-        { double-2-rep [ double-array{ 0.5 0.5 }         underlying>> ^^load-constant ] }
+        { float-4-rep  [ float-array{  0.5 0.5 0.5 0.5 } underlying>> ^^load-literal ] }
+        { double-2-rep [ double-array{ 0.5 0.5 }         underlying>> ^^load-literal ] }
     } case ;
 
 : >variable-shuffle ( shuffle rep -- shuffle' )
@@ -70,7 +70,7 @@ IN: compiler.cfg.intrinsics.simd
     '[ _ n*v _ v+ ] map concat ;
 
 : ^load-immediate-shuffle ( shuffle rep -- dst )
-    >variable-shuffle ^^load-constant ;
+    >variable-shuffle ^^load-literal ;
 
 :: ^blend-vector ( mask true false rep -- dst )
     true mask rep ^^and-vector
@@ -118,7 +118,7 @@ IN: compiler.cfg.intrinsics.simd
         [ ^(compare-vector) ]
         [ ^minmax-compare-vector ]
         { unsigned-int-vector-rep [| src1 src2 rep cc |
-            rep sign-bit-mask ^^load-constant :> sign-bits
+            rep sign-bit-mask ^^load-literal :> sign-bits
             src1 sign-bits rep ^^xor-vector
             src2 sign-bits rep ^^xor-vector
             rep signed-rep cc ^(compare-vector)
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index 1ceac4990a..5203c8535c 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -76,8 +76,7 @@ IN: compiler.cfg.intrinsics.slots
     ] [ drop emit-primitive ] if ;
 
 : emit-string-nth ( -- )
-    2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
+    2inputs swap ^^string-nth ds-push ;
 
 : emit-set-string-nth-fast ( -- )
-    3inputs [ ^^untag-fixnum ] [ ^^untag-fixnum ] [ ] tri*
-    swap next-vreg ##set-string-nth-fast ;
+    3inputs swap next-vreg ##set-string-nth-fast ;
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index dcf2e743ec..b3fca6bab7 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -1126,7 +1126,7 @@ V{
 V{ T{ ##prologue } T{ ##branch } } 0 test-bb
 
 V{
-    T{ ##load-immediate { dst 61 } }
+    T{ ##load-integer { dst 61 } }
     T{ ##peek { dst 62 } { loc D 0 } }
     T{ ##peek { dst 64 } { loc D 1 } }
     T{ ##slot-imm
@@ -1269,7 +1269,7 @@ V{
         { src1 109 }
         { src2 8 }
     }
-    T{ ##load-immediate { dst 129 } { val 24 } }
+    T{ ##load-integer { dst 129 } { val 24 } }
     T{ ##inc-d { n 4 } }
     T{ ##inc-r { n 1 } }
     T{ ##replace { src 109 } { loc D 2 } }
diff --git a/basis/compiler/cfg/representations/conversion/conversion.factor b/basis/compiler/cfg/representations/conversion/conversion.factor
index 071adea76d..87cca9204a 100644
--- a/basis/compiler/cfg/representations/conversion/conversion.factor
+++ b/basis/compiler/cfg/representations/conversion/conversion.factor
@@ -7,59 +7,70 @@ IN: compiler.cfg.representations.conversion
 
 ERROR: bad-conversion dst src dst-rep src-rep ;
 
-GENERIC: emit-box ( dst src rep -- )
-GENERIC: emit-unbox ( dst src rep -- )
+GENERIC: rep>tagged ( dst src rep -- )
+GENERIC: tagged>rep ( dst src rep -- )
 
-M: int-rep emit-box ( dst src rep -- )
+M: int-rep rep>tagged ( dst src rep -- )
     drop tag-bits get ##shl-imm ;
 
-M: int-rep emit-unbox ( dst src rep -- )
+M: int-rep tagged>rep ( dst src rep -- )
     drop tag-bits get ##sar-imm ;
 
-M:: float-rep emit-box ( dst src rep -- )
+M:: float-rep rep>tagged ( dst src rep -- )
     double-rep next-vreg-rep :> temp
     temp src ##single>double-float
-    dst temp double-rep emit-box ;
+    dst temp double-rep rep>tagged ;
 
-M:: float-rep emit-unbox ( dst src rep -- )
+M:: float-rep tagged>rep ( dst src rep -- )
     double-rep next-vreg-rep :> temp
-    temp src double-rep emit-unbox
+    temp src double-rep tagged>rep
     dst temp ##double>single-float ;
 
-M: double-rep emit-box
+M: double-rep rep>tagged
     drop
-    [ drop 16 float tagged-rep next-vreg-rep ##allot ]
+    [ drop 16 float int-rep next-vreg-rep ##allot ]
     [ float-offset swap ##set-alien-double ]
     2bi ;
 
-M: double-rep emit-unbox
+M: double-rep tagged>rep
     drop float-offset ##alien-double ;
 
-M:: vector-rep emit-box ( dst src rep -- )
+M:: vector-rep rep>tagged ( dst src rep -- )
     tagged-rep next-vreg-rep :> temp
-    dst 16 2 cells + byte-array tagged-rep next-vreg-rep ##allot
-    temp 16 tag-fixnum ##load-immediate
+    dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
+    temp 16 tag-fixnum ##load-tagged
     temp dst 1 byte-array type-number ##set-slot-imm
     dst byte-array-offset src rep ##set-alien-vector ;
 
-M: vector-rep emit-unbox
+M: vector-rep tagged>rep
     [ byte-array-offset ] dip ##alien-vector ;
 
-M:: scalar-rep emit-box ( dst src rep -- )
+M:: scalar-rep rep>tagged ( dst src rep -- )
     tagged-rep next-vreg-rep :> temp
     temp src rep ##scalar>integer
-    dst temp int-rep emit-box ;
+    dst temp int-rep rep>tagged ;
 
-M:: scalar-rep emit-unbox ( dst src rep -- )
+M:: scalar-rep tagged>rep ( dst src rep -- )
     tagged-rep next-vreg-rep :> temp
-    temp src int-rep emit-unbox
+    temp src int-rep tagged>rep
     dst temp rep ##integer>scalar ;
 
+GENERIC: rep>int ( dst src rep -- )
+GENERIC: int>rep ( dst src rep -- )
+
+M: scalar-rep rep>int ( dst src rep -- )
+    ##scalar>integer ;
+
+M: scalar-rep int>rep ( dst src rep -- )
+    ##integer>scalar ;
+
 : emit-conversion ( dst src dst-rep src-rep -- )
     {
         { [ 2dup eq? ] [ drop ##copy ] }
-        { [ dup tagged-rep eq? ] [ drop emit-unbox ] }
-        { [ over tagged-rep eq? ] [ nip emit-box ] }
+        { [ dup tagged-rep? ] [ drop tagged>rep ] }
+        { [ over tagged-rep? ] [ nip rep>tagged ] }
+        { [ dup int-rep? ] [ drop int>rep ] }
+        { [ over int-rep? ] [ nip rep>int ] }
         [
             2dup 2array {
                 { { double-rep float-rep } [ 2drop ##single>double-float ] }
diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor
index a00f65e075..35e56f5489 100644
--- a/basis/compiler/cfg/representations/representations-tests.factor
+++ b/basis/compiler/cfg/representations/representations-tests.factor
@@ -1,7 +1,7 @@
 USING: accessors compiler.cfg compiler.cfg.debugger
 compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.representations.preferred cpu.architecture kernel
-namespaces tools.test sequences arrays system ;
+namespaces tools.test sequences arrays system literals layouts ;
 IN: compiler.cfg.representations
 
 [ { double-rep double-rep } ] [
@@ -50,6 +50,59 @@ V{
 
 [ 1 ] [ 1 get instructions>> [ ##allot? ] count ] unit-test
 
+! Converting a ##load-integer into a ##load-tagged
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##load-integer f 1 100 }
+    T{ ##replace f 1 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+[ ] [ test-representations ] unit-test
+
+[ T{ ##load-tagged f 1 $[ 100 tag-fixnum ] } ]
+[ 1 get instructions>> first ]
+unit-test
+
+! scalar-rep => int-rep conversion
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##peek f 2 D 0 }
+    T{ ##vector>scalar f 3 2 int-4-rep }
+    T{ ##shl f 4 1 3 }
+    T{ ##replace f 4 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+[ ] [ test-representations ] unit-test
+
+[ t ] [ 1 get instructions>> 4 swap nth ##scalar>integer? ] unit-test
+
 cpu x86.32? [
 
     ! Make sure load-constant is converted into load-double
@@ -60,7 +113,7 @@ cpu x86.32? [
 
     V{
         T{ ##peek f 1 D 0 }
-        T{ ##load-constant f 2 0.5 }
+        T{ ##load-reference f 2 0.5 }
         T{ ##add-float f 3 1 2 }
         T{ ##replace f 3 D 0 }
         T{ ##branch }
@@ -90,12 +143,12 @@ cpu x86.32? [
     } 1 test-bb
 
     V{
-        T{ ##load-constant f 2 1.5 }
+        T{ ##load-reference f 2 1.5 }
         T{ ##branch }
     } 2 test-bb
 
     V{
-        T{ ##load-constant f 3 2.5 }
+        T{ ##load-reference f 3 2.5 }
         T{ ##branch }
     } 3 test-bb
 
diff --git a/basis/compiler/cfg/representations/rewrite/rewrite.factor b/basis/compiler/cfg/representations/rewrite/rewrite.factor
index 7b9164ce78..d5afe1faa2 100644
--- a/basis/compiler/cfg/representations/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/representations/rewrite/rewrite.factor
@@ -1,12 +1,16 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators
-combinators.short-circuit compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.renaming.functor
+combinators.short-circuit layouts kernel locals make math
+namespaces sequences
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.renaming.functor
 compiler.cfg.representations.conversion
-compiler.cfg.representations.preferred compiler.cfg.rpo
-compiler.cfg.utilities cpu.architecture kernel locals make math
-namespaces sequences ;
+compiler.cfg.representations.preferred
+compiler.cfg.rpo
+compiler.cfg.utilities
+cpu.architecture ;
 IN: compiler.cfg.representations.rewrite
 
 ! Insert conversions. This introduces new temporaries, so we need
@@ -78,7 +82,16 @@ GENERIC: conversions-for-insn ( insn -- )
 
 M: ##phi conversions-for-insn , ;
 
-! When a float is unboxed, we replace the ##load-constant with a ##load-double
+M: ##load-integer conversions-for-insn
+    {
+        {
+            [ dup dst>> rep-of tagged-rep? ]
+            [ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+! When a float is unboxed, we replace the ##load-reference with a ##load-double
 ! if the architecture supports it
 : convert-to-load-double? ( insn -- ? )
     {
@@ -107,29 +120,23 @@ M: ##phi conversions-for-insn , ;
 : (convert-to-zero/fill-vector) ( insn -- dst rep )
     dst>> dup rep-of ; inline
 
-: conversions-for-load-insn ( insn -- ?insn )
+M: ##load-reference conversions-for-insn
     {
         {
             [ dup convert-to-load-double? ]
-            [ (convert-to-load-double) ##load-double f ]
+            [ (convert-to-load-double) ##load-double ]
         }
         {
             [ dup convert-to-zero-vector? ]
-            [ (convert-to-zero/fill-vector) ##zero-vector f ]
+            [ (convert-to-zero/fill-vector) ##zero-vector ]
         }
         {
             [ dup convert-to-fill-vector? ]
-            [ (convert-to-zero/fill-vector) ##fill-vector f ]
+            [ (convert-to-zero/fill-vector) ##fill-vector ]
         }
-        [ ]
+        [ call-next-method ]
     } cond ;
 
-M: ##load-reference conversions-for-insn
-    conversions-for-load-insn [ call-next-method ] when* ;
-
-M: ##load-constant conversions-for-insn
-    conversions-for-load-insn [ call-next-method ] when* ;
-
 M: vreg-insn conversions-for-insn
     [ compute-renaming-set ] [ perform-renaming ] bi ;
 
diff --git a/basis/compiler/cfg/representations/selection/selection.factor b/basis/compiler/cfg/representations/selection/selection.factor
index 4178101ddd..77ffde01ad 100644
--- a/basis/compiler/cfg/representations/selection/selection.factor
+++ b/basis/compiler/cfg/representations/selection/selection.factor
@@ -29,7 +29,7 @@ SYMBOL: always-boxed
     H{ } clone [
         '[
             [
-                dup [ ##load-reference? ] [ ##load-constant? ] bi or
+                dup ##load-reference?
                 [ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
             ] each-non-phi
         ] each-basic-block
@@ -65,9 +65,9 @@ SYMBOL: costs
 
 GENERIC: compute-insn-costs ( insn -- )
 
-M: ##load-constant compute-insn-costs
-    ! There's no cost to unboxing the result of a ##load-constant
-    drop ;
+! There's no cost to converting a constant's representation
+M: ##load-integer compute-insn-costs drop ;
+M: ##load-reference compute-insn-costs drop ;
 
 M: insn compute-insn-costs [ representation-cost ] each-rep ;
 
diff --git a/basis/compiler/cfg/ssa/construction/construction-tests.factor b/basis/compiler/cfg/ssa/construction/construction-tests.factor
index 3d743176b1..54b02b7450 100644
--- a/basis/compiler/cfg/ssa/construction/construction-tests.factor
+++ b/basis/compiler/cfg/ssa/construction/construction-tests.factor
@@ -13,19 +13,19 @@ IN: compiler.cfg.ssa.construction.tests
 reset-counters
 
 V{
-    T{ ##load-immediate f 1 100 }
+    T{ ##load-integer f 1 100 }
     T{ ##add-imm f 2 1 50 }
     T{ ##add-imm f 2 2 10 }
     T{ ##branch }
 } 0 test-bb
 
 V{
-    T{ ##load-immediate f 3 3 }
+    T{ ##load-integer f 3 3 }
     T{ ##branch }
 } 1 test-bb
 
 V{
-    T{ ##load-immediate f 3 4 }
+    T{ ##load-integer f 3 4 }
     T{ ##branch }
 } 2 test-bb
 
@@ -48,7 +48,7 @@ V{
 
 [
     V{
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add-imm f 2 1 50 }
         T{ ##add-imm f 3 2 10 }
         T{ ##branch }
@@ -57,14 +57,14 @@ V{
 
 [
     V{
-        T{ ##load-immediate f 4 3 }
+        T{ ##load-integer f 4 3 }
         T{ ##branch }
     }
 ] [ 1 get instructions>> ] unit-test
 
 [
     V{
-        T{ ##load-immediate f 5 4 }
+        T{ ##load-integer f 5 4 }
         T{ ##branch }
     }
 ] [ 2 get instructions>> ] unit-test
diff --git a/basis/compiler/cfg/ssa/cssa/cssa.factor b/basis/compiler/cfg/ssa/cssa/cssa.factor
index d58cebac65..611f722cb3 100644
--- a/basis/compiler/cfg/ssa/cssa/cssa.factor
+++ b/basis/compiler/cfg/ssa/cssa/cssa.factor
@@ -7,7 +7,7 @@ compiler.cfg.def-use
 compiler.cfg.utilities
 compiler.cfg.registers
 compiler.cfg.instructions
-compiler.cfg.representations ;
+compiler.cfg.representations.conversion ;
 IN: compiler.cfg.ssa.cssa
 
 ! Convert SSA to conventional SSA. This pass runs after representation
diff --git a/basis/compiler/cfg/value-numbering/alien/alien.factor b/basis/compiler/cfg/value-numbering/alien/alien.factor
new file mode 100644
index 0000000000..db9e02d4a6
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/alien/alien.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry kernel make math
+compiler.cfg.hats
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.alien
+
+! ##box-displaced-alien f 1 2 3 <class>
+! ##unbox-c-ptr 4 1 <class>
+! =>
+! ##box-displaced-alien f 1 2 3 <class>
+! ##unbox-c-ptr 5 3 <class>
+! ##add 4 5 2
+
+: rewrite-unbox-displaced-alien ( insn expr -- insns )
+    [
+        [ dst>> ]
+        [ [ base>> vn>vreg ] [ base-class>> ] [ displacement>> vn>vreg ] tri ] bi*
+        [ ^^unbox-c-ptr ] dip
+        ##add
+    ] { } make ;
+
+M: ##unbox-any-c-ptr rewrite
+    dup src>> vreg>expr dup box-displaced-alien-expr?
+    [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
+
+! More efficient addressing for alien intrinsics
+: rewrite-alien-addressing ( insn -- insn' )
+    dup src>> vreg>expr dup add-imm-expr? [
+        [ src1>> vn>vreg ] [ src2>> vn>integer ] bi
+        [ >>src ] [ '[ _ + ] change-offset ] bi*
+    ] [ 2drop f ] if ;
+
+M: ##alien-unsigned-1 rewrite rewrite-alien-addressing ;
+M: ##alien-unsigned-2 rewrite rewrite-alien-addressing ;
+M: ##alien-unsigned-4 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-1 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-2 rewrite rewrite-alien-addressing ;
+M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
+M: ##alien-float rewrite rewrite-alien-addressing ;
+M: ##alien-double rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
+M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
+M: ##set-alien-float rewrite rewrite-alien-addressing ;
+M: ##set-alien-double rewrite rewrite-alien-addressing ;
diff --git a/basis/compiler/cfg/value-numbering/alien/authors.txt b/basis/compiler/cfg/value-numbering/alien/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/alien/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/value-numbering/comparisons/authors.txt b/basis/compiler/cfg/value-numbering/comparisons/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/comparisons/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
new file mode 100644
index 0000000000..45b15b61d2
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
@@ -0,0 +1,167 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel math math.order namespaces
+sequences vectors combinators.short-circuit compiler.cfg
+compiler.cfg.comparisons compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering.comparisons
+
+: ##branch-t? ( insn -- ? )
+    dup ##compare-imm-branch? [
+        { [ cc>> cc/= eq? ] [ src2>> not ] } 1&&
+    ] [ drop f ] if ; inline
+
+: scalar-compare-expr? ( insn -- ? )
+    {
+        [ compare-expr? ]
+        [ compare-imm-expr? ]
+        [ compare-float-unordered-expr? ]
+        [ compare-float-ordered-expr? ]
+    } 1|| ;
+
+: general-compare-expr? ( insn -- ? )
+    {
+        [ scalar-compare-expr? ]
+        [ test-vector-expr? ]
+    } 1|| ;
+
+: rewrite-boolean-comparison? ( insn -- ? )
+    dup ##branch-t? [
+        src1>> vreg>expr general-compare-expr?
+    ] [ drop f ] if ; inline
+ 
+: >compare-expr< ( expr -- in1 in2 cc )
+    [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
+
+: >compare-imm-expr< ( expr -- in1 in2 cc )
+    [ src1>> vn>vreg ] [ src2>> vn>integer ] [ cc>> ] tri ; inline
+
+: >test-vector-expr< ( expr -- src1 temp rep vcc )
+    {
+        [ src1>> vn>vreg ]
+        [ drop next-vreg ]
+        [ rep>> ]
+        [ vcc>> ]
+    } cleave ; inline
+
+: rewrite-boolean-comparison ( expr -- insn )
+    src1>> vreg>expr {
+        { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
+        { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
+        { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
+        { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] }
+        { [ dup test-vector-expr? ] [ >test-vector-expr< \ ##test-vector-branch new-insn ] }
+    } cond ;
+
+: rewrite-redundant-comparison? ( insn -- ? )
+    {
+        [ src1>> vreg>expr scalar-compare-expr? ]
+        [ src2>> not ]
+        [ cc>> { cc= cc/= } member? ]
+    } 1&& ; inline
+
+: rewrite-redundant-comparison ( insn -- insn' )
+    [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
+        { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
+        { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
+        { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
+        { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
+    } cond
+    swap cc= eq? [ [ negate-cc ] change-cc ] when ;
+
+: evaluate-compare-imm ( insn -- ? )
+    [ src1>> vreg>comparand ] [ src2>> ] [ cc>> ] tri
+    2over [ integer? ] both? [ [ <=> ] dip evaluate-cc ] [
+        {
+            { cc= [ eq? ] }
+            { cc/= [ eq? not ] }
+        } case
+    ] if ;
+
+: fold-compare-imm? ( insn -- ? )
+    src1>> vreg>expr literal-expr? ;
+
+: fold-branch ( ? -- insn )
+    0 1 ?
+    basic-block get [ nth 1vector ] change-successors drop
+    \ ##branch new-insn ;
+
+: fold-compare-imm-branch ( insn -- insn/f )
+    evaluate-compare-imm fold-branch ;
+
+M: ##compare-imm-branch rewrite
+    {
+        { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
+        { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
+        [ drop f ]
+    } cond ;
+
+: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
+    [ [ swap ] dip swap-cc ] when ; inline
+
+: >compare-imm-branch ( insn swap? -- insn' )
+    [
+        [ src1>> ]
+        [ src2>> ]
+        [ cc>> ]
+        tri
+    ] dip
+    swap-compare
+    [ vreg>comparand ] dip
+    \ ##compare-imm-branch new-insn ; inline
+
+: self-compare? ( insn -- ? )
+    [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
+
+: evaluate-self-compare ( insn -- ? )
+    cc>> { cc= cc<= cc>= } member-eq? ;
+
+: rewrite-self-compare-branch ( insn -- insn' )
+    evaluate-self-compare fold-branch ;
+
+M: ##compare-branch rewrite
+    {
+        { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm-branch ] }
+        { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm-branch ] }
+        { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
+        [ drop f ]
+    } cond ;
+
+: >compare-imm ( insn swap? -- insn' )
+    [
+        {
+            [ dst>> ]
+            [ src1>> ]
+            [ src2>> ]
+            [ cc>> ]
+        } cleave
+    ] dip
+    swap-compare
+    [ vreg>comparand ] dip
+    next-vreg \ ##compare-imm new-insn ; inline
+
+: >boolean-insn ( insn ? -- insn' )
+    [ dst>> ] dip \ ##load-reference new-insn ;
+
+: rewrite-self-compare ( insn -- insn' )
+    dup evaluate-self-compare >boolean-insn ;
+
+M: ##compare rewrite
+    {
+        { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm ] }
+        { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm ] }
+        { [ dup self-compare? ] [ rewrite-self-compare ] }
+        [ drop f ]
+    } cond ;
+
+: fold-compare-imm ( insn -- insn' )
+    dup evaluate-compare-imm >boolean-insn ;
+
+M: ##compare-imm rewrite
+    {
+        { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
+        { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
+        [ drop f ]
+    } cond ;
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index d2e7c2ac86..92260ae6ee 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -1,46 +1,87 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes classes.algebra classes.parser
 classes.tuple combinators combinators.short-circuit fry
-generic.parser kernel math namespaces quotations sequences slots
-splitting words compiler.cfg.instructions
+generic.parser kernel layouts locals math namespaces quotations
+sequences slots splitting words
+cpu.architecture
+compiler.cfg.instructions
 compiler.cfg.instructions.syntax
 compiler.cfg.value-numbering.graph ;
 IN: compiler.cfg.value-numbering.expressions
 
-TUPLE: constant-expr < expr value ;
+TUPLE: integer-expr < expr value ;
 
-C: <constant> constant-expr
-
-M: constant-expr equal?
-    over constant-expr? [
-        [ value>> ] bi@
-        2dup [ float? ] both? [ fp-bitwise= ] [
-            { [ [ class ] bi@ = ] [ = ] } 2&&
-        ] if
-    ] [ 2drop f ] if ;
+C: <integer-expr> integer-expr
 
 TUPLE: reference-expr < expr value ;
 
-C: <reference> reference-expr
+C: <reference-expr> reference-expr
 
 M: reference-expr equal?
-    over reference-expr? [ [ value>> ] bi@ eq? ] [ 2drop f ] if ;
+    over reference-expr? [
+        [ value>> ] bi@
+        2dup [ float? ] both?
+        [ fp-bitwise= ] [ eq? ] if
+    ] [ 2drop f ] if ;
 
 M: reference-expr hashcode*
-    nip value>> identity-hashcode ;
+    nip value>> dup float? [ double>bits ] [ identity-hashcode ] if ;
 
-: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
+UNION: literal-expr integer-expr reference-expr ;
 
 GENERIC: >expr ( insn -- expr )
 
 M: insn >expr drop next-input-expr ;
 
-M: ##load-immediate >expr val>> <constant> ;
+M: ##load-integer >expr val>> <integer-expr> ;
 
-M: ##load-reference >expr obj>> <reference> ;
+M: ##load-reference >expr obj>> <reference-expr> ;
 
-M: ##load-constant >expr obj>> <constant> ;
+GENERIC: expr>reference ( expr -- obj )
+
+M: reference-expr expr>reference value>> ;
+
+: vn>reference ( vn -- obj ) vn>expr expr>reference ;
+
+: vreg>reference ( vreg -- obj ) vreg>vn vn>reference ; inline
+
+GENERIC: expr>integer ( expr -- n )
+
+M: integer-expr expr>integer value>> ;
+
+: vn>integer ( vn -- n ) vn>expr expr>integer ;
+
+: vreg>integer ( vreg -- n ) vreg>vn vn>integer ; inline
+
+: vreg-immediate-arithmetic? ( vreg -- ? )
+    vreg>expr {
+        [ integer-expr? ]
+        [ expr>integer tag-fixnum immediate-arithmetic? ]
+    } 1&& ;
+
+: vreg-immediate-bitwise? ( vreg -- ? )
+    vreg>expr {
+        [ integer-expr? ]
+        [ expr>integer tag-fixnum immediate-bitwise? ]
+    } 1&& ;
+
+GENERIC: expr>comparand ( expr -- n )
+
+M: integer-expr expr>comparand value>> ;
+
+M: reference-expr expr>comparand value>> ;
+
+: vn>comparand ( vn -- n ) vn>expr expr>comparand ;
+
+: vreg>comparand ( vreg -- n ) vreg>vn vn>comparand ; inline
+
+: vreg-immediate-comparand? ( vreg -- ? )
+    vreg>expr {
+        { [ dup integer-expr? ] [ expr>integer tag-fixnum immediate-comparand? ] }
+        { [ dup reference-expr? ] [ value>> immediate-comparand? ] }
+        [ drop f ]
+    } cond ;
 
 <<
 
@@ -50,8 +91,12 @@ M: ##load-constant >expr obj>> <constant> ;
 : expr-class ( insn -- expr )
     name>> "##" ?head drop "-expr" append create-class-in ;
 
-: define-expr-class ( insn expr slot-specs -- )
-    [ nip expr ] dip [ name>> ] map define-tuple-class ;
+: define-expr-class ( expr slot-specs -- )
+    [ expr ] dip [ name>> ] map define-tuple-class ;
+
+: constant>vn ( obj -- vn )
+    dup integer? [ <integer-expr> ] [ <reference-expr> ] if
+    expr>vn ;
 
 : >expr-quot ( expr slot-specs -- quot )
      [
@@ -66,11 +111,11 @@ M: ##load-constant >expr obj>> <constant> ;
     ] map cleave>quot swap suffix \ boa suffix ;
 
 : define->expr-method ( insn expr slot-specs -- )
-    [ 2drop \ >expr create-method-in ] [ >expr-quot nip ] 3bi define ;
+    [ \ >expr create-method-in ] 2dip >expr-quot define ;
 
 : handle-pure-insn ( insn -- )
     [ ] [ expr-class ] [ "insn-slots" word-prop input-values ] tri
-    [ define-expr-class ] [ define->expr-method ] 3bi ;
+    [ define-expr-class drop ] [ define->expr-method ] 3bi ;
 
 insn-classes get [ pure-insn class<= ] filter [ handle-pure-insn ] each
 
diff --git a/basis/compiler/cfg/value-numbering/folding/authors.txt b/basis/compiler/cfg/value-numbering/folding/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/folding/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/value-numbering/folding/folding.factor b/basis/compiler/cfg/value-numbering/folding/folding.factor
new file mode 100644
index 0000000000..3cd9df8b4b
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/folding/folding.factor
@@ -0,0 +1,39 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel layouts math math.bitwise
+compiler.cfg.instructions
+compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.graph ;
+IN: compiler.cfg.value-numbering.folding
+
+: binary-constant-fold? ( insn -- ? )
+    src1>> vreg>expr integer-expr? ; inline
+
+GENERIC: binary-constant-fold* ( x y insn -- z )
+
+M: ##add-imm binary-constant-fold* drop + ;
+M: ##sub-imm binary-constant-fold* drop - ;
+M: ##mul-imm binary-constant-fold* drop * ;
+M: ##and-imm binary-constant-fold* drop bitand ;
+M: ##or-imm binary-constant-fold* drop bitor ;
+M: ##xor-imm binary-constant-fold* drop bitxor ;
+M: ##shr-imm binary-constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
+M: ##sar-imm binary-constant-fold* drop neg shift ;
+M: ##shl-imm binary-constant-fold* drop shift ;
+
+: binary-constant-fold ( insn -- insn' )
+    [ dst>> ]
+    [ [ src1>> vreg>integer ] [ src2>> ] [ ] tri binary-constant-fold* ] bi
+    \ ##load-integer new-insn ; inline
+
+: unary-constant-fold? ( insn -- ? )
+    src>> vreg>expr integer-expr? ; inline
+
+GENERIC: unary-constant-fold* ( x insn -- y )
+
+M: ##not unary-constant-fold* drop bitnot ;
+M: ##neg unary-constant-fold* drop neg ;
+
+: unary-constant-fold ( insn -- insn' )
+    [ dst>> ] [ [ src>> vreg>integer ] [ ] bi unary-constant-fold* ] bi
+    \ ##load-integer new-insn ; inline
diff --git a/basis/compiler/cfg/value-numbering/graph/graph.factor b/basis/compiler/cfg/value-numbering/graph/graph.factor
index f380ecd02f..8ba09b125d 100644
--- a/basis/compiler/cfg/value-numbering/graph/graph.factor
+++ b/basis/compiler/cfg/value-numbering/graph/graph.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math namespaces assocs biassocs ;
 IN: compiler.cfg.value-numbering.graph
@@ -35,10 +35,6 @@ SYMBOL: vregs>vns
 
 : vreg>expr ( vreg -- expr ) vreg>vn vn>expr ; inline
 
-: vn>constant ( vn -- constant ) vn>expr value>> ; inline
-
-: vreg>constant ( vreg -- constant ) vreg>vn vn>constant ; inline
-
 : init-value-graph ( -- )
     0 vn-counter set
     0 input-expr-counter set
diff --git a/basis/compiler/cfg/value-numbering/math/authors.txt b/basis/compiler/cfg/value-numbering/math/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/math/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/value-numbering/math/math.factor b/basis/compiler/cfg/value-numbering/math/math.factor
new file mode 100644
index 0000000000..bbc2d5a169
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/math/math.factor
@@ -0,0 +1,196 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators cpu.architecture fry kernel layouts
+math sequences compiler.cfg.instructions
+compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.folding
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite
+compiler.cfg.value-numbering.simplify ;
+IN: compiler.cfg.value-numbering.math
+
+M: ##tagged>integer rewrite
+    [ dst>> ] [ src>> vreg>expr ] bi {
+        { [ dup integer-expr? ] [ value>> tag-fixnum \ ##load-integer new-insn ] }
+        { [ dup reference-expr? ] [ value>> [ drop f ] [ \ f type-number \ ##load-integer new-insn ] if ] }
+        [ 2drop f ]
+    } cond ;
+
+M: ##neg rewrite
+    dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ;
+
+M: ##not rewrite
+    dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ;
+
+: reassociate ( insn -- dst src1 src2 )
+    {
+        [ dst>> ]
+        [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>integer ] bi ]
+        [ src2>> ]
+        [ ]
+    } cleave binary-constant-fold* ;
+
+: ?new-insn ( dst src1 src2 ? class -- insn/f )
+    '[ _ new-insn ] [ 3drop f ] if ; inline
+
+: reassociate-arithmetic ( insn new-insn -- insn/f )
+    [ reassociate dup immediate-arithmetic? ] dip ?new-insn ; inline
+
+: reassociate-bitwise ( insn new-insn -- insn/f )
+    [ reassociate dup immediate-bitwise? ] dip ?new-insn ; inline
+
+M: ##add-imm rewrite
+    {
+        { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate-arithmetic ] }
+        [ drop f ]
+    } cond ;
+
+: sub-imm>add-imm ( insn -- insn' )
+    [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup immediate-arithmetic?
+    \ ##add-imm ?new-insn ;
+
+M: ##sub-imm rewrite
+    {
+        { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        [ sub-imm>add-imm ]
+    } cond ;
+
+: mul-to-neg? ( insn -- ? )
+    src2>> -1 = ;
+
+: mul-to-neg ( insn -- insn' )
+    [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
+
+: mul-to-shl? ( insn -- ? )
+    src2>> power-of-2? ;
+
+: mul-to-shl ( insn -- insn' )
+    [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+
+M: ##mul-imm rewrite
+    {
+        { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        { [ dup mul-to-neg? ] [ mul-to-neg ] }
+        { [ dup mul-to-shl? ] [ mul-to-shl ] }
+        { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate-arithmetic ] }
+        [ drop f ]
+    } cond ;
+
+M: ##and-imm rewrite
+    {
+        { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate-bitwise ] }
+        [ drop f ]
+    } cond ;
+
+M: ##or-imm rewrite
+    {
+        { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate-bitwise ] }
+        [ drop f ]
+    } cond ;
+
+M: ##xor-imm rewrite
+    {
+        { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate-bitwise ] }
+        [ drop f ]
+    } cond ;
+
+M: ##shl-imm rewrite
+    {
+        { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        [ drop f ]
+    } cond ;
+
+M: ##shr-imm rewrite
+    {
+        { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        [ drop f ]
+    } cond ;
+
+M: ##sar-imm rewrite
+    {
+        { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        [ drop f ]
+    } cond ;
+
+: insn>imm-insn ( insn op swap? -- new-insn )
+    swap [
+        [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
+        [ swap ] when vreg>integer
+    ] dip new-insn ; inline
+
+M: ##add rewrite
+    {
+        { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##add-imm f insn>imm-insn ] }
+        { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##add-imm t insn>imm-insn ] }
+        [ drop f ]
+    } cond ;
+
+: subtraction-identity? ( insn -- ? )
+    [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ;
+
+: rewrite-subtraction-identity ( insn -- insn' )
+    dst>> 0 \ ##load-integer new-insn ;
+
+: sub-to-neg? ( ##sub -- ? )
+    src1>> vn>expr expr-zero? ;
+
+: sub-to-neg ( ##sub -- insn )
+    [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
+
+M: ##sub rewrite
+    {
+        { [ dup sub-to-neg? ] [ sub-to-neg ] }
+        { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
+        { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##sub-imm f insn>imm-insn ] }
+        [ drop f ]
+    } cond ;
+
+M: ##mul rewrite
+    {
+        { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##mul-imm f insn>imm-insn ] }
+        { [ dup src1>> vreg-immediate-arithmetic? ] [ \ ##mul-imm t insn>imm-insn ] }
+        [ drop f ]
+    } cond ;
+
+M: ##and rewrite
+    {
+        { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##and-imm f insn>imm-insn ] }
+        { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##and-imm t insn>imm-insn ] }
+        [ drop f ]
+    } cond ;
+
+M: ##or rewrite
+    {
+        { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##or-imm f insn>imm-insn ] }
+        { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##or-imm t insn>imm-insn ] }
+        [ drop f ]
+    } cond ;
+
+M: ##xor rewrite
+    {
+        { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##xor-imm f insn>imm-insn ] }
+        { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##xor-imm t insn>imm-insn ] }
+        [ drop f ]
+    } cond ;
+
+M: ##shl rewrite
+    {
+        { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shl-imm f insn>imm-insn ] }
+        [ drop f ]
+    } cond ;
+
+M: ##shr rewrite
+    {
+        { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##shr-imm f insn>imm-insn ] }
+        [ drop f ]
+    } cond ;
+
+M: ##sar rewrite
+    {
+        { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##sar-imm f insn>imm-insn ] }
+        [ drop f ]
+    } cond ;
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 81f39d7da2..dc34f2dcd8 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -1,478 +1,9 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman, Daniel Ehrenberg.
+! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators combinators.short-circuit arrays
-fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise math.order classes
-vectors locals make alien.c-types io.binary grouping
-compiler.cfg
-compiler.cfg.registers
-compiler.cfg.comparisons
-compiler.cfg.instructions
-compiler.cfg.value-numbering.expressions
-compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.simplify ;
+USING: kernel compiler.cfg.instructions ;
 IN: compiler.cfg.value-numbering.rewrite
 
-: vreg-immediate-arithmetic? ( vreg -- ? )
-    vreg>expr {
-        [ constant-expr? ]
-        [ value>> fixnum? ]
-        [ value>> immediate-arithmetic? ]
-    } 1&& ;
-
-: vreg-immediate-bitwise? ( vreg -- ? )
-    vreg>expr {
-        [ constant-expr? ]
-        [ value>> fixnum? ]
-        [ value>> immediate-bitwise? ]
-    } 1&& ;
-
-: vreg-immediate-comparand? ( vreg -- ? )
-    vreg>expr {
-        [ constant-expr? ]
-        [ value>> immediate-comparand? ]
-    } 1&& ;
-
 ! Outputs f to mean no change
-
 GENERIC: rewrite ( insn -- insn/f )
 
 M: insn rewrite drop f ;
-
-: ##branch-t? ( insn -- ? )
-    dup ##compare-imm-branch? [
-        { [ cc>> cc/= eq? ] [ src2>> not ] } 1&&
-    ] [ drop f ] if ; inline
-
-: general-compare-expr? ( insn -- ? )
-    {
-        [ compare-expr? ]
-        [ compare-imm-expr? ]
-        [ compare-float-unordered-expr? ]
-        [ compare-float-ordered-expr? ]
-    } 1|| ;
-
-: general-or-vector-compare-expr? ( insn -- ? )
-    {
-        [ compare-expr? ]
-        [ compare-imm-expr? ]
-        [ compare-float-unordered-expr? ]
-        [ compare-float-ordered-expr? ]
-        [ test-vector-expr? ]
-    } 1|| ;
-
-: rewrite-boolean-comparison? ( insn -- ? )
-    dup ##branch-t? [
-        src1>> vreg>expr general-or-vector-compare-expr?
-    ] [ drop f ] if ; inline
- 
-: >compare-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
-
-: >compare-imm-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline
-
-: >test-vector-expr< ( expr -- src1 temp rep vcc )
-    {
-        [ src1>> vn>vreg ]
-        [ drop next-vreg ]
-        [ rep>> ]
-        [ vcc>> ]
-    } cleave ; inline
-
-: rewrite-boolean-comparison ( expr -- insn )
-    src1>> vreg>expr {
-        { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
-        { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
-        { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
-        { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] }
-        { [ dup test-vector-expr? ] [ >test-vector-expr< \ ##test-vector-branch new-insn ] }
-    } cond ;
-
-: tag-fixnum-expr? ( expr -- ? )
-    dup shl-imm-expr?
-    [ src2>> vn>constant tag-bits get = ] [ drop f ] if ;
-
-: rewrite-tagged-comparison? ( insn -- ? )
-    #! Are we comparing two tagged fixnums? Then untag them.
-    {
-        [ src1>> vreg>expr tag-fixnum-expr? ]
-        [ src2>> tag-mask get bitand 0 = ]
-    } 1&& ; inline
-
-: tagged>constant ( n -- n' )
-    tag-bits get neg shift ; inline
-
-: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
-    [ src1>> vreg>expr src1>> vn>vreg ]
-    [ src2>> tagged>constant ]
-    [ cc>> ]
-    tri ; inline
-
-GENERIC: rewrite-tagged-comparison ( insn -- insn/f )
-
-M: ##compare-imm-branch rewrite-tagged-comparison
-    (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
-
-M: ##compare-imm rewrite-tagged-comparison
-    [ dst>> ] [ (rewrite-tagged-comparison) ] bi
-    next-vreg \ ##compare-imm new-insn ;
-
-: rewrite-redundant-comparison? ( insn -- ? )
-    {
-        [ src1>> vreg>expr general-compare-expr? ]
-        [ src2>> not ]
-        [ cc>> { cc= cc/= } member? ]
-    } 1&& ; inline
-
-: rewrite-redundant-comparison ( insn -- insn' )
-    [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
-        { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
-        { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
-        { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
-        { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
-    } cond
-    swap cc= eq? [ [ negate-cc ] change-cc ] when ;
-
-: (fold-compare-imm) ( insn -- ? )
-    [ src1>> vreg>constant ] [ src2>> ] [ cc>> ] tri
-    2over [ integer? ] both? [ [ <=> ] dip evaluate-cc ] [
-        {
-            { cc= [ eq? ] }
-            { cc/= [ eq? not ] }
-        } case
-    ] if ;
-
-: fold-compare-imm? ( insn -- ? )
-    src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
-
-: fold-branch ( ? -- insn )
-    0 1 ?
-    basic-block get [ nth 1vector ] change-successors drop
-    \ ##branch new-insn ;
-
-: fold-compare-imm-branch ( insn -- insn/f )
-    (fold-compare-imm) fold-branch ;
-
-M: ##compare-imm-branch rewrite
-    {
-        { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
-        { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
-        { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
-        [ drop f ]
-    } cond ;
-
-: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
-    [ [ swap ] dip swap-cc ] when ; inline
-
-: >compare-imm-branch ( insn swap? -- insn' )
-    [
-        [ src1>> ]
-        [ src2>> ]
-        [ cc>> ]
-        tri
-    ] dip
-    swap-compare
-    [ vreg>constant ] dip
-    \ ##compare-imm-branch new-insn ; inline
-
-: self-compare? ( insn -- ? )
-    [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
-
-: (rewrite-self-compare) ( insn -- ? )
-    cc>> { cc= cc<= cc>= } member-eq? ;
-
-: rewrite-self-compare-branch ( insn -- insn' )
-    (rewrite-self-compare) fold-branch ;
-
-M: ##compare-branch rewrite
-    {
-        { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm-branch ] }
-        { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm-branch ] }
-        { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
-        [ drop f ]
-    } cond ;
-
-: >compare-imm ( insn swap? -- insn' )
-    [
-        {
-            [ dst>> ]
-            [ src1>> ]
-            [ src2>> ]
-            [ cc>> ]
-        } cleave
-    ] dip
-    swap-compare
-    [ vreg>constant ] dip
-    next-vreg \ ##compare-imm new-insn ; inline
-
-: >boolean-insn ( insn ? -- insn' )
-    [ dst>> ] dip \ ##load-constant new-insn ;
-
-: rewrite-self-compare ( insn -- insn' )
-    dup (rewrite-self-compare) >boolean-insn ;
-
-M: ##compare rewrite
-    {
-        { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm ] }
-        { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm ] }
-        { [ dup self-compare? ] [ rewrite-self-compare ] }
-        [ drop f ]
-    } cond ;
-
-: fold-compare-imm ( insn -- insn' )
-    dup (fold-compare-imm) >boolean-insn ;
-
-M: ##compare-imm rewrite
-    {
-        { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
-        { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
-        { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
-        [ drop f ]
-    } cond ;
-
-: constant-fold? ( insn -- ? )
-    src1>> vreg>expr constant-expr? ; inline
-
-GENERIC: constant-fold* ( x y insn -- z )
-
-M: ##add-imm constant-fold* drop + ;
-M: ##sub-imm constant-fold* drop - ;
-M: ##mul-imm constant-fold* drop * ;
-M: ##and-imm constant-fold* drop bitand ;
-M: ##or-imm constant-fold* drop bitor ;
-M: ##xor-imm constant-fold* drop bitxor ;
-M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
-M: ##sar-imm constant-fold* drop neg shift ;
-M: ##shl-imm constant-fold* drop shift ;
-
-: constant-fold ( insn -- insn' )
-    [ dst>> ]
-    [
-        [ src1>> vreg>constant \ f type-number or ]
-        [ src2>> ]
-        [ ]
-        tri constant-fold*
-    ] bi
-    \ ##load-immediate new-insn ; inline
-
-: unary-constant-fold? ( insn -- ? )
-    src>> vreg>expr constant-expr? ; inline
-
-GENERIC: unary-constant-fold* ( x insn -- y )
-
-M: ##not unary-constant-fold* drop bitnot ;
-M: ##neg unary-constant-fold* drop neg ;
-
-: unary-constant-fold ( insn -- insn' )
-    [ dst>> ]
-    [ [ src>> vreg>constant ] [ ] bi unary-constant-fold* ] bi
-    \ ##load-immediate new-insn ; inline
-
-: maybe-unary-constant-fold ( insn -- insn' )
-    dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ;
-
-M: ##neg rewrite
-    maybe-unary-constant-fold ;
-
-M: ##not rewrite
-    maybe-unary-constant-fold ;
-
-: arithmetic-op? ( op -- ? )
-    {
-        ##add
-        ##add-imm
-        ##sub
-        ##sub-imm
-        ##mul
-        ##mul-imm
-    } member-eq? ;
-
-: immediate? ( value op -- ? )
-    arithmetic-op? [ immediate-arithmetic? ] [ immediate-bitwise? ] if ;
-
-: reassociate ( insn op -- insn )
-    [
-        {
-            [ dst>> ]
-            [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>constant ] bi ]
-            [ src2>> ]
-            [ ]
-        } cleave constant-fold*
-    ] dip
-    2dup immediate? [ new-insn ] [ 2drop 2drop f ] if ; inline
-
-M: ##add-imm rewrite
-    {
-        { [ dup constant-fold? ] [ constant-fold ] }
-        { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate ] }
-        [ drop f ]
-    } cond ;
-
-: sub-imm>add-imm ( insn -- insn' )
-    [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup immediate-arithmetic?
-    [ \ ##add-imm new-insn ] [ 3drop f ] if ;
-
-M: ##sub-imm rewrite
-    {
-        { [ dup constant-fold? ] [ constant-fold ] }
-        [ sub-imm>add-imm ]
-    } cond ;
-
-: mul-to-neg? ( insn -- ? )
-    src2>> -1 = ;
-
-: mul-to-neg ( insn -- insn' )
-    [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
-
-: mul-to-shl? ( insn -- ? )
-    src2>> power-of-2? ;
-
-: mul-to-shl ( insn -- insn' )
-    [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
-
-M: ##mul-imm rewrite
-    {
-        { [ dup constant-fold? ] [ constant-fold ] }
-        { [ dup mul-to-neg? ] [ mul-to-neg ] }
-        { [ dup mul-to-shl? ] [ mul-to-shl ] }
-        { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] }
-        [ drop f ]
-    } cond ;
-
-M: ##and-imm rewrite
-    {
-        { [ dup constant-fold? ] [ constant-fold ] }
-        { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate ] }
-        [ drop f ]
-    } cond ;
-
-M: ##or-imm rewrite
-    {
-        { [ dup constant-fold? ] [ constant-fold ] }
-        { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate ] }
-        [ drop f ]
-    } cond ;
-
-M: ##xor-imm rewrite
-    {
-        { [ dup constant-fold? ] [ constant-fold ] }
-        { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate ] }
-        [ drop f ]
-    } cond ;
-
-M: ##shl-imm rewrite
-    {
-        { [ dup constant-fold? ] [ constant-fold ] }
-        [ drop f ]
-    } cond ;
-
-M: ##shr-imm rewrite
-    {
-        { [ dup constant-fold? ] [ constant-fold ] }
-        [ drop f ]
-    } cond ;
-
-M: ##sar-imm rewrite
-    {
-        { [ dup constant-fold? ] [ constant-fold ] }
-        [ drop f ]
-    } cond ;
-
-: insn>imm-insn ( insn op swap? -- new-insn )
-    swap [
-        [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
-        [ swap ] when vreg>constant
-    ] dip new-insn ; inline
-
-: vreg-immediate? ( vreg op -- ? )
-    arithmetic-op?
-    [ vreg-immediate-arithmetic? ] [ vreg-immediate-bitwise? ] if ;
-
-: rewrite-arithmetic ( insn op -- insn/f )
-    {
-        { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
-        [ 2drop f ]
-    } cond ; inline
-
-: rewrite-arithmetic-commutative ( insn op -- insn/f )
-    {
-        { [ over src2>> over vreg-immediate? ] [ f insn>imm-insn ] }
-        { [ over src1>> over vreg-immediate? ] [ t insn>imm-insn ] }
-        [ 2drop f ]
-    } cond ; inline
-
-M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ;
-
-: subtraction-identity? ( insn -- ? )
-    [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq?  ;
-
-: rewrite-subtraction-identity ( insn -- insn' )
-    dst>> 0 \ ##load-immediate new-insn ;
-
-: sub-to-neg? ( ##sub -- ? )
-    src1>> vn>expr expr-zero? ;
-
-: sub-to-neg ( ##sub -- insn )
-    [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
-
-M: ##sub rewrite
-    {
-        { [ dup sub-to-neg? ] [ sub-to-neg ] }
-        { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
-        [ \ ##sub-imm rewrite-arithmetic ]
-    } cond ;
-
-M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ;
-
-M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ;
-
-M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ;
-
-M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ;
-
-M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ;
-
-M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
-
-M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
-
-! ##box-displaced-alien f 1 2 3 <class>
-! ##unbox-c-ptr 4 1 <class>
-! =>
-! ##box-displaced-alien f 1 2 3 <class>
-! ##unbox-c-ptr 5 3 <class>
-! ##add 4 5 2
-
-:: rewrite-unbox-displaced-alien ( insn expr -- insns )
-    [
-        next-vreg :> temp
-        temp expr base>> vn>vreg expr base-class>> ##unbox-c-ptr
-        insn dst>> temp expr displacement>> vn>vreg ##add
-    ] { } make ;
-
-M: ##unbox-any-c-ptr rewrite
-    dup src>> vreg>expr dup box-displaced-alien-expr?
-    [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
-
-! More efficient addressing for alien intrinsics
-: rewrite-alien-addressing ( insn -- insn' )
-    dup src>> vreg>expr dup add-imm-expr? [
-        [ src1>> vn>vreg ] [ src2>> vn>constant ] bi
-        [ >>src ] [ '[ _ + ] change-offset ] bi*
-    ] [ 2drop f ] if ;
-
-M: ##alien-unsigned-1 rewrite rewrite-alien-addressing ;
-M: ##alien-unsigned-2 rewrite rewrite-alien-addressing ;
-M: ##alien-unsigned-4 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-1 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-2 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
-M: ##alien-float rewrite rewrite-alien-addressing ;
-M: ##alien-double rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
-M: ##set-alien-float rewrite rewrite-alien-addressing ;
-M: ##set-alien-double rewrite rewrite-alien-addressing ;
-
diff --git a/basis/compiler/cfg/value-numbering/simd/simd.factor b/basis/compiler/cfg/value-numbering/simd/simd.factor
index 16d38bc5bb..4c4b422187 100644
--- a/basis/compiler/cfg/value-numbering/simd/simd.factor
+++ b/basis/compiler/cfg/value-numbering/simd/simd.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.short-circuit arrays
 fry kernel layouts math namespaces sequences cpu.architecture
@@ -9,6 +9,7 @@ compiler.cfg
 compiler.cfg.registers
 compiler.cfg.comparisons
 compiler.cfg.instructions
+compiler.cfg.value-numbering.alien
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.rewrite
@@ -34,19 +35,18 @@ M: ##set-alien-vector rewrite rewrite-alien-addressing ;
 
 : fold-shuffle-vector-imm ( insn expr -- insn' )
     [ [ dst>> ] [ shuffle>> ] bi ] dip value>>
-    (fold-shuffle-vector-imm) \ ##load-constant new-insn ;
+    (fold-shuffle-vector-imm) \ ##load-reference new-insn ;
 
 M: ##shuffle-vector-imm rewrite
     dup src>> vreg>expr {
         { [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] }
         { [ dup reference-expr? ] [ fold-shuffle-vector-imm ] }
-        { [ dup constant-expr? ] [ fold-shuffle-vector-imm ] }
         [ 2drop f ]
     } cond ;
 
 : (fold-scalar>vector) ( insn bytes -- insn' )
     [ [ dst>> ] [ rep>> rep-length ] bi ] dip <repetition> concat
-    \ ##load-constant new-insn ;
+    \ ##load-reference new-insn ;
 
 : fold-scalar>vector ( insn expr -- insn' )
     value>> over rep>> {
@@ -56,7 +56,7 @@ M: ##shuffle-vector-imm rewrite
     } case ;
 
 M: ##scalar>vector rewrite
-    dup src>> vreg>expr dup constant-expr?
+    dup src>> vreg>expr dup reference-expr?
     [ fold-scalar>vector ] [ 2drop f ] if ;
 
 M: ##xor-vector rewrite
@@ -117,4 +117,3 @@ M: scalar>vector-expr simplify*
 M: shuffle-vector-imm-expr simplify*
     [ src>> ] [ shuffle>> ] [ rep>> rep-length iota ] tri
     sequence= [ drop f ] unless ;
-
diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
index 7a95711b01..67203a9ca7 100644
--- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor
+++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors combinators classes math layouts
 sequences 
@@ -19,11 +19,9 @@ M: unbox-alien-expr simplify* simplify-unbox-alien ;
 
 M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ;
 
-: expr-zero? ( expr -- ? ) T{ constant-expr f 0 } = ; inline
-
-: expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline
-
-: expr-neg-one? ( expr -- ? ) T{ constant-expr f -1 } = ; inline
+: expr-zero? ( expr -- ? ) T{ integer-expr f 0 } = ; inline
+: expr-one? ( expr -- ? ) T{ integer-expr f 1 } = ; inline
+: expr-neg-one? ( expr -- ? ) T{ integer-expr f -1 } = ; inline
 
 : >unary-expr< ( expr -- in ) src>> vn>expr ; inline
 
@@ -101,13 +99,8 @@ M: or-imm-expr simplify* simplify-or ;
 M: xor-expr simplify* simplify-xor ;
 M: xor-imm-expr simplify* simplify-xor ;
 
-: useless-shr? ( in1 in2 -- ? )
-    over shl-imm-expr?
-    [ [ src2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
-
 : simplify-shr ( expr -- vn/expr/f )
     >binary-expr< {
-        { [ 2dup useless-shr? ] [ drop src1>> ] }
         { [ dup expr-zero? ] [ drop ] }
         [ 2drop f ]
     } cond ; inline
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index f835200702..6b6f49d1c5 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -23,15 +23,15 @@ IN: compiler.cfg.value-numbering.tests
 ! Folding constants together
 [
     {
-        T{ ##load-constant f 0 0.0 }
-        T{ ##load-constant f 1 -0.0 }
+        T{ ##load-reference f 0 0.0 }
+        T{ ##load-reference f 1 -0.0 }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     }
 ] [
     {
-        T{ ##load-constant f 0 0.0 }
-        T{ ##load-constant f 1 -0.0 }
+        T{ ##load-reference f 0 0.0 }
+        T{ ##load-reference f 1 -0.0 }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     } value-numbering-step
@@ -39,15 +39,15 @@ IN: compiler.cfg.value-numbering.tests
 
 [
     {
-        T{ ##load-constant f 0 0.0 }
+        T{ ##load-reference f 0 0.0 }
         T{ ##copy f 1 0 any-rep }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     }
 ] [
     {
-        T{ ##load-constant f 0 0.0 }
-        T{ ##load-constant f 1 0.0 }
+        T{ ##load-reference f 0 0.0 }
+        T{ ##load-reference f 1 0.0 }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     } value-numbering-step
@@ -55,24 +55,24 @@ IN: compiler.cfg.value-numbering.tests
 
 [
     {
-        T{ ##load-constant f 0 t }
+        T{ ##load-reference f 0 t }
         T{ ##copy f 1 0 any-rep }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     }
 ] [
     {
-        T{ ##load-constant f 0 t }
-        T{ ##load-constant f 1 t }
+        T{ ##load-reference f 0 t }
+        T{ ##load-reference f 1 t }
         T{ ##replace f 0 D 0 }
         T{ ##replace f 1 D 1 }
     } value-numbering-step
 ] unit-test
 
-! Compare propagation
+! Double compare elimination
 [
     {
-        T{ ##load-reference f 1 + }
+        T{ ##load-reference f 1 "hi" }
         T{ ##peek f 2 D 0 }
         T{ ##compare f 4 2 1 cc> }
         T{ ##copy f 6 4 any-rep }
@@ -80,7 +80,7 @@ IN: compiler.cfg.value-numbering.tests
     }
 ] [
     {
-        T{ ##load-reference f 1 + }
+        T{ ##load-reference f 1 "hi" }
         T{ ##peek f 2 D 0 }
         T{ ##compare f 4 2 1 cc> }
         T{ ##compare-imm f 6 4 f cc/= }
@@ -90,7 +90,7 @@ IN: compiler.cfg.value-numbering.tests
 
 [
     {
-        T{ ##load-reference f 1 + }
+        T{ ##load-reference f 1 "hi" }
         T{ ##peek f 2 D 0 }
         T{ ##compare f 4 2 1 cc<= }
         T{ ##compare f 6 2 1 cc/<= }
@@ -98,7 +98,7 @@ IN: compiler.cfg.value-numbering.tests
     }
 ] [
     {
-        T{ ##load-reference f 1 + }
+        T{ ##load-reference f 1 "hi" }
         T{ ##peek f 2 D 0 }
         T{ ##compare f 4 2 1 cc<= }
         T{ ##compare-imm f 6 4 f cc= }
@@ -154,17 +154,17 @@ IN: compiler.cfg.value-numbering.tests
     } value-numbering-step trim-temps
 ] unit-test
 
-! Immediate operand conversion
+! Immediate operand fusion
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add-imm f 2 0 100 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add f 2 0 1 }
     } value-numbering-step
 ] unit-test
@@ -172,13 +172,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add-imm f 2 0 100 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add f 2 1 0 }
     } value-numbering-step
 ] unit-test
@@ -186,13 +186,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add-imm f 2 0 -100 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##sub f 2 0 1 }
     } value-numbering-step
 ] unit-test
@@ -200,7 +200,7 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 0 }
+        T{ ##load-integer f 1 0 }
     }
 ] [
     {
@@ -212,13 +212,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##mul-imm f 2 0 100 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##mul f 2 0 1 }
     } value-numbering-step
 ] unit-test
@@ -226,13 +226,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##mul-imm f 2 0 100 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##mul f 2 1 0 }
     } value-numbering-step
 ] unit-test
@@ -252,13 +252,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 -1 }
+        T{ ##load-integer f 1 -1 }
         T{ ##neg f 2 0 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 -1 }
+        T{ ##load-integer f 1 -1 }
         T{ ##mul f 2 0 1 }
     } value-numbering-step
 ] unit-test
@@ -266,13 +266,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 -1 }
+        T{ ##load-integer f 1 -1 }
         T{ ##neg f 2 0 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 -1 }
+        T{ ##load-integer f 1 -1 }
         T{ ##mul f 2 1 0 }
     } value-numbering-step
 ] unit-test
@@ -280,13 +280,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 0 }
+        T{ ##load-integer f 1 0 }
         T{ ##neg f 2 0 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 0 }
+        T{ ##load-integer f 1 0 }
         T{ ##sub f 2 1 0 }
     } value-numbering-step
 ] unit-test
@@ -294,14 +294,14 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 0 }
+        T{ ##load-integer f 1 0 }
         T{ ##neg f 2 0 }
         T{ ##copy f 3 0 any-rep }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 0 }
+        T{ ##load-integer f 1 0 }
         T{ ##sub f 2 1 0 }
         T{ ##sub f 3 1 2 }
     } value-numbering-step
@@ -324,13 +324,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##and-imm f 2 0 100 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##and f 2 0 1 }
     } value-numbering-step
 ] unit-test
@@ -338,13 +338,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##and-imm f 2 0 100 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##and f 2 1 0 }
     } value-numbering-step
 ] unit-test
@@ -352,13 +352,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##or-imm f 2 0 100 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##or f 2 0 1 }
     } value-numbering-step
 ] unit-test
@@ -366,13 +366,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##or-imm f 2 0 100 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##or f 2 1 0 }
     } value-numbering-step
 ] unit-test
@@ -380,13 +380,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##xor-imm f 2 0 100 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##xor f 2 0 1 }
     } value-numbering-step
 ] unit-test
@@ -394,13 +394,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##xor-imm f 2 0 100 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##xor f 2 1 0 }
     } value-numbering-step
 ] unit-test
@@ -408,13 +408,13 @@ IN: compiler.cfg.value-numbering.tests
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##compare-imm f 2 0 100 cc<= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##compare f 2 0 1 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
@@ -423,13 +423,13 @@ cpu x86.32? [
     [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-constant f 1 + }
+            T{ ##load-reference f 1 + }
             T{ ##compare-imm f 2 0 + cc= }
         }
     ] [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-constant f 1 + }
+            T{ ##load-reference f 1 + }
             T{ ##compare f 2 0 1 cc= }
         } value-numbering-step trim-temps
     ] unit-test
@@ -437,13 +437,13 @@ cpu x86.32? [
     [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-constant f 1 + }
+            T{ ##load-reference f 1 + }
             T{ ##compare-imm-branch f 0 + cc= }
         }
     ] [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-constant f 1 + }
+            T{ ##load-reference f 1 + }
             T{ ##compare-branch f 0 1 cc= }
         } value-numbering-step trim-temps
     ] unit-test
@@ -452,13 +452,13 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 3.5 }
+        T{ ##load-reference f 1 3.5 }
         T{ ##compare f 2 0 1 cc= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 3.5 }
+        T{ ##load-reference f 1 3.5 }
         T{ ##compare f 2 0 1 cc= }
     } value-numbering-step trim-temps
 ] unit-test
@@ -466,13 +466,13 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 3.5 }
+        T{ ##load-reference f 1 3.5 }
         T{ ##compare-branch f 0 1 cc= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 3.5 }
+        T{ ##load-reference f 1 3.5 }
         T{ ##compare-branch f 0 1 cc= }
     } value-numbering-step trim-temps
 ] unit-test
@@ -480,13 +480,13 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##compare-imm f 2 0 100 cc>= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##compare f 2 1 0 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
@@ -494,13 +494,13 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##compare-imm-branch f 0 100 cc<= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##compare-branch f 0 1 cc<= }
     } value-numbering-step
 ] unit-test
@@ -508,85 +508,213 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##compare-imm-branch f 0 100 cc>= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##compare-branch f 1 0 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
 
-! Branch folding
+! Compare folding
 [
     {
-        T{ ##load-immediate f 1 100 }
-        T{ ##load-immediate f 2 200 }
-        T{ ##load-constant f 3 t }
+        T{ ##load-integer f 1 100 }
+        T{ ##load-integer f 2 200 }
+        T{ ##load-reference f 3 t }
     }
 ] [
     {
-        T{ ##load-immediate f 1 100 }
-        T{ ##load-immediate f 2 200 }
+        T{ ##load-integer f 1 100 }
+        T{ ##load-integer f 2 200 }
         T{ ##compare f 3 1 2 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
 
 [
     {
-        T{ ##load-immediate f 1 100 }
-        T{ ##load-immediate f 2 200 }
-        T{ ##load-constant f 3 f }
+        T{ ##load-integer f 1 100 }
+        T{ ##load-integer f 2 200 }
+        T{ ##load-reference f 3 f }
     }
 ] [
     {
-        T{ ##load-immediate f 1 100 }
-        T{ ##load-immediate f 2 200 }
+        T{ ##load-integer f 1 100 }
+        T{ ##load-integer f 2 200 }
         T{ ##compare f 3 1 2 cc= }
     } value-numbering-step trim-temps
 ] unit-test
 
 [
     {
-        T{ ##load-immediate f 1 100 }
-        T{ ##load-constant f 2 f }
+        T{ ##load-integer f 1 100 }
+        T{ ##load-reference f 2 f }
     }
 ] [
     {
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##compare-imm f 2 1 f cc= }
     } value-numbering-step trim-temps
 ] unit-test
 
 [
     {
-        T{ ##load-constant f 1 f }
-        T{ ##load-constant f 2 t }
+        T{ ##load-reference f 1 f }
+        T{ ##load-reference f 2 t }
     }
 ] [
     {
-        T{ ##load-constant f 1 f }
+        T{ ##load-reference f 1 f }
         T{ ##compare-imm f 2 1 f cc= }
     } value-numbering-step trim-temps
 ] unit-test
 
+[
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##load-reference f 3 f }
+    }
+] [
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##compare f 3 1 2 cc= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##load-reference f 3 t }
+    }
+] [
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##compare f 3 1 2 cc/= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##load-reference f 3 t }
+    }
+] [
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##compare f 3 1 2 cc< }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##load-reference f 3 f }
+    }
+] [
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##compare f 3 2 1 cc< }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 f }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare f 1 0 0 cc< }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 t }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare f 1 0 0 cc<= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 f }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare f 1 0 0 cc> }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 t }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare f 1 0 0 cc>= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 f }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare f 1 0 0 cc/= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 t }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare f 1 0 0 cc= }
+    } value-numbering-step
+] unit-test
+
 ! Reassociation
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add-imm f 2 0 100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##add-imm f 4 0 150 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add f 2 0 1 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##add f 4 2 3 }
     } value-numbering-step
 ] unit-test
@@ -594,17 +722,17 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add-imm f 2 0 100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##add-imm f 4 0 150 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add f 2 1 0 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##add f 4 3 2 }
     } value-numbering-step
 ] unit-test
@@ -612,17 +740,17 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add-imm f 2 0 100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##add-imm f 4 0 50 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add f 2 0 1 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##sub f 4 2 3 }
     } value-numbering-step
 ] unit-test
@@ -630,17 +758,17 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##add-imm f 2 0 -100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##add-imm f 4 0 -150 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##sub f 2 0 1 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##sub f 4 2 3 }
     } value-numbering-step
 ] unit-test
@@ -648,17 +776,17 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##mul-imm f 2 0 100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##mul-imm f 4 0 5000 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##mul f 2 0 1 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##mul f 4 2 3 }
     } value-numbering-step
 ] unit-test
@@ -666,17 +794,17 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##mul-imm f 2 0 100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##mul-imm f 4 0 5000 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##mul f 2 1 0 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##mul f 4 3 2 }
     } value-numbering-step
 ] unit-test
@@ -684,17 +812,17 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##and-imm f 2 0 100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##and-imm f 4 0 32 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##and f 2 0 1 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##and f 4 2 3 }
     } value-numbering-step
 ] unit-test
@@ -702,17 +830,17 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##and-imm f 2 0 100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##and-imm f 4 0 32 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##and f 2 1 0 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##and f 4 3 2 }
     } value-numbering-step
 ] unit-test
@@ -720,17 +848,17 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##or-imm f 2 0 100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##or-imm f 4 0 118 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##or f 2 0 1 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##or f 4 2 3 }
     } value-numbering-step
 ] unit-test
@@ -738,17 +866,17 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##or-imm f 2 0 100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##or-imm f 4 0 118 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##or f 2 1 0 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##or f 4 3 2 }
     } value-numbering-step
 ] unit-test
@@ -756,17 +884,17 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##xor-imm f 2 0 100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##xor-imm f 4 0 86 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##xor f 2 0 1 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##xor f 4 2 3 }
     } value-numbering-step
 ] unit-test
@@ -774,17 +902,17 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##xor-imm f 2 0 100 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##xor-imm f 4 0 86 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 100 }
+        T{ ##load-integer f 1 100 }
         T{ ##xor f 2 1 0 }
-        T{ ##load-immediate f 3 50 }
+        T{ ##load-integer f 3 50 }
         T{ ##xor f 4 3 2 }
     } value-numbering-step
 ] unit-test
@@ -794,7 +922,7 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
-        T{ ##load-immediate f 2 0 }
+        T{ ##load-integer f 2 0 }
         T{ ##copy f 3 0 any-rep }
         T{ ##replace f 3 D 0 }
     }
@@ -812,7 +940,7 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
-        T{ ##load-immediate f 2 0 }
+        T{ ##load-integer f 2 0 }
         T{ ##copy f 3 0 any-rep }
         T{ ##replace f 3 D 0 }
     }
@@ -830,7 +958,7 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
-        T{ ##load-immediate f 2 0 }
+        T{ ##load-integer f 2 0 }
         T{ ##copy f 3 0 any-rep }
         T{ ##replace f 3 D 0 }
     }
@@ -848,7 +976,7 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
-        T{ ##load-immediate f 2 0 }
+        T{ ##load-integer f 2 0 }
         T{ ##copy f 3 0 any-rep }
         T{ ##replace f 3 D 0 }
     }
@@ -865,14 +993,14 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
+        T{ ##load-integer f 1 1 }
         T{ ##copy f 2 0 any-rep }
         T{ ##replace f 2 D 0 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
+        T{ ##load-integer f 1 1 }
         T{ ##mul f 2 0 1 }
         T{ ##replace f 2 D 0 }
     } value-numbering-step
@@ -882,15 +1010,15 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 3 }
-        T{ ##load-immediate f 3 4 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 3 }
+        T{ ##load-integer f 3 4 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 3 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 3 }
         T{ ##add f 3 1 2 }
     } value-numbering-step
 ] unit-test
@@ -898,15 +1026,15 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 3 }
-        T{ ##load-immediate f 3 -2 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 3 }
+        T{ ##load-integer f 3 -2 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 3 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 3 }
         T{ ##sub f 3 1 2 }
     } value-numbering-step
 ] unit-test
@@ -914,15 +1042,15 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 2 }
-        T{ ##load-immediate f 2 3 }
-        T{ ##load-immediate f 3 6 }
+        T{ ##load-integer f 1 2 }
+        T{ ##load-integer f 2 3 }
+        T{ ##load-integer f 3 6 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 2 }
-        T{ ##load-immediate f 2 3 }
+        T{ ##load-integer f 1 2 }
+        T{ ##load-integer f 2 3 }
         T{ ##mul f 3 1 2 }
     } value-numbering-step
 ] unit-test
@@ -930,15 +1058,15 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 2 }
-        T{ ##load-immediate f 2 1 }
-        T{ ##load-immediate f 3 0 }
+        T{ ##load-integer f 1 2 }
+        T{ ##load-integer f 2 1 }
+        T{ ##load-integer f 3 0 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 2 }
-        T{ ##load-immediate f 2 1 }
+        T{ ##load-integer f 1 2 }
+        T{ ##load-integer f 2 1 }
         T{ ##and f 3 1 2 }
     } value-numbering-step
 ] unit-test
@@ -946,15 +1074,15 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 2 }
-        T{ ##load-immediate f 2 1 }
-        T{ ##load-immediate f 3 3 }
+        T{ ##load-integer f 1 2 }
+        T{ ##load-integer f 2 1 }
+        T{ ##load-integer f 3 3 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 2 }
-        T{ ##load-immediate f 2 1 }
+        T{ ##load-integer f 1 2 }
+        T{ ##load-integer f 2 1 }
         T{ ##or f 3 1 2 }
     } value-numbering-step
 ] unit-test
@@ -962,15 +1090,15 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 2 }
-        T{ ##load-immediate f 2 3 }
-        T{ ##load-immediate f 3 1 }
+        T{ ##load-integer f 1 2 }
+        T{ ##load-integer f 2 3 }
+        T{ ##load-integer f 3 1 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 2 }
-        T{ ##load-immediate f 2 3 }
+        T{ ##load-integer f 1 2 }
+        T{ ##load-integer f 2 3 }
         T{ ##xor f 3 1 2 }
     } value-numbering-step
 ] unit-test
@@ -978,13 +1106,13 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 3 8 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 3 8 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
+        T{ ##load-integer f 1 1 }
         T{ ##shl-imm f 3 1 3 }
     } value-numbering-step
 ] unit-test
@@ -993,13 +1121,13 @@ cell 8 = [
     [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-immediate f 1 -1 }
-            T{ ##load-immediate f 3 HEX: ffffffffffff }
+            T{ ##load-integer f 1 -1 }
+            T{ ##load-integer f 3 HEX: ffffffffffff }
         }
     ] [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-immediate f 1 -1 }
+            T{ ##load-integer f 1 -1 }
             T{ ##shr-imm f 3 1 16 }
         } value-numbering-step
     ] unit-test
@@ -1008,13 +1136,13 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 -8 }
-        T{ ##load-immediate f 3 -4 }
+        T{ ##load-integer f 1 -8 }
+        T{ ##load-integer f 3 -4 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 -8 }
+        T{ ##load-integer f 1 -8 }
         T{ ##sar-imm f 3 1 1 }
     } value-numbering-step
 ] unit-test
@@ -1023,14 +1151,14 @@ cell 8 = [
     [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-immediate f 1 65536 }
-            T{ ##load-immediate f 2 140737488355328 }
+            T{ ##load-integer f 1 65536 }
+            T{ ##load-integer f 2 140737488355328 }
             T{ ##add f 3 0 2 }
         }
     ] [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-immediate f 1 65536 }
+            T{ ##load-integer f 1 65536 }
             T{ ##shl-imm f 2 1 31 }
             T{ ##add f 3 0 2 }
         } value-numbering-step
@@ -1039,13 +1167,13 @@ cell 8 = [
     [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-immediate f 2 140737488355328 }
+            T{ ##load-integer f 2 140737488355328 }
             T{ ##add f 3 0 2 }
         }
     ] [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-immediate f 2 140737488355328 }
+            T{ ##load-integer f 2 140737488355328 }
             T{ ##add f 3 0 2 }
         } value-numbering-step
     ] unit-test
@@ -1053,14 +1181,14 @@ cell 8 = [
     [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-immediate f 2 2147483647 }
+            T{ ##load-integer f 2 2147483647 }
             T{ ##add-imm f 3 0 2147483647 }
             T{ ##add-imm f 4 3 2147483647 }
         }
     ] [
         {
             T{ ##peek f 0 D 0 }
-            T{ ##load-immediate f 2 2147483647 }
+            T{ ##load-integer f 2 2147483647 }
             T{ ##add f 3 0 2 }
             T{ ##add f 4 3 2 }
         } value-numbering-step
@@ -1070,13 +1198,13 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 -1 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 -1 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
+        T{ ##load-integer f 1 1 }
         T{ ##neg f 2 1 }
     } value-numbering-step
 ] unit-test
@@ -1084,27 +1212,43 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 -2 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 -2 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 1 1 }
+        T{ ##load-integer f 1 1 }
         T{ ##not f 2 1 }
     } value-numbering-step
 ] unit-test
 
-! Stupid constant folding corner case
+! ##tagged>integer constant folding
 [
     {
-        T{ ##load-constant f 1 f }
-        T{ ##load-immediate f 2 $[ \ f type-number ] }
+        T{ ##load-reference f 1 f }
+        T{ ##load-integer f 2 $[ \ f type-number ] }
+        T{ ##copy f 3 2 any-rep }
     }
 ] [
     {
-        T{ ##load-constant f 1 f }
-        T{ ##and-imm f 2 1 15 }
+        T{ ##load-reference f 1 f }
+        T{ ##load-integer f 2 1 }
+        T{ ##and-imm f 3 2 15 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 100 }
+        T{ ##load-integer f 2 $[ 100 tag-fixnum ] }
+        T{ ##load-integer f 3 $[ 100 tag-fixnum 1 + ] }
+    }
+] [
+    {
+        T{ ##load-integer f 1 100 }
+        T{ ##tagged>integer f 2 1 }
+        T{ ##add-imm f 3 2 1 }
     } value-numbering-step
 ] unit-test
 
@@ -1114,7 +1258,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 2 16 }
+        T{ ##load-integer f 2 16 }
         T{ ##box-displaced-alien f 1 2 0 c-ptr }
         T{ ##unbox-any-c-ptr f 4 0 }
         T{ ##add-imm f 3 4 16 }
@@ -1122,7 +1266,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 2 16 }
+        T{ ##load-integer f 2 16 }
         T{ ##box-displaced-alien f 1 2 0 c-ptr }
         T{ ##unbox-any-c-ptr f 3 1 }
     } value-numbering-step
@@ -1133,7 +1277,7 @@ cell 8 = [
 [
     {
         T{ ##box-alien f 0 1 }
-        T{ ##load-immediate f 2 16 }
+        T{ ##load-integer f 2 16 }
         T{ ##box-displaced-alien f 3 2 0 c-ptr }
         T{ ##copy f 5 1 any-rep }
         T{ ##add-imm f 4 5 16 }
@@ -1141,7 +1285,7 @@ cell 8 = [
 ] [
     {
         T{ ##box-alien f 0 1 }
-        T{ ##load-immediate f 2 16 }
+        T{ ##load-integer f 2 16 }
         T{ ##box-displaced-alien f 3 2 0 c-ptr }
         T{ ##unbox-any-c-ptr f 4 3 }
     } value-numbering-step
@@ -1152,148 +1296,19 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 2 0 }
+        T{ ##load-integer f 2 0 }
         T{ ##copy f 3 0 any-rep }
         T{ ##replace f 3 D 1 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-immediate f 2 0 }
+        T{ ##load-integer f 2 0 }
         T{ ##box-displaced-alien f 3 2 0 c-ptr }
         T{ ##replace f 3 D 1 }
     } value-numbering-step
 ] unit-test
 
-! Branch folding
-[
-    {
-        T{ ##load-immediate f 1 10 }
-        T{ ##load-immediate f 2 20 }
-        T{ ##load-constant f 3 f }
-    }
-] [
-    {
-        T{ ##load-immediate f 1 10 }
-        T{ ##load-immediate f 2 20 }
-        T{ ##compare f 3 1 2 cc= }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
-        T{ ##load-constant f 3 t }
-    }
-] [
-    {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
-        T{ ##compare f 3 1 2 cc/= }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
-        T{ ##load-constant f 3 t }
-    }
-] [
-    {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
-        T{ ##compare f 3 1 2 cc< }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##load-immediate f 1 10 }
-        T{ ##load-immediate f 2 20 }
-        T{ ##load-constant f 3 f }
-    }
-] [
-    {
-        T{ ##load-immediate f 1 10 }
-        T{ ##load-immediate f 2 20 }
-        T{ ##compare f 3 2 1 cc< }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 f }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc< }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 t }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc<= }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 f }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc> }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 t }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc>= }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 f }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc/= }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 t }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc= }
-    } value-numbering-step
-] unit-test
-
 [
     {
         T{ ##vector>scalar f 1 0 float-4-rep }
@@ -1342,13 +1357,13 @@ cell 8 = [
 
 [
     {
-        T{ ##load-constant f 0 $[ 55 tag-fixnum ] }
-        T{ ##load-constant f 1 B{ 55 0 0 0  55 0 0 0  55 0 0 0  55 0 0 0 } }
-        T{ ##copy f 2 1 any-rep }
+        T{ ##load-reference f 0 $[ 55 tag-fixnum ] }
+        T{ ##load-reference f 1 B{ 55 0 0 0  55 0 0 0  55 0 0 0  55 0 0 0 } }
+        T{ ##load-reference f 2 B{ 55 0 0 0  55 0 0 0  55 0 0 0  55 0 0 0 } }
     }
 ] [
     {
-        T{ ##load-constant f 0 $[ 55 tag-fixnum ] }
+        T{ ##load-reference f 0 $[ 55 tag-fixnum ] }
         T{ ##scalar>vector f 1 0 int-4-rep }
         T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep }
     } value-numbering-step
@@ -1356,13 +1371,13 @@ cell 8 = [
 
 [
     {
-        T{ ##load-constant f 0 1.25 }
-        T{ ##load-constant f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
-        T{ ##copy f 2 1 any-rep }
+        T{ ##load-reference f 0 1.25 }
+        T{ ##load-reference f 1 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
+        T{ ##load-reference f 2 B{ 0 0 160 63 0 0 160 63 0 0 160 63 0 0 160 63 } }
     }
 ] [
     {
-        T{ ##load-constant f 0 1.25 }
+        T{ ##load-reference f 0 1.25 }
         T{ ##scalar>vector f 1 0 float-4-rep }
         T{ ##shuffle-vector-imm f 2 1 { 0 0 0 0 } float-4-rep }
     } value-numbering-step
@@ -1498,8 +1513,7 @@ cell 8 = [
     } value-numbering-step
 ] unit-test
 
-! branch folding
-
+! Branch folding
 : test-branch-folding ( insns -- insns' n )
     <basic-block>
     [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
@@ -1507,60 +1521,60 @@ cell 8 = [
 
 [
     {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
         T{ ##branch }
     }
     1
 ] [
     {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
         T{ ##compare-branch f 1 2 cc= }
     } test-branch-folding
 ] unit-test
 
 [
     {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
         T{ ##branch }
     }
     0
 ] [
     {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
         T{ ##compare-branch f 1 2 cc/= }
     } test-branch-folding
 ] unit-test
 
 [
     {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
         T{ ##branch }
     }
     0
 ] [
     {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
         T{ ##compare-branch f 1 2 cc< }
     } test-branch-folding
 ] unit-test
 
 [
     {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
         T{ ##branch }
     }
     1
 ] [
     {
-        T{ ##load-immediate f 1 1 }
-        T{ ##load-immediate f 2 2 }
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
         T{ ##compare-branch f 2 1 cc< }
     } test-branch-folding
 ] unit-test
@@ -1646,7 +1660,7 @@ cell 8 = [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-constant f 1 t }
+        T{ ##load-reference f 1 t }
         T{ ##branch }
     }
     0
@@ -1667,12 +1681,12 @@ V{
 } 1 test-bb
 
 V{
-    T{ ##load-immediate f 1 1 }
+    T{ ##load-integer f 1 1 }
     T{ ##branch }
 } 2 test-bb
 
 V{
-    T{ ##load-immediate f 2 2 }
+    T{ ##load-integer f 2 2 }
     T{ ##branch }
 } 3 test-bb
 
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index 96ca3efcf2..a7eb5dc0cd 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -8,10 +8,13 @@ compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.def-use
 compiler.cfg.instructions
-compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.alien
+compiler.cfg.value-numbering.comparisons
 compiler.cfg.value-numbering.expressions
-compiler.cfg.value-numbering.simplify
-compiler.cfg.value-numbering.rewrite ;
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.math
+compiler.cfg.value-numbering.rewrite
+compiler.cfg.value-numbering.simplify ;
 IN: compiler.cfg.value-numbering
 
 ! Local value numbering.
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 99564b7e0e..cc0754aba3 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -78,9 +78,9 @@ SYNTAX: CODEGEN:
     codegen-method-body define ;
 >>
 
-CODEGEN: ##load-immediate %load-immediate
+CODEGEN: ##load-integer %load-immediate
+CODEGEN: ##load-tagged %load-immediate
 CODEGEN: ##load-reference %load-reference
-CODEGEN: ##load-constant %load-reference
 CODEGEN: ##load-double %load-double
 CODEGEN: ##peek %peek
 CODEGEN: ##replace %replace
@@ -119,6 +119,7 @@ CODEGEN: ##not %not
 CODEGEN: ##neg %neg
 CODEGEN: ##log2 %log2
 CODEGEN: ##copy %copy
+CODEGEN: ##tagged>integer %copy
 CODEGEN: ##add-float %add-float
 CODEGEN: ##sub-float %sub-float
 CODEGEN: ##mul-float %mul-float
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 7bb33dec9a..fe2f0da02d 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -1457,7 +1457,7 @@ M: x86 immediate-bitwise? ( n -- ? )
     frame-reg swap 2 cells + [+] ;
 
 enable-min/max
-enable-fixnum-log2
+enable-log2
 
 :: install-sse2-check ( -- )
     [

From 82fb1879af96575dd5ad7efb318b1deb5f2ce1c5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 22 Apr 2010 03:21:23 -0500
Subject: [PATCH 103/158] Debugging untagged fixnums

---
 basis/compiler/cfg/builder/builder.factor     |   4 +-
 basis/compiler/cfg/checker/checker.factor     |   2 +
 basis/compiler/cfg/hats/hats.factor           |   7 +-
 .../cfg/instructions/instructions.factor      |  87 ++--
 .../cfg/intrinsics/alien/alien.factor         |  18 +-
 .../cfg/intrinsics/fixnum/fixnum.factor       |  28 +-
 .../cfg/intrinsics/float/float.factor         |  24 +-
 .../compiler/cfg/intrinsics/intrinsics.factor |  41 +-
 .../compiler/cfg/intrinsics/misc/misc.factor  |  27 +-
 .../cfg/linearization/linearization.factor    |   6 +
 .../cfg/ssa/destruction/destruction.factor    |   2 +-
 basis/compiler/cfg/stacks/stacks.factor       |   7 +-
 .../useless-conditionals.factor               |  21 +-
 .../comparisons/comparisons.factor            | 187 ++++---
 .../expressions/expressions.factor            |  24 +-
 .../value-numbering-tests.factor              | 459 +++++++++++++-----
 basis/compiler/codegen/codegen.factor         |   4 +-
 basis/cpu/architecture/architecture.factor    |   2 +
 18 files changed, 632 insertions(+), 318 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 370f3d053f..07f3c0aae4 100644
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -123,7 +123,7 @@ M: #recursive emit-node
     and ;
 
 : emit-trivial-if ( -- )
-    ds-pop f cc/= ^^compare-imm ds-push ;
+    [ f cc/= ^^compare-imm ] unary-op ;
 
 : trivial-not-if? ( #if -- ? )
     children>> first2
@@ -132,7 +132,7 @@ M: #recursive emit-node
     and ;
 
 : emit-trivial-not-if ( -- )
-    ds-pop f cc= ^^compare-imm ds-push ;
+    [ f cc= ^^compare-imm ] unary-op ;
 
 : emit-actual-if ( #if -- )
     ! Inputs to the final instruction need to be copied because of
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index d6f2702ee7..1a0265b42a 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -27,6 +27,8 @@ ERROR: last-insn-not-a-jump bb ;
         [ ##dispatch? ]
         [ ##compare-branch? ]
         [ ##compare-imm-branch? ]
+        [ ##compare-integer-branch? ]
+        [ ##compare-integer-imm-branch? ]
         [ ##compare-float-ordered-branch? ]
         [ ##compare-float-unordered-branch? ]
         [ ##fixnum-add? ]
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index f11ffb10d4..a03f1f83bc 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays combinators.short-circuit
-kernel layouts math namespaces sequences combinators splitting
-parser effects words cpu.architecture compiler.cfg.registers
+USING: accessors alien arrays byte-arrays classes.algebra
+combinators.short-circuit kernel layouts math namespaces
+sequences combinators splitting parser effects words
+cpu.architecture compiler.constants compiler.cfg.registers
 compiler.cfg.instructions compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.hats
 
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index f7800ab6be..11d7bfe93a 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces words
-math math.order layouts classes.algebra classes.union
-compiler.units alien byte-arrays compiler.constants combinators
-compiler.cfg.registers compiler.cfg.instructions.syntax ;
+math math.order layouts classes.union compiler.units alien
+byte-arrays combinators compiler.cfg.registers
+compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
 <<
@@ -23,20 +23,20 @@ TUPLE: pure-insn < insn ;
 ! Constants
 INSN: ##load-integer
 def: dst/int-rep
-constant: val ;
+constant: val/int-rep ;
 
 INSN: ##load-reference
 def: dst/tagged-rep
-constant: obj ;
+constant: obj/tagged-rep ;
 
 ! These two are inserted by representation selection
 INSN: ##load-tagged
 def: dst/tagged-rep
-constant: val ;
+constant: val/tagged-rep ;
 
 INSN: ##load-double
 def: dst/double-rep
-constant: val ;
+constant: val/double-rep ;
 
 ! Stack operations
 INSN: ##peek
@@ -115,7 +115,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##add-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##sub
 def: dst/int-rep
@@ -124,7 +124,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##sub-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##mul
 def: dst/int-rep
@@ -133,7 +133,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##mul-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##and
 def: dst/int-rep
@@ -142,7 +142,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##and-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##or
 def: dst/int-rep
@@ -151,7 +151,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##or-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##xor
 def: dst/int-rep
@@ -160,7 +160,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##xor-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##shl
 def: dst/int-rep
@@ -169,7 +169,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##shl-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##shr
 def: dst/int-rep
@@ -178,7 +178,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##shr-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##sar
 def: dst/int-rep
@@ -187,7 +187,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##sar-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2 ;
+constant: src2/int-rep ;
 
 PURE-INSN: ##min
 def: dst/int-rep
@@ -691,14 +691,14 @@ INSN: ##phi
 def: dst
 literal: inputs ;
 
-! Conditionals
+! Tagged conditionals
 INSN: ##compare-branch
 use: src1/tagged-rep src2/tagged-rep
 literal: cc ;
 
 INSN: ##compare-imm-branch
 use: src1/tagged-rep
-constant: src2
+constant: src2/tagged-rep
 literal: cc ;
 
 PURE-INSN: ##compare
@@ -710,10 +710,34 @@ temp: temp/int-rep ;
 PURE-INSN: ##compare-imm
 def: dst/tagged-rep
 use: src1/tagged-rep
-constant: src2
+constant: src2/tagged-rep
 literal: cc
 temp: temp/int-rep ;
 
+! Integer conditionals
+INSN: ##compare-integer-branch
+use: src1/int-rep src2/int-rep
+literal: cc ;
+
+INSN: ##compare-integer-imm-branch
+use: src1/int-rep
+constant: src2/int-rep
+literal: cc ;
+
+PURE-INSN: ##compare-integer
+def: dst/tagged-rep
+use: src1/int-rep src2/int-rep
+literal: cc
+temp: temp/int-rep ;
+
+PURE-INSN: ##compare-integer-imm
+def: dst/tagged-rep
+use: src1/int-rep
+constant: src2/int-rep
+literal: cc
+temp: temp/int-rep ;
+
+! Float conditionals
 INSN: ##compare-float-ordered-branch
 use: src1/double-rep src2/double-rep
 literal: cc ;
@@ -770,7 +794,7 @@ literal: label ;
 INSN: _loop-entry ;
 
 INSN: _dispatch
-use: src/int-rep
+use: src
 temp: temp ;
 
 INSN: _dispatch-label
@@ -778,46 +802,44 @@ literal: label ;
 
 INSN: _compare-branch
 literal: label
-use: src1/tagged-rep src2/tagged-rep
+use: src1 src2
 literal: cc ;
 
 INSN: _compare-imm-branch
 literal: label
-use: src1/tagged-rep
+use: src1
 constant: src2
 literal: cc ;
 
 INSN: _compare-float-unordered-branch
 literal: label
-use: src1/tagged-rep src2/tagged-rep
+use: src1 src2
 literal: cc ;
 
 INSN: _compare-float-ordered-branch
 literal: label
-use: src1/tagged-rep src2/tagged-rep
+use: src1 src2
 literal: cc ;
 
 ! Overflowing arithmetic
 INSN: _fixnum-add
 literal: label
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst
+use: src1 src2 ;
 
 INSN: _fixnum-sub
 literal: label
-def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+def: dst
+use: src1 src2 ;
 
 INSN: _fixnum-mul
 literal: label
-def: dst/tagged-rep
-use: src1/tagged-rep src2/int-rep ;
+def: dst
+use: src1 src2 ;
 
 TUPLE: spill-slot { n integer } ;
 C: <spill-slot> spill-slot
 
-! These instructions operate on machine registers and not
-! virtual registers
 INSN: _spill
 use: src
 literal: rep dst ;
@@ -829,6 +851,7 @@ literal: rep src ;
 INSN: _spill-area-size
 literal: n ;
 
+! For GC check insertion
 UNION: ##allocation
 ##allot
 ##box-alien
diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor
index 8ef51f6478..452a48ea54 100644
--- a/basis/compiler/cfg/intrinsics/alien/alien.factor
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@@ -16,9 +16,10 @@ IN: compiler.cfg.intrinsics.alien
 
 : emit-<displaced-alien> ( node -- )
     dup emit-<displaced-alien>? [
-        [ 2inputs ] dip
-        node-input-infos second class>>
-        ^^box-displaced-alien ds-push
+        '[
+            _ node-input-infos second class>>
+            ^^box-displaced-alien
+        ] binary-op
     ] [ emit-primitive ] if ;
 
 :: inline-alien ( node quot test -- )
@@ -51,11 +52,16 @@ IN: compiler.cfg.intrinsics.alien
 : prepare-alien-setter ( infos -- ptr-vreg offset )
     second prepare-alien-accessor ;
 
-: inline-alien-setter ( node quot -- )
+: inline-alien-integer-setter ( node quot -- )
     '[ prepare-alien-setter ds-pop @ ]
     [ fixnum inline-alien-setter? ]
     inline-alien ; inline
 
+: inline-alien-float-setter ( node quot -- )
+    '[ prepare-alien-setter ds-pop @ ]
+    [ float inline-alien-setter? ]
+    inline-alien ; inline
+
 : inline-alien-cell-setter ( node quot -- )
     '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
     [ pinned-c-ptr inline-alien-setter? ]
@@ -86,7 +92,7 @@ IN: compiler.cfg.intrinsics.alien
             { 2 [ ##set-alien-integer-2 ] }
             { 4 [ ##set-alien-integer-4 ] }
         } case
-    ] inline-alien-setter ;
+    ] inline-alien-integer-setter ;
 
 : emit-alien-cell-getter ( node -- )
     [ ^^alien-cell ^^box-alien ] inline-alien-getter ;
@@ -108,4 +114,4 @@ IN: compiler.cfg.intrinsics.alien
             { float-rep [ ##set-alien-float ] }
             { double-rep [ ##set-alien-double ] }
         } case
-    ] inline-alien-setter ;
+    ] inline-alien-float-setter ;
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index 3f86332dcb..dcecb1fac4 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -14,26 +14,24 @@ compiler.cfg.comparisons ;
 IN: compiler.cfg.intrinsics.fixnum
 
 : emit-both-fixnums? ( -- )
-    2inputs
-    ^^or
-    tag-mask get ^^and-imm
-    0 cc= ^^compare-imm
-    ds-push ;
-
-: binary-fixnum-op ( quot -- )
-    [ 2inputs ] dip call ds-push ; inline
-
-: unary-fixnum-op ( quot -- )
-    [ ds-pop ] dip call ds-push ; inline
+    [
+        [ ^^tagged>integer ] bi@
+        ^^or tag-mask get ^^and-imm
+        0 cc= ^^compare-integer-imm
+    ] binary-op ;
 
 : emit-fixnum-left-shift ( -- )
-    [ ^^shl ] binary-fixnum-op ;
+    [ ^^shl ] binary-op ;
 
 : emit-fixnum-right-shift ( -- )
-    [ ^^sar ] binary-fixnum-op ;
+    [
+        [ tag-bits get ^^shl-imm ] dip
+        ^^neg ^^sar
+        tag-bits get ^^sar-imm
+    ] binary-op ;
 
 : emit-fixnum-shift-general ( -- )
-    ds-peek 0 cc> ##compare-imm-branch
+    ds-peek 0 cc> ##compare-integer-imm-branch
     [ emit-fixnum-left-shift ] with-branch
     [ emit-fixnum-right-shift ] with-branch
     2array emit-conditional ;
@@ -46,7 +44,7 @@ IN: compiler.cfg.intrinsics.fixnum
     } cond ;
 
 : emit-fixnum-comparison ( cc -- )
-    '[ _ ^^compare ] binary-fixnum-op ;
+    '[ _ ^^compare-integer ] binary-op ;
 
 : emit-no-overflow-case ( dst -- final-bb )
     [ ds-drop ds-drop ds-push ] with-branch ;
diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor
index 39dc80cf28..480b46f9b3 100644
--- a/basis/compiler/cfg/intrinsics/float/float.factor
+++ b/basis/compiler/cfg/intrinsics/float/float.factor
@@ -1,29 +1,17 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.stacks compiler.cfg.hats
+USING: fry kernel compiler.cfg.stacks compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.float
 
-: emit-float-op ( insn -- )
-    [ 2inputs ] dip call ds-push ; inline
-
 : emit-float-ordered-comparison ( cc -- )
-    [ 2inputs ] dip ^^compare-float-ordered ds-push ; inline
+    '[ _ ^^compare-float-ordered ] binary-op ; inline
 
 : emit-float-unordered-comparison ( cc -- )
-    [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
-
-: emit-float>fixnum ( -- )
-    ds-pop ^^float>integer ds-push ;
-
-: emit-fixnum>float ( -- )
-    ds-pop ^^integer>float ds-push ;
-
-: emit-fsqrt ( -- )
-    ds-pop ^^sqrt ds-push ;
+    '[ _ ^^compare-float-unordered ] binary-op ; inline
 
 : emit-unary-float-function ( func -- )
-    [ ds-pop ] dip ^^unary-float-function ds-push ;
+    '[ _ ^^unary-float-function ] unary-op ;
 
 : emit-binary-float-function ( func -- )
-    [ 2inputs ] dip ^^binary-float-function ds-push ;
+    '[ _ ^^binary-float-function ] binary-op ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 35832d282e..535bcf4f7f 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: words sequences kernel combinators cpu.architecture assocs
 compiler.cfg.hats
+compiler.cfg.stacks
 compiler.cfg.instructions
 compiler.cfg.intrinsics.alien
 compiler.cfg.intrinsics.allot
@@ -38,19 +39,19 @@ IN: compiler.cfg.intrinsics
     { math.private:fixnum+ [ drop emit-fixnum+ ] }
     { math.private:fixnum- [ drop emit-fixnum- ] }
     { math.private:fixnum* [ drop emit-fixnum* ] }
-    { math.private:fixnum+fast [ drop [ ^^add ] binary-fixnum-op ] }
-    { math.private:fixnum-fast [ drop [ ^^sub ] binary-fixnum-op ] }
-    { math.private:fixnum*fast [ drop [ ^^mul ] binary-fixnum-op ] }
-    { math.private:fixnum-bitand [ drop [ ^^and ] binary-fixnum-op ] }
-    { math.private:fixnum-bitor [ drop [ ^^or ] binary-fixnum-op ] }
-    { math.private:fixnum-bitxor [ drop [ ^^xor ] binary-fixnum-op ] }
+    { math.private:fixnum+fast [ drop [ ^^add ] binary-op ] }
+    { math.private:fixnum-fast [ drop [ ^^sub ] binary-op ] }
+    { math.private:fixnum*fast [ drop [ ^^mul ] binary-op ] }
+    { math.private:fixnum-bitand [ drop [ ^^and ] binary-op ] }
+    { math.private:fixnum-bitor [ drop [ ^^or ] binary-op ] }
+    { math.private:fixnum-bitxor [ drop [ ^^xor ] binary-op ] }
     { math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
-    { math.private:fixnum-bitnot [ drop [ ^^not ] unary-fixnum-op ] }
+    { math.private:fixnum-bitnot [ drop [ ^^not ] unary-op ] }
     { math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
     { math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
     { math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
     { math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
-    { kernel:eq? [ drop cc= emit-fixnum-comparison ] }
+    { kernel:eq? [ emit-eq ] }
     { slots.private:slot [ emit-slot ] }
     { slots.private:set-slot [ emit-set-slot ] }
     { strings.private:string-nth [ drop emit-string-nth ] }
@@ -83,10 +84,10 @@ IN: compiler.cfg.intrinsics
 
 : enable-float-intrinsics ( -- )
     {
-        { math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
-        { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
-        { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
-        { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+        { math.private:float+ [ drop [ ^^add-float ] binary-op ] }
+        { math.private:float- [ drop [ ^^sub-float ] binary-op ] }
+        { math.private:float* [ drop [ ^^mul-float ] binary-op ] }
+        { math.private:float/f [ drop [ ^^div-float ] binary-op ] }
         { math.private:float< [ drop cc< emit-float-ordered-comparison ] }
         { math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
         { math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
@@ -96,8 +97,8 @@ IN: compiler.cfg.intrinsics
         { math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
         { math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
         { math.private:float= [ drop cc= emit-float-unordered-comparison ] }
-        { math.private:float>fixnum [ drop emit-float>fixnum ] }
-        { math.private:fixnum>float [ drop emit-fixnum>float ] }
+        { math.private:float>fixnum [ drop [ ^^float>integer ] unary-op ] }
+        { math.private:fixnum>float [ drop [ ^^integer>float ] unary-op ] }
         { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
         { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
         { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
@@ -107,13 +108,13 @@ IN: compiler.cfg.intrinsics
 
 : enable-fsqrt ( -- )
     {
-        { math.libm:fsqrt [ drop emit-fsqrt ] }
+        { math.libm:fsqrt [ drop [ ^^sqrt ] unary-op ] }
     } enable-intrinsics ;
 
 : enable-float-min/max ( -- )
     {
-        { math.floats.private:float-min [ drop [ ^^min-float ] emit-float-op ] }
-        { math.floats.private:float-max [ drop [ ^^max-float ] emit-float-op ] }
+        { math.floats.private:float-min [ drop [ ^^min-float ] binary-op ] }
+        { math.floats.private:float-max [ drop [ ^^max-float ] binary-op ] }
     } enable-intrinsics ;
 
 : enable-float-functions ( -- )
@@ -143,13 +144,13 @@ IN: compiler.cfg.intrinsics
 
 : enable-min/max ( -- )
     {
-        { math.integers.private:fixnum-min [ drop [ ^^min ] binary-fixnum-op ] }
-        { math.integers.private:fixnum-max [ drop [ ^^max ] binary-fixnum-op ] }
+        { math.integers.private:fixnum-min [ drop [ ^^min ] binary-op ] }
+        { math.integers.private:fixnum-max [ drop [ ^^max ] binary-op ] }
     } enable-intrinsics ;
 
 : enable-log2 ( -- )
     {
-        { math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-fixnum-op ] }
+        { math.integers.private:fixnum-log2 [ drop [ ^^log2 ] unary-op ] }
     } enable-intrinsics ;
 
 : emit-intrinsic ( node word -- )
diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor
index 028b6ad990..952b8701da 100644
--- a/basis/compiler/cfg/intrinsics/misc/misc.factor
+++ b/basis/compiler/cfg/intrinsics/misc/misc.factor
@@ -1,15 +1,23 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces layouts sequences kernel math accessors
-compiler.tree.propagation.info compiler.cfg.stacks
-compiler.cfg.hats compiler.cfg.instructions
+USING: accessors classes.algebra layouts kernel math namespaces
+sequences
+compiler.tree.propagation.info
+compiler.cfg.stacks
+compiler.cfg.hats
+compiler.cfg.comparisons
+compiler.cfg.instructions
 compiler.cfg.builder.blocks
 compiler.cfg.utilities ;
 FROM: vm => context-field-offset vm-field-offset ;
 IN: compiler.cfg.intrinsics.misc
 
 : emit-tag ( -- )
-    ds-pop ^^tagged>integer tag-mask get ^^and-imm ds-push ;
+    [ ^^tagged>integer tag-mask get ^^and-imm ] unary-op ;
+
+: emit-eq ( node -- )
+    node-input-infos first2 [ class>> fixnum class<= ] both?
+    [ [ cc= ^^compare-integer ] binary-op ] [ [ cc= ^^compare ] binary-op ] if ;
 
 : special-object-offset ( n -- offset )
     cells "special-objects" vm-field-offset + ;
@@ -37,8 +45,9 @@ IN: compiler.cfg.intrinsics.misc
     ] [ emit-primitive ] ?if ;
 
 : emit-identity-hashcode ( -- )
-    ds-pop ^^tagged>integer
-    tag-mask get bitnot ^^load-integer ^^and
-    0 ^^alien-cell
-    hashcode-shift ^^shr-imm
-    ds-push ;
+    [
+        ^^tagged>integer
+        tag-mask get bitnot ^^load-integer ^^and
+        0 ^^alien-cell
+        hashcode-shift ^^shr-imm
+    ] unary-op ;
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index a0360e9d9c..b53eebfc20 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -69,6 +69,12 @@ M: ##compare-branch linearize-insn
 M: ##compare-imm-branch linearize-insn
     binary-conditional _compare-imm-branch emit-branch ;
 
+M: ##compare-integer-branch linearize-insn
+    binary-conditional _compare-branch emit-branch ;
+
+M: ##compare-integer-imm-branch linearize-insn
+    binary-conditional _compare-imm-branch emit-branch ;
+
 M: ##compare-float-ordered-branch linearize-insn
     binary-conditional _compare-float-ordered-branch emit-branch ;
 
diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor
index 8b766c8114..a55e5baa2c 100644
--- a/basis/compiler/cfg/ssa/destruction/destruction.factor
+++ b/basis/compiler/cfg/ssa/destruction/destruction.factor
@@ -67,7 +67,7 @@ GENERIC: prepare-insn ( insn -- )
 M: insn prepare-insn
     [ defs-vreg ] [ uses-vregs ] bi
     2dup empty? not and [
-        first 
+        first
         2dup [ rep-of ] bi@ eq?
         [ try-to-coalesce ] [ 2drop ] if
     ] [ 2drop ] if ;
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index 6cf362c230..fdd6e405f5 100644
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -68,9 +68,14 @@ IN: compiler.cfg.stacks
 : 3inputs ( -- vreg1 vreg2 vreg3 )
     (3inputs) -3 inc-d ;
 
+: binary-op ( quot -- )
+    [ 2inputs ] dip call ds-push ; inline
+
+: unary-op ( quot -- )
+    [ ds-pop ] dip call ds-push ; inline
+
 ! adjust-d/adjust-r: these are called when other instructions which
 ! internally adjust the stack height are emitted, such as ##call and
 ! ##alien-invoke
 : adjust-d ( n -- ) current-height get [ + ] change-d drop ;
 : adjust-r ( n -- ) current-height get [ + ] change-r drop ;
-
diff --git a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
index a2885ae26e..b2529655bb 100644
--- a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
+++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor
@@ -1,19 +1,22 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 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
+USING: kernel accessors sequences math combinators
+combinators.short-circuit vectors compiler.cfg
+compiler.cfg.instructions compiler.cfg.rpo
 compiler.cfg.utilities ;
 IN: compiler.cfg.useless-conditionals
 
 : delete-conditional? ( bb -- ? )
     {
         [
-            instructions>> last class {
-                ##compare-branch
-                ##compare-imm-branch
-                ##compare-float-ordered-branch
-                ##compare-float-unordered-branch
-            } member-eq?
+            instructions>> last {
+                [ ##compare-branch? ]
+                [ ##compare-imm-branch? ]
+                [ ##compare-integer-branch? ]
+                [ ##compare-integer-imm-branch? ]
+                [ ##compare-float-ordered-branch? ]
+                [ ##compare-float-unordered-branch? ]
+            } 1||
         ]
         [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
     } 1&& ;
diff --git a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
index 45b15b61d2..cd2f420af9 100644
--- a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
+++ b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
@@ -8,15 +8,57 @@ compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.comparisons
 
-: ##branch-t? ( insn -- ? )
-    dup ##compare-imm-branch? [
-        { [ cc>> cc/= eq? ] [ src2>> not ] } 1&&
-    ] [ drop f ] if ; inline
+! Optimizations performed here:
+!
+! 1) Eliminating intermediate boolean values when the result of
+! a comparison is used by a compare-branch
+! 2) Folding comparisons where both inputs are literal
+! 3) Folding comparisons where both inputs are congruent
+! 4) Converting compare instructions into compare-imm instructions
+
+: fold-compare-imm? ( insn -- ? )
+    src1>> vreg>expr literal-expr? ;
+
+: evaluate-compare-imm ( insn -- ? )
+    [ src1>> vreg>comparand ] [ src2>> ] [ cc>> ] tri
+    {
+        { cc= [ eq? ] }
+        { cc/= [ eq? not ] }
+    } case ;
+
+: fold-compare-integer-imm? ( insn -- ? )
+    src1>> vreg>expr integer-expr? ;
+
+: evaluate-compare-integer-imm ( insn -- ? )
+    [ src1>> vreg>integer ] [ src2>> ] [ cc>> ] tri
+    [ <=> ] dip evaluate-cc ;
+
+: >compare-expr< ( expr -- in1 in2 cc )
+    [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
+
+: >compare-imm-expr< ( expr -- in1 in2 cc )
+    [ src1>> vn>vreg ] [ src2>> vn>comparand ] [ cc>> ] tri ; inline
+
+: >compare-integer-expr< ( expr -- in1 in2 cc )
+    [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
+
+: >compare-integer-imm-expr< ( expr -- in1 in2 cc )
+    [ src1>> vn>vreg ] [ src2>> vn>integer ] [ cc>> ] tri ; inline
+
+: >test-vector-expr< ( expr -- src1 temp rep vcc )
+    {
+        [ src1>> vn>vreg ]
+        [ drop next-vreg ]
+        [ rep>> ]
+        [ vcc>> ]
+    } cleave ; inline
 
 : scalar-compare-expr? ( insn -- ? )
     {
         [ compare-expr? ]
         [ compare-imm-expr? ]
+        [ compare-integer-expr? ]
+        [ compare-integer-imm-expr? ]
         [ compare-float-unordered-expr? ]
         [ compare-float-ordered-expr? ]
     } 1|| ;
@@ -28,61 +70,23 @@ IN: compiler.cfg.value-numbering.comparisons
     } 1|| ;
 
 : rewrite-boolean-comparison? ( insn -- ? )
-    dup ##branch-t? [
-        src1>> vreg>expr general-compare-expr?
-    ] [ drop f ] if ; inline
- 
-: >compare-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
-
-: >compare-imm-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> vn>integer ] [ cc>> ] tri ; inline
-
-: >test-vector-expr< ( expr -- src1 temp rep vcc )
     {
-        [ src1>> vn>vreg ]
-        [ drop next-vreg ]
-        [ rep>> ]
-        [ vcc>> ]
-    } cleave ; inline
+        [ src1>> vreg>expr general-compare-expr? ]
+        [ src2>> not ]
+        [ cc>> cc/= eq? ]
+    } 1&& ; inline
 
 : rewrite-boolean-comparison ( expr -- insn )
     src1>> vreg>expr {
         { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
         { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
+        { [ dup compare-integer-expr? ] [ >compare-integer-expr< \ ##compare-integer-branch new-insn ] }
+        { [ dup compare-integer-imm-expr? ] [ >compare-integer-imm-expr< \ ##compare-integer-imm-branch new-insn ] }
         { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
         { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] }
         { [ dup test-vector-expr? ] [ >test-vector-expr< \ ##test-vector-branch new-insn ] }
     } cond ;
 
-: rewrite-redundant-comparison? ( insn -- ? )
-    {
-        [ src1>> vreg>expr scalar-compare-expr? ]
-        [ src2>> not ]
-        [ cc>> { cc= cc/= } member? ]
-    } 1&& ; inline
-
-: rewrite-redundant-comparison ( insn -- insn' )
-    [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
-        { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
-        { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
-        { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
-        { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
-    } cond
-    swap cc= eq? [ [ negate-cc ] change-cc ] when ;
-
-: evaluate-compare-imm ( insn -- ? )
-    [ src1>> vreg>comparand ] [ src2>> ] [ cc>> ] tri
-    2over [ integer? ] both? [ [ <=> ] dip evaluate-cc ] [
-        {
-            { cc= [ eq? ] }
-            { cc/= [ eq? not ] }
-        } case
-    ] if ;
-
-: fold-compare-imm? ( insn -- ? )
-    src1>> vreg>expr literal-expr? ;
-
 : fold-branch ( ? -- insn )
     0 1 ?
     basic-block get [ nth 1vector ] change-successors drop
@@ -98,20 +102,31 @@ M: ##compare-imm-branch rewrite
         [ drop f ]
     } cond ;
 
+: fold-compare-integer-imm-branch ( insn -- insn/f )
+    evaluate-compare-integer-imm fold-branch ;
+
+M: ##compare-integer-imm-branch rewrite
+    {
+        { [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm-branch ] }
+        [ drop f ]
+    } cond ;
+
 : swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
     [ [ swap ] dip swap-cc ] when ; inline
 
+: (>compare-imm-branch) ( insn swap? -- src1 src2 cc )
+    [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] dip swap-compare ; inline
+
 : >compare-imm-branch ( insn swap? -- insn' )
-    [
-        [ src1>> ]
-        [ src2>> ]
-        [ cc>> ]
-        tri
-    ] dip
-    swap-compare
+    (>compare-imm-branch)
     [ vreg>comparand ] dip
     \ ##compare-imm-branch new-insn ; inline
 
+: >compare-integer-imm-branch ( insn swap? -- insn' )
+    (>compare-imm-branch)
+    [ vreg>integer ] dip
+    \ ##compare-integer-imm-branch new-insn ; inline
+
 : self-compare? ( insn -- ? )
     [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
 
@@ -129,19 +144,28 @@ M: ##compare-branch rewrite
         [ drop f ]
     } cond ;
 
+M: ##compare-integer-branch rewrite
+    {
+        { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm-branch ] }
+        { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm-branch ] }
+        { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
+        [ drop f ]
+    } cond ;
+
+: (>compare-imm) ( insn swap? -- dst src1 src2 cc )
+    [ { [ dst>> ] [ src1>> ] [ src2>> ] [ cc>> ] } cleave ] dip
+    swap-compare ; inline
+
 : >compare-imm ( insn swap? -- insn' )
-    [
-        {
-            [ dst>> ]
-            [ src1>> ]
-            [ src2>> ]
-            [ cc>> ]
-        } cleave
-    ] dip
-    swap-compare
+    (>compare-imm)
     [ vreg>comparand ] dip
     next-vreg \ ##compare-imm new-insn ; inline
 
+: >compare-integer-imm ( insn swap? -- insn' )
+    (>compare-imm)
+    [ vreg>integer ] dip
+    next-vreg \ ##compare-integer-imm new-insn ; inline
+
 : >boolean-insn ( insn ? -- insn' )
     [ dst>> ] dip \ ##load-reference new-insn ;
 
@@ -156,6 +180,32 @@ M: ##compare rewrite
         [ drop f ]
     } cond ;
 
+M: ##compare-integer rewrite
+    {
+        { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm ] }
+        { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm ] }
+        { [ dup self-compare? ] [ rewrite-self-compare ] }
+        [ drop f ]
+    } cond ;
+
+: rewrite-redundant-comparison? ( insn -- ? )
+    {
+        [ src1>> vreg>expr scalar-compare-expr? ]
+        [ src2>> not ]
+        [ cc>> { cc= cc/= } member? ]
+    } 1&& ; inline
+
+: rewrite-redundant-comparison ( insn -- insn' )
+    [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
+        { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
+        { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
+        { [ dup compare-integer-expr? ] [ >compare-integer-expr< next-vreg \ ##compare-integer new-insn ] }
+        { [ dup compare-integer-imm-expr? ] [ >compare-integer-imm-expr< next-vreg \ ##compare-integer-imm new-insn ] }
+        { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
+        { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
+    } cond
+    swap cc= eq? [ [ negate-cc ] change-cc ] when ;
+
 : fold-compare-imm ( insn -- insn' )
     dup evaluate-compare-imm >boolean-insn ;
 
@@ -165,3 +215,12 @@ M: ##compare-imm rewrite
         { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
         [ drop f ]
     } cond ;
+
+: fold-compare-integer-imm ( insn -- insn' )
+    dup evaluate-compare-integer-imm >boolean-insn ;
+
+M: ##compare-integer-imm rewrite
+    {
+        { [ dup fold-compare-integer-imm? ] [ fold-compare-integer-imm ] }
+        [ drop f ]
+    } cond ;
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index 92260ae6ee..041432c089 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes classes.algebra classes.parser
 classes.tuple combinators combinators.short-circuit fry
-generic.parser kernel layouts locals math namespaces quotations
+generic.parser kernel layouts math namespaces quotations
 sequences slots splitting words
 cpu.architecture
 compiler.cfg.instructions
@@ -57,18 +57,18 @@ M: integer-expr expr>integer value>> ;
 : vreg-immediate-arithmetic? ( vreg -- ? )
     vreg>expr {
         [ integer-expr? ]
-        [ expr>integer tag-fixnum immediate-arithmetic? ]
+        [ expr>integer immediate-arithmetic? ]
     } 1&& ;
 
 : vreg-immediate-bitwise? ( vreg -- ? )
     vreg>expr {
         [ integer-expr? ]
-        [ expr>integer tag-fixnum immediate-bitwise? ]
+        [ expr>integer immediate-bitwise? ]
     } 1&& ;
 
 GENERIC: expr>comparand ( expr -- n )
 
-M: integer-expr expr>comparand value>> ;
+M: integer-expr expr>comparand value>> tag-fixnum ;
 
 M: reference-expr expr>comparand value>> ;
 
@@ -94,18 +94,20 @@ M: reference-expr expr>comparand value>> ;
 : define-expr-class ( expr slot-specs -- )
     [ expr ] dip [ name>> ] map define-tuple-class ;
 
-: constant>vn ( obj -- vn )
-    dup integer? [ <integer-expr> ] [ <reference-expr> ] if
-    expr>vn ;
+: constant-quot ( rep -- quot )
+    {
+        { int-rep [ [ <integer-expr> ] ] }
+        { tagged-rep [ [ <reference-expr> ] ] }
+    } case [ expr>vn ] append ;
 
 : >expr-quot ( expr slot-specs -- quot )
      [
         [ name>> reader-word 1quotation ]
         [
-            type>> {
-                { use [ [ vreg>vn ] ] }
-                { literal [ [ ] ] }
-                { constant [ [ constant>vn ] ] }
+            [ rep>> ] [ type>> ] bi {
+                { use [ drop [ vreg>vn ] ] }
+                { literal [ drop [ ] ] }
+                { constant [ constant-quot ] }
             } case
         ] bi append
     ] map cleave>quot swap suffix \ boa suffix ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 6b6f49d1c5..f18f00aa76 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -13,6 +13,8 @@ IN: compiler.cfg.value-numbering.tests
         dup {
             [ ##compare? ]
             [ ##compare-imm? ]
+            [ ##compare-integer? ]
+            [ ##compare-integer-imm? ]
             [ ##compare-float-unordered? ]
             [ ##compare-float-ordered? ]
             [ ##test-vector? ]
@@ -72,17 +74,17 @@ IN: compiler.cfg.value-numbering.tests
 ! Double compare elimination
 [
     {
-        T{ ##load-reference f 1 "hi" }
-        T{ ##peek f 2 D 0 }
-        T{ ##compare f 4 2 1 cc> }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##compare f 4 2 1 cc= }
         T{ ##copy f 6 4 any-rep }
         T{ ##replace f 6 D 0 }
     }
 ] [
     {
-        T{ ##load-reference f 1 "hi" }
-        T{ ##peek f 2 D 0 }
-        T{ ##compare f 4 2 1 cc> }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##compare f 4 2 1 cc= }
         T{ ##compare-imm f 6 4 f cc/= }
         T{ ##replace f 6 D 0 }
     } value-numbering-step trim-temps
@@ -90,22 +92,72 @@ IN: compiler.cfg.value-numbering.tests
 
 [
     {
-        T{ ##load-reference f 1 "hi" }
-        T{ ##peek f 2 D 0 }
-        T{ ##compare f 4 2 1 cc<= }
-        T{ ##compare f 6 2 1 cc/<= }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-imm f 2 1 16 cc= }
+        T{ ##copy f 3 2 any-rep }
+        T{ ##replace f 3 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-imm f 2 1 16 cc= }
+        T{ ##compare-imm f 3 2 f cc/= }
+        T{ ##replace f 3 D 0 }
+    } value-numbering-step trim-temps
+] unit-test
+
+[
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##compare-integer f 4 2 1 cc> }
+        T{ ##copy f 6 4 any-rep }
         T{ ##replace f 6 D 0 }
     }
 ] [
     {
-        T{ ##load-reference f 1 "hi" }
-        T{ ##peek f 2 D 0 }
-        T{ ##compare f 4 2 1 cc<= }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##compare-integer f 4 2 1 cc> }
+        T{ ##compare-imm f 6 4 f cc/= }
+        T{ ##replace f 6 D 0 }
+    } value-numbering-step trim-temps
+] unit-test
+
+[
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##compare-integer f 4 2 1 cc<= }
+        T{ ##compare-integer f 6 2 1 cc/<= }
+        T{ ##replace f 6 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##compare-integer f 4 2 1 cc<= }
         T{ ##compare-imm f 6 4 f cc= }
         T{ ##replace f 6 D 0 }
     } value-numbering-step trim-temps
 ] unit-test
 
+[
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-imm f 2 1 100 cc<= }
+        T{ ##compare-integer-imm f 3 1 100 cc/<= }
+        T{ ##replace f 3 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-imm f 2 1 100 cc<= }
+        T{ ##compare-imm f 3 2 f cc= }
+        T{ ##replace f 3 D 0 }
+    } value-numbering-step trim-temps
+] unit-test
+
 [
     {
         T{ ##peek f 8 D 0 }
@@ -128,14 +180,30 @@ IN: compiler.cfg.value-numbering.tests
     {
         T{ ##peek f 29 D -1 }
         T{ ##peek f 30 D -2 }
-        T{ ##compare f 33 29 30 cc<= }
-        T{ ##compare-branch f 29 30 cc<= }
+        T{ ##compare f 33 29 30 cc= }
+        T{ ##compare-branch f 29 30 cc= }
     }
 ] [
     {
         T{ ##peek f 29 D -1 }
         T{ ##peek f 30 D -2 }
-        T{ ##compare f 33 29 30 cc<= }
+        T{ ##compare f 33 29 30 cc= }
+        T{ ##compare-imm-branch f 33 f cc/= }
+    } value-numbering-step trim-temps
+] unit-test
+
+[
+    {
+        T{ ##peek f 29 D -1 }
+        T{ ##peek f 30 D -2 }
+        T{ ##compare-integer f 33 29 30 cc<= }
+        T{ ##compare-integer-branch f 29 30 cc<= }
+    }
+] [
+    {
+        T{ ##peek f 29 D -1 }
+        T{ ##peek f 30 D -2 }
+        T{ ##compare-integer f 33 29 30 cc<= }
         T{ ##compare-imm-branch f 33 f cc/= }
     } value-numbering-step trim-temps
 ] unit-test
@@ -154,6 +222,22 @@ IN: compiler.cfg.value-numbering.tests
     } value-numbering-step trim-temps
 ] unit-test
 
+cpu x86.32? [
+    [
+        {
+            T{ ##peek f 1 D 0 }
+            T{ ##compare-imm f 2 1 + cc= }
+            T{ ##compare-imm-branch f 1 + cc= }
+        }
+    ] [
+        {
+            T{ ##peek f 1 D 0 }
+            T{ ##compare-imm f 2 1 + cc= }
+            T{ ##compare-imm-branch f 2 f cc/= }
+        } value-numbering-step trim-temps
+    ] unit-test
+] when
+
 ! Immediate operand fusion
 [
     {
@@ -409,13 +493,27 @@ IN: compiler.cfg.value-numbering.tests
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-imm f 2 0 100 cc<= }
+        T{ ##compare-imm f 2 0 $[ 100 tag-fixnum ] cc= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare f 2 0 1 cc<= }
+        T{ ##compare f 2 0 1 cc= }
+    } value-numbering-step trim-temps
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-integer f 1 100 }
+        T{ ##compare-integer-imm f 2 0 100 cc<= }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-integer f 1 100 }
+        T{ ##compare-integer f 2 0 1 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -481,13 +579,13 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-imm f 2 0 100 cc>= }
+        T{ ##compare-integer-imm f 2 0 100 cc>= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare f 2 1 0 cc<= }
+        T{ ##compare-integer f 2 1 0 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -495,13 +593,13 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-imm-branch f 0 100 cc<= }
+        T{ ##compare-integer-imm-branch f 0 100 cc<= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-branch f 0 1 cc<= }
+        T{ ##compare-integer-branch f 0 1 cc<= }
     } value-numbering-step
 ] unit-test
 
@@ -509,13 +607,13 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-imm-branch f 0 100 cc>= }
+        T{ ##compare-integer-imm-branch f 0 100 cc>= }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-branch f 1 0 cc<= }
+        T{ ##compare-integer-branch f 1 0 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -530,7 +628,7 @@ cpu x86.32? [
     {
         T{ ##load-integer f 1 100 }
         T{ ##load-integer f 2 200 }
-        T{ ##compare f 3 1 2 cc<= }
+        T{ ##compare-integer f 3 1 2 cc<= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -544,7 +642,7 @@ cpu x86.32? [
     {
         T{ ##load-integer f 1 100 }
         T{ ##load-integer f 2 200 }
-        T{ ##compare f 3 1 2 cc= }
+        T{ ##compare-integer f 3 1 2 cc= }
     } value-numbering-step trim-temps
 ] unit-test
 
@@ -556,90 +654,236 @@ cpu x86.32? [
 ] [
     {
         T{ ##load-integer f 1 100 }
-        T{ ##compare-imm f 2 1 f cc= }
+        T{ ##compare-integer-imm f 2 1 123 cc= }
     } value-numbering-step trim-temps
 ] unit-test
 
 [
     {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##load-reference f 3 f }
+    }
+] [
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##compare-integer f 3 1 2 cc= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##load-reference f 3 t }
+    }
+] [
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##compare-integer f 3 1 2 cc/= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##load-reference f 3 t }
+    }
+] [
+    {
+        T{ ##load-integer f 1 1 }
+        T{ ##load-integer f 2 2 }
+        T{ ##compare-integer f 3 1 2 cc< }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##load-reference f 3 f }
+    }
+] [
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-integer f 2 20 }
+        T{ ##compare-integer f 3 2 1 cc< }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
         T{ ##load-reference f 1 f }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc< }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 t }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc<= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 f }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc> }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 t }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc>= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 f }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc/= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-reference f 1 t }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##compare-integer f 1 0 0 cc= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##load-reference f 2 f }
+    }
+] [
+    {
+        T{ ##load-integer f 1 10 }
+        T{ ##compare-imm f 2 1 10 cc= }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##load-integer f 1 10 }
         T{ ##load-reference f 2 t }
     }
 ] [
-    {
-        T{ ##load-reference f 1 f }
-        T{ ##compare-imm f 2 1 f cc= }
-    } value-numbering-step trim-temps
-] unit-test
-
-[
     {
         T{ ##load-integer f 1 10 }
-        T{ ##load-integer f 2 20 }
-        T{ ##load-reference f 3 f }
-    }
-] [
-    {
-        T{ ##load-integer f 1 10 }
-        T{ ##load-integer f 2 20 }
-        T{ ##compare f 3 1 2 cc= }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##load-integer f 1 1 }
-        T{ ##load-integer f 2 2 }
-        T{ ##load-reference f 3 t }
-    }
-] [
-    {
-        T{ ##load-integer f 1 1 }
-        T{ ##load-integer f 2 2 }
-        T{ ##compare f 3 1 2 cc/= }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##load-integer f 1 1 }
-        T{ ##load-integer f 2 2 }
-        T{ ##load-reference f 3 t }
-    }
-] [
-    {
-        T{ ##load-integer f 1 1 }
-        T{ ##load-integer f 2 2 }
-        T{ ##compare f 3 1 2 cc< }
+        T{ ##compare-imm f 2 1 $[ 10 tag-fixnum ] cc= }
     } value-numbering-step
 ] unit-test
 
 [
     {
         T{ ##load-integer f 1 10 }
-        T{ ##load-integer f 2 20 }
-        T{ ##load-reference f 3 f }
+        T{ ##load-reference f 2 t }
     }
 ] [
     {
         T{ ##load-integer f 1 10 }
-        T{ ##load-integer f 2 20 }
-        T{ ##compare f 3 2 1 cc< }
+        T{ ##compare-imm f 2 1 10 cc/= }
     } value-numbering-step
 ] unit-test
 
 [
     {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 f }
+        T{ ##load-integer f 1 10 }
+        T{ ##load-reference f 2 f }
     }
 ] [
     {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc< }
+        T{ ##load-integer f 1 10 }
+        T{ ##compare-imm f 2 1 $[ 10 tag-fixnum ] cc/= }
     } value-numbering-step
 ] unit-test
 
+cpu x86.32? [
+    [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##load-reference f 2 f }
+        }
+    ] [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##compare-imm f 2 1 + cc/= }
+        } value-numbering-step
+    ] unit-test
+
+    [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##load-reference f 2 t }
+        }
+    ] [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##compare-imm f 2 1 * cc/= }
+        } value-numbering-step
+    ] unit-test
+
+    [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##load-reference f 2 t }
+        }
+    ] [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##compare-imm f 2 1 + cc= }
+        } value-numbering-step
+    ] unit-test
+
+    [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##load-reference f 2 f }
+        }
+    ] [
+        {
+            T{ ##load-reference f 1 + }
+            T{ ##compare-imm f 2 1 * cc= }
+        } value-numbering-step
+    ] unit-test
+] when
+
 [
     {
         T{ ##peek f 0 D 0 }
@@ -648,31 +892,7 @@ cpu x86.32? [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc<= }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 f }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc> }
-    } value-numbering-step
-] unit-test
-
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 t }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc>= }
+        T{ ##compare f 1 0 0 cc= }
     } value-numbering-step
 ] unit-test
 
@@ -688,18 +908,6 @@ cpu x86.32? [
     } value-numbering-step
 ] unit-test
 
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 t }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##compare f 1 0 0 cc= }
-    } value-numbering-step
-] unit-test
-
 ! Reassociation
 [
     {
@@ -1560,7 +1768,7 @@ cell 8 = [
     {
         T{ ##load-integer f 1 1 }
         T{ ##load-integer f 2 2 }
-        T{ ##compare-branch f 1 2 cc< }
+        T{ ##compare-integer-branch f 1 2 cc< }
     } test-branch-folding
 ] unit-test
 
@@ -1575,7 +1783,7 @@ cell 8 = [
     {
         T{ ##load-integer f 1 1 }
         T{ ##load-integer f 2 2 }
-        T{ ##compare-branch f 2 1 cc< }
+        T{ ##compare-integer-branch f 2 1 cc< }
     } test-branch-folding
 ] unit-test
 
@@ -1588,7 +1796,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc< }
+        T{ ##compare-integer-branch f 0 0 cc< }
     } test-branch-folding
 ] unit-test
 
@@ -1601,7 +1809,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc<= }
+        T{ ##compare-integer-branch f 0 0 cc<= }
     } test-branch-folding
 ] unit-test
 
@@ -1614,7 +1822,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc> }
+        T{ ##compare-integer-branch f 0 0 cc> }
     } test-branch-folding
 ] unit-test
 
@@ -1627,7 +1835,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc>= }
+        T{ ##compare-integer-branch f 0 0 cc>= }
     } test-branch-folding
 ] unit-test
 
@@ -1640,7 +1848,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc= }
+        T{ ##compare-integer-branch f 0 0 cc= }
     } test-branch-folding
 ] unit-test
 
@@ -1653,7 +1861,7 @@ cell 8 = [
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##compare-branch f 0 0 cc/= }
+        T{ ##compare-integer-branch f 0 0 cc/= }
     } test-branch-folding
 ] unit-test
 
@@ -1677,7 +1885,7 @@ V{ T{ ##branch } } 0 test-bb
 
 V{
     T{ ##peek f 0 D 0 }
-    T{ ##compare-branch f 0 0 cc< }
+    T{ ##compare-integer-branch f 0 0 cc< }
 } 1 test-bb
 
 V{
@@ -1718,7 +1926,7 @@ V{
 
 V{
     T{ ##peek f 1 D 1 }
-    T{ ##compare-branch f 1 1 cc< }
+    T{ ##compare-integer-branch f 1 1 cc< }
 } 1 test-bb
 
 V{
@@ -1816,4 +2024,3 @@ V{
 ] unit-test
 
 [ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
-
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index cc0754aba3..1e824dc706 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -119,7 +119,7 @@ CODEGEN: ##not %not
 CODEGEN: ##neg %neg
 CODEGEN: ##log2 %log2
 CODEGEN: ##copy %copy
-CODEGEN: ##tagged>integer %copy
+CODEGEN: ##tagged>integer %tagged>integer
 CODEGEN: ##add-float %add-float
 CODEGEN: ##sub-float %sub-float
 CODEGEN: ##mul-float %mul-float
@@ -210,6 +210,8 @@ CODEGEN: ##write-barrier %write-barrier
 CODEGEN: ##write-barrier-imm %write-barrier-imm
 CODEGEN: ##compare %compare
 CODEGEN: ##compare-imm %compare-imm
+CODEGEN: ##compare-integer %compare
+CODEGEN: ##compare-integer-imm %compare-imm
 CODEGEN: ##compare-float-ordered %compare-float-ordered
 CODEGEN: ##compare-float-unordered %compare-float-unordered
 CODEGEN: ##save-context %save-context
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index a98b5cbafb..57a04d4c65 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -253,6 +253,8 @@ HOOK: %log2    cpu ( dst src -- )
 
 HOOK: %copy cpu ( dst src rep -- )
 
+: %tagged>integer ( dst src -- ) int-rep %copy ;
+
 HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
 HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
 HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )

From 2ca8d543f14026f31649b2cfd5745c1848f81871 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 22 Apr 2010 18:02:56 -0400
Subject: [PATCH 104/158] compiler.cfg.instructions: more typos

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

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 11d7bfe93a..2108d2e2a8 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -542,7 +542,7 @@ temp: temp/int-rep ;
 
 PURE-INSN: ##box-displaced-alien
 def: dst/tagged-rep
-use: displacement/int-rep base/int-rep
+use: displacement/int-rep base/tagged-rep
 temp: temp/int-rep
 literal: base-class ;
 
@@ -665,7 +665,7 @@ def: dst/tagged-rep
 literal: offset ;
 
 INSN: ##set-vm-field
-use: src/int-rep
+use: src/tagged-rep
 literal: offset ;
 
 ! FFI

From 2ce926594d129a62f215025e7712908c6ef57524 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 Apr 2010 04:17:41 -0400
Subject: [PATCH 105/158] compiler.cfg.value-numbering: new optimizations;
 reassociation for shifts and redistribution for shifts/multiplies over
 additions/subtractions

---
 .../cfg/value-numbering/math/math.factor      |  73 ++++++-
 .../value-numbering-tests.factor              | 183 ++++++++++++++++++
 basis/cpu/architecture/architecture.factor    |   8 +-
 3 files changed, 257 insertions(+), 7 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/math/math.factor b/basis/compiler/cfg/value-numbering/math/math.factor
index bbc2d5a169..1ea2135db4 100644
--- a/basis/compiler/cfg/value-numbering/math/math.factor
+++ b/basis/compiler/cfg/value-numbering/math/math.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators cpu.architecture fry kernel layouts
-math sequences compiler.cfg.instructions
+locals make math sequences compiler.cfg.instructions
+compiler.cfg.registers
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.folding
 compiler.cfg.value-numbering.graph
@@ -9,10 +10,12 @@ compiler.cfg.value-numbering.rewrite
 compiler.cfg.value-numbering.simplify ;
 IN: compiler.cfg.value-numbering.math
 
+: f-expr? ( expr -- ? ) T{ reference-expr f f } = ;
+
 M: ##tagged>integer rewrite
     [ dst>> ] [ src>> vreg>expr ] bi {
         { [ dup integer-expr? ] [ value>> tag-fixnum \ ##load-integer new-insn ] }
-        { [ dup reference-expr? ] [ value>> [ drop f ] [ \ f type-number \ ##load-integer new-insn ] if ] }
+        { [ dup f-expr? ] [ \ f type-number \ ##load-integer new-insn ] }
         [ 2drop f ]
     } cond ;
 
@@ -22,13 +25,22 @@ M: ##neg rewrite
 M: ##not rewrite
     dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ;
 
-: reassociate ( insn -- dst src1 src2 )
+! Reassociation converts
+! ## *-imm 2 1 X
+! ## *-imm 3 2 Y
+! into
+! ## *-imm 3 1 (X $ Y)
+! If * is associative, then $ is the same operation as *.
+! In the case of shifts, $ is addition.
+: (reassociate) ( insn -- dst src1 src2' src2'' )
     {
         [ dst>> ]
         [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>integer ] bi ]
         [ src2>> ]
-        [ ]
-    } cleave binary-constant-fold* ;
+    } cleave ; inline
+
+: reassociate ( insn -- dst src1 src2 )
+    [ (reassociate) ] keep binary-constant-fold* ;
 
 : ?new-insn ( dst src1 src2 ? class -- insn/f )
     '[ _ new-insn ] [ 3drop f ] if ; inline
@@ -39,6 +51,9 @@ M: ##not rewrite
 : reassociate-bitwise ( insn new-insn -- insn/f )
     [ reassociate dup immediate-bitwise? ] dip ?new-insn ; inline
 
+: reassociate-shift ( insn new-insn -- insn/f )
+    [ (reassociate) + dup immediate-shift-count? ] dip ?new-insn ; inline
+
 M: ##add-imm rewrite
     {
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
@@ -56,24 +71,57 @@ M: ##sub-imm rewrite
         [ sub-imm>add-imm ]
     } cond ;
 
+! Convert ##mul-imm -1 => ##neg
 : mul-to-neg? ( insn -- ? )
     src2>> -1 = ;
 
 : mul-to-neg ( insn -- insn' )
     [ dst>> ] [ src1>> ] bi \ ##neg new-insn ;
 
+! Convert ##mul-imm 2^X => ##shl-imm X
 : mul-to-shl? ( insn -- ? )
     src2>> power-of-2? ;
 
 : mul-to-shl ( insn -- insn' )
     [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
 
+! Distribution converts
+! ##+-imm 2 1 X
+! ##*-imm 3 2 Y
+! Into
+! ##*-imm 4 1 Y
+! ##+-imm 3 4 X*Y
+! Where * is mul or shl, + is add or sub
+! Have to make sure that X*Y fits in an immediate
+:: (distribute) ( insn expr imm temp add-op mul-op -- new-insns/f )
+    imm immediate-arithmetic? [
+        [
+            temp expr src1>> vn>vreg insn src2>> mul-op execute
+            insn dst>> temp imm add-op execute
+        ] { } make
+    ] [ f ] if ;
+
+: distribute-over-add? ( insn -- ? )
+    src1>> vreg>expr add-imm-expr? ;
+
+: distribute-over-sub? ( insn -- ? )
+    src1>> vreg>expr sub-imm-expr? ;
+
+: distribute ( insn add-op mul-op -- new-insns/f )
+    [
+        dup src1>> vreg>expr
+        2dup src2>> vn>integer swap [ src2>> ] keep binary-constant-fold*
+        next-vreg
+    ] 2dip (distribute) ;
+
 M: ##mul-imm rewrite
     {
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
         { [ dup mul-to-neg? ] [ mul-to-neg ] }
         { [ dup mul-to-shl? ] [ mul-to-shl ] }
         { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate-arithmetic ] }
+        { [ dup distribute-over-add? ] [ \ ##add-imm \ ##mul-imm distribute ] }
+        { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##mul-imm distribute ] }
         [ drop f ]
     } cond ;
 
@@ -101,21 +149,31 @@ M: ##xor-imm rewrite
 M: ##shl-imm rewrite
     {
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        { [ dup src1>> vreg>expr shl-imm-expr? ] [ \ ##shl-imm reassociate-shift ] }
+        { [ dup distribute-over-add? ] [ \ ##add-imm \ ##shl-imm distribute ] }
+        { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##shl-imm distribute ] }
         [ drop f ]
     } cond ;
 
 M: ##shr-imm rewrite
     {
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        { [ dup src1>> vreg>expr shr-imm-expr? ] [ \ ##shr-imm reassociate-shift ] }
         [ drop f ]
     } cond ;
 
 M: ##sar-imm rewrite
     {
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
+        { [ dup src1>> vreg>expr sar-imm-expr? ] [ \ ##sar-imm reassociate-shift ] }
         [ drop f ]
     } cond ;
 
+! Convert
+! ##load-integer 2 X
+! ##* 3 1 2
+! Where * is an operation with an -imm equivalent into
+! ##*-imm 3 1 X
 : insn>imm-insn ( insn op swap? -- new-insn )
     swap [
         [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
@@ -129,12 +187,17 @@ M: ##add rewrite
         [ drop f ]
     } cond ;
 
+! ##sub 2 1 1 => ##load-integer 2 0
 : subtraction-identity? ( insn -- ? )
     [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ;
 
 : rewrite-subtraction-identity ( insn -- insn' )
     dst>> 0 \ ##load-integer new-insn ;
 
+! ##load-integer 1 0
+! ##sub 3 1 2
+! =>
+! ##neg 3 2
 : sub-to-neg? ( ##sub -- ? )
     src1>> vn>expr expr-zero? ;
 
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index f18f00aa76..bdf8b330af 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -1125,6 +1125,189 @@ cpu x86.32? [
     } value-numbering-step
 ] unit-test
 
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shl-imm f 1 0 10 }
+        T{ ##shl-imm f 2 0 21 }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shl-imm f 1 0 10 }
+        T{ ##shl-imm f 2 1 11 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shl-imm f 1 0 10 }
+        T{ ##shl-imm f 2 1 $[ cell-bits 1 - ] }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shl-imm f 1 0 10 }
+        T{ ##shl-imm f 2 1 $[ cell-bits 1 - ] }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##sar-imm f 1 0 10 }
+        T{ ##sar-imm f 2 0 21 }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##sar-imm f 1 0 10 }
+        T{ ##sar-imm f 2 1 11 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##sar-imm f 1 0 10 }
+        T{ ##sar-imm f 2 1 $[ cell-bits 1 - ] }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##sar-imm f 1 0 10 }
+        T{ ##sar-imm f 2 1 $[ cell-bits 1 - ] }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shr-imm f 1 0 10 }
+        T{ ##shr-imm f 2 0 21 }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shr-imm f 1 0 10 }
+        T{ ##shr-imm f 2 1 11 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shr-imm f 1 0 10 }
+        T{ ##shr-imm f 2 1 $[ cell-bits 1 - ] }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shr-imm f 1 0 10 }
+        T{ ##shr-imm f 2 1 $[ cell-bits 1 - ] }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shr-imm f 1 0 10 }
+        T{ ##sar-imm f 2 1 11 }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shr-imm f 1 0 10 }
+        T{ ##sar-imm f 2 1 11 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+! Distributive law
+2 \ vreg-counter set-global
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##add-imm f 1 0 10 }
+        T{ ##shl-imm f 3 0 2 }
+        T{ ##add-imm f 2 3 40 }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##add-imm f 1 0 10 }
+        T{ ##shl-imm f 2 1 2 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##add-imm f 1 0 10 }
+        T{ ##mul-imm f 4 0 3 }
+        T{ ##add-imm f 2 4 30 }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##add-imm f 1 0 10 }
+        T{ ##mul-imm f 2 1 3 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##add-imm f 1 0 -10 }
+        T{ ##shl-imm f 5 0 2 }
+        T{ ##add-imm f 2 5 -40 }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##sub-imm f 1 0 10 }
+        T{ ##shl-imm f 2 1 2 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##add-imm f 1 0 -10 }
+        T{ ##mul-imm f 6 0 3 }
+        T{ ##add-imm f 2 6 -30 }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##sub-imm f 1 0 10 }
+        T{ ##mul-imm f 2 1 3 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
 ! Simplification
 [
     {
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 57a04d4c65..a2e5050edf 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs generic kernel kernel.private
-math memory namespaces make sequences layouts system hashtables
-classes alien byte-arrays combinators words sets fry ;
+math math.order memory namespaces make sequences layouts system
+hashtables classes alien byte-arrays combinators words sets fry
+;
 IN: cpu.architecture
 
 ! Representations -- these are like low-level types
@@ -523,6 +524,9 @@ M: object immediate-comparand? ( n -- ? )
         [ drop f ]
     } cond ;
 
+: immediate-shift-count? ( n -- ? )
+    0 cell-bits 1 - between? ;
+
 ! What c-type describes the implicit struct return pointer for
 ! large structs?
 HOOK: struct-return-pointer-type cpu ( -- c-type )

From e95cd256ec093a0768a730fb70114c8c1d97d143 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 Apr 2010 04:18:31 -0400
Subject: [PATCH 106/158] compiler.cfg.representations: peephole optimizations
 are used to simplify the case where the input to a ##shl-imm or ##sar-imm
 needs to be untagged

---
 .../cfg/representations/peephole/authors.txt  |   1 +
 .../representations/peephole/peephole.factor  | 115 ++++++++++++++++++
 .../representations-tests.factor              |  78 +++++++++++-
 .../representations/representations.factor    |  14 ++-
 .../representations/rewrite/rewrite.factor    |  85 +++----------
 5 files changed, 220 insertions(+), 73 deletions(-)
 create mode 100644 basis/compiler/cfg/representations/peephole/authors.txt
 create mode 100644 basis/compiler/cfg/representations/peephole/peephole.factor

diff --git a/basis/compiler/cfg/representations/peephole/authors.txt b/basis/compiler/cfg/representations/peephole/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/representations/peephole/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/representations/peephole/peephole.factor b/basis/compiler/cfg/representations/peephole/peephole.factor
new file mode 100644
index 0000000000..94f9dd8aeb
--- /dev/null
+++ b/basis/compiler/cfg/representations/peephole/peephole.factor
@@ -0,0 +1,115 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.short-circuit kernel
+layouts math namespaces cpu.architecture
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.representations.rewrite ;
+IN: compiler.cfg.representations.peephole
+
+! Representation selection performs some peephole optimizations
+! when inserting conversions to optimize for a few common cases
+
+M: ##load-integer conversions-for-insn
+    {
+        {
+            [ dup dst>> rep-of tagged-rep? ]
+            [ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+! When a float is unboxed, we replace the ##load-reference with a ##load-double
+! if the architecture supports it
+: convert-to-load-double? ( insn -- ? )
+    {
+        [ drop load-double? ]
+        [ dst>> rep-of double-rep? ]
+        [ obj>> float? ]
+    } 1&& ;
+
+! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
+! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
+: convert-to-zero-vector? ( insn -- ? )
+    {
+        [ dst>> rep-of vector-rep? ]
+        [ obj>> B{ 0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 } = ]
+    } 1&& ;
+
+: convert-to-fill-vector? ( insn -- ? )
+    {
+        [ dst>> rep-of vector-rep? ]
+        [ obj>> B{ 255 255 255 255  255 255 255 255  255 255 255 255  255 255 255 255 } = ]
+    } 1&& ;
+
+: (convert-to-load-double) ( insn -- dst val )
+    [ dst>> ] [ obj>> ] bi ; inline
+
+: (convert-to-zero/fill-vector) ( insn -- dst rep )
+    dst>> dup rep-of ; inline
+
+M: ##load-reference conversions-for-insn
+    {
+        {
+            [ dup convert-to-load-double? ]
+            [ (convert-to-load-double) ##load-double ]
+        }
+        {
+            [ dup convert-to-zero-vector? ]
+            [ (convert-to-zero/fill-vector) ##zero-vector ]
+        }
+        {
+            [ dup convert-to-fill-vector? ]
+            [ (convert-to-zero/fill-vector) ##fill-vector ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+! Optimize this:
+! ##sar-imm temp src tag-bits
+! ##shl-imm dst temp X
+! Into either
+! ##shl-imm by X - tag-bits, or
+! ##sar-imm by tag-bits - X.
+: combine-shl-imm? ( insn -- ? )
+    src1>> rep-of tagged-rep? ;
+
+: combine-shl-imm ( insn -- )
+    [ dst>> ] [ src1>> ] [ src2>> ] tri tag-bits get {
+        { [ 2dup < ] [ swap - ##sar-imm ] }
+        { [ 2dup > ] [ - ##shl-imm ] }
+        [ 2drop int-rep ##copy ]
+    } cond ;
+
+M: ##shl-imm conversions-for-insn
+    {
+        {
+            [ dup combine-shl-imm? ]
+            [ [ combine-shl-imm ] [ emit-def-conversion ] bi ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+! Optimize this:
+! ##sar-imm temp src tag-bits
+! ##sar-imm dst temp X
+! Into
+! ##sar-imm by X + tag-bits
+! assuming X + tag-bits is a valid shift count.
+: combine-sar-imm? ( insn -- ? )
+    {
+        [ src1>> rep-of tagged-rep? ]
+        [ src2>> tag-bits get + immediate-shift-count? ]
+    } 1&& ;
+
+: combine-sar-imm ( insn -- )
+    [ dst>> ] [ src1>> ] [ src2>> tag-bits get + ] tri ##sar-imm ;
+
+M: ##sar-imm conversions-for-insn
+    {
+        {
+            [ dup combine-sar-imm? ]
+            [ [ combine-sar-imm ] [ emit-def-conversion ] bi ]
+        }
+        [ call-next-method ]
+    } cond ;
diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor
index 35e56f5489..fb03dfa2ea 100644
--- a/basis/compiler/cfg/representations/representations-tests.factor
+++ b/basis/compiler/cfg/representations/representations-tests.factor
@@ -1,7 +1,8 @@
 USING: accessors compiler.cfg compiler.cfg.debugger
 compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.representations.preferred cpu.architecture kernel
-namespaces tools.test sequences arrays system literals layouts ;
+namespaces tools.test sequences arrays system literals layouts
+math ;
 IN: compiler.cfg.representations
 
 [ { double-rep double-rep } ] [
@@ -177,4 +178,77 @@ cpu x86.32? [
     [ t ] [ 3 get instructions>> first ##load-double? ] unit-test
 
     [ t ] [ 4 get instructions>> first ##phi? ] unit-test
-] when
\ No newline at end of file
+] when
+
+! Peephole optimization if input to ##shl-imm is tagged
+
+3 \ vreg-counter set-global
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##shl-imm f 2 1 3 }
+    T{ ##replace f 2 D 0 }
+} 0 test-bb
+
+[ ] [ test-representations ] unit-test
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##sar-imm f 2 1 1 }
+        T{ ##shl-imm f 4 2 $[ tag-bits get ] }
+        T{ ##replace f 4 D 0 }
+    }
+] [ 0 get instructions>> ] unit-test
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##shl-imm f 2 1 10 }
+    T{ ##replace f 2 D 0 }
+} 0 test-bb
+
+[ ] [ test-representations ] unit-test
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##shl-imm f 2 1 $[ 10 tag-bits get - ] }
+        T{ ##shl-imm f 5 2 $[ tag-bits get ] }
+        T{ ##replace f 5 D 0 }
+    }
+] [ 0 get instructions>> ] unit-test
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##shl-imm f 2 1 $[ tag-bits get ] }
+    T{ ##replace f 2 D 0 }
+} 0 test-bb
+
+[ ] [ test-representations ] unit-test
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##copy f 2 1 int-rep }
+        T{ ##shl-imm f 6 2 $[ tag-bits get ] }
+        T{ ##replace f 6 D 0 }
+    }
+] [ 0 get instructions>> ] unit-test
+
+! Peephole optimization if input to ##sar-imm is tagged
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##sar-imm f 2 1 3 }
+    T{ ##replace f 2 D 0 }
+} 0 test-bb
+
+[ ] [ test-representations ] unit-test
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##sar-imm f 2 1 $[ 3 tag-bits get + ] }
+        T{ ##shl-imm f 7 2 $[ tag-bits get ] }
+        T{ ##replace f 7 D 0 }
+    }
+] [ 0 get instructions>> ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor
index d4c500291e..22184ca284 100644
--- a/basis/compiler/cfg/representations/representations.factor
+++ b/basis/compiler/cfg/representations/representations.factor
@@ -1,12 +1,18 @@
 ! Copyright (C) 2009, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators compiler.cfg
-compiler.cfg.loop-detection compiler.cfg.registers
+USING: accessors combinators namespaces
+compiler.cfg
+compiler.cfg.registers
+compiler.cfg.loop-detection
 compiler.cfg.representations.rewrite
-compiler.cfg.representations.selection namespaces ;
+compiler.cfg.representations.peephole
+compiler.cfg.representations.selection ;
 IN: compiler.cfg.representations
 
-! Virtual register representation selection.
+! Virtual register representation selection. This is where
+! decisions about integer tagging and float and vector boxing
+! are made. The appropriate conversion operations inserted
+! after a cost analysis.
 
 : select-representations ( cfg -- cfg' )
     needs-loops
diff --git a/basis/compiler/cfg/representations/rewrite/rewrite.factor b/basis/compiler/cfg/representations/rewrite/rewrite.factor
index d5afe1faa2..5b15e95c15 100644
--- a/basis/compiler/cfg/representations/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/representations/rewrite/rewrite.factor
@@ -19,14 +19,14 @@ IN: compiler.cfg.representations.rewrite
 ! Mapping from vreg,rep pairs to vregs
 SYMBOL: alternatives
 
-:: emit-def-conversion ( dst preferred required -- new-dst' )
+:: (emit-def-conversion) ( dst preferred required -- new-dst' )
     ! If an instruction defines a register with representation 'required',
     ! but the register has preferred representation 'preferred', then
     ! we rename the instruction's definition to a new register, which
     ! becomes the input of a conversion instruction.
     dst required next-vreg-rep [ preferred required emit-conversion ] keep ;
 
-:: emit-use-conversion ( src preferred required -- new-src' )
+:: (emit-use-conversion) ( src preferred required -- new-src' )
     ! If an instruction uses a register with representation 'required',
     ! but the register has preferred representation 'preferred', then
     ! we rename the instruction's input to a new register, which
@@ -43,7 +43,7 @@ SYMBOLS: renaming-set needs-renaming? ;
 
 : init-renaming-set ( -- )
     needs-renaming? off
-    V{ } clone renaming-set set ;
+    renaming-set get delete-all ;
 
 : no-renaming ( vreg -- )
     dup 2array renaming-set get push ;
@@ -57,14 +57,11 @@ SYMBOLS: renaming-set needs-renaming? ;
     [ vreg no-renaming ]
     [ vreg vreg preferred required quot call record-renaming ] if ; inline
 
-: compute-renaming-set ( insn -- )
-    ! temp vregs don't need conversions since they're always in their
-    ! preferred representation
-    init-renaming-set
-    [ [ [ emit-use-conversion ] (compute-renaming-set) ] each-use-rep ]
-    [ , ]
-    [ [ [ emit-def-conversion ] (compute-renaming-set) ] each-def-rep ]
-    tri ;
+: emit-use-conversion ( insn -- )
+    [ [ (emit-use-conversion) ] (compute-renaming-set) ] each-use-rep ;
+
+: emit-def-conversion ( insn -- )
+    [ [ (emit-def-conversion) ] (compute-renaming-set) ] each-def-rep ;
 
 : converted-value ( vreg -- vreg' )
     renaming-set get pop first2 [ assert= ] dip ;
@@ -78,67 +75,20 @@ RENAMING: convert [ converted-value ] [ converted-value ] [ ]
         renaming-set get length 0 assert=
     ] [ drop ] if ;
 
+: with-conversions ( insn -- quot )
+    init-renaming-set [ perform-renaming ] bi ; inline
+
 GENERIC: conversions-for-insn ( insn -- )
 
 M: ##phi conversions-for-insn , ;
 
-M: ##load-integer conversions-for-insn
-    {
-        {
-            [ dup dst>> rep-of tagged-rep? ]
-            [ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged ]
-        }
-        [ call-next-method ]
-    } cond ;
-
-! When a float is unboxed, we replace the ##load-reference with a ##load-double
-! if the architecture supports it
-: convert-to-load-double? ( insn -- ? )
-    {
-        [ drop load-double? ]
-        [ dst>> rep-of double-rep? ]
-        [ obj>> float? ]
-    } 1&& ;
-
-! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
-! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
-: convert-to-zero-vector? ( insn -- ? )
-    {
-        [ dst>> rep-of vector-rep? ]
-        [ obj>> B{ 0 0 0 0  0 0 0 0  0 0 0 0  0 0 0 0 } = ]
-    } 1&& ;
-
-: convert-to-fill-vector? ( insn -- ? )
-    {
-        [ dst>> rep-of vector-rep? ]
-        [ obj>> B{ 255 255 255 255  255 255 255 255  255 255 255 255  255 255 255 255 } = ]
-    } 1&& ;
-
-: (convert-to-load-double) ( insn -- dst val )
-    [ dst>> ] [ obj>> ] bi ; inline
-
-: (convert-to-zero/fill-vector) ( insn -- dst rep )
-    dst>> dup rep-of ; inline
-
-M: ##load-reference conversions-for-insn
-    {
-        {
-            [ dup convert-to-load-double? ]
-            [ (convert-to-load-double) ##load-double ]
-        }
-        {
-            [ dup convert-to-zero-vector? ]
-            [ (convert-to-zero/fill-vector) ##zero-vector ]
-        }
-        {
-            [ dup convert-to-fill-vector? ]
-            [ (convert-to-zero/fill-vector) ##fill-vector ]
-        }
-        [ call-next-method ]
-    } cond ;
-
 M: vreg-insn conversions-for-insn
-    [ compute-renaming-set ] [ perform-renaming ] bi ;
+    [
+        [ emit-use-conversion ]
+        [ , ]
+        [ emit-def-conversion ]
+        tri
+    ] with-conversions ;
 
 M: insn conversions-for-insn , ;
 
@@ -153,4 +103,5 @@ M: insn conversions-for-insn , ;
     ] if ;
 
 : insert-conversions ( cfg -- )
+    V{ } clone renaming-set set
     [ conversions-for-block ] each-basic-block ;

From efd2a80d98dc44b3e418feefd9736dac5e3cd798 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 Apr 2010 04:23:32 -0400
Subject: [PATCH 107/158] compiler.cfg.value-numbering: fix compile error

---
 basis/compiler/cfg/value-numbering/math/math.factor         | 6 +++---
 .../cfg/value-numbering/value-numbering-tests.factor        | 2 +-
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/math/math.factor b/basis/compiler/cfg/value-numbering/math/math.factor
index 1ea2135db4..742e995f1d 100644
--- a/basis/compiler/cfg/value-numbering/math/math.factor
+++ b/basis/compiler/cfg/value-numbering/math/math.factor
@@ -15,7 +15,7 @@ IN: compiler.cfg.value-numbering.math
 M: ##tagged>integer rewrite
     [ dst>> ] [ src>> vreg>expr ] bi {
         { [ dup integer-expr? ] [ value>> tag-fixnum \ ##load-integer new-insn ] }
-        { [ dup f-expr? ] [ \ f type-number \ ##load-integer new-insn ] }
+        { [ dup f-expr? ] [ drop \ f type-number \ ##load-integer new-insn ] }
         [ 2drop f ]
     } cond ;
 
@@ -99,7 +99,7 @@ M: ##sub-imm rewrite
             temp expr src1>> vn>vreg insn src2>> mul-op execute
             insn dst>> temp imm add-op execute
         ] { } make
-    ] [ f ] if ;
+    ] [ f ] if ; inline
 
 : distribute-over-add? ( insn -- ? )
     src1>> vreg>expr add-imm-expr? ;
@@ -112,7 +112,7 @@ M: ##sub-imm rewrite
         dup src1>> vreg>expr
         2dup src2>> vn>integer swap [ src2>> ] keep binary-constant-fold*
         next-vreg
-    ] 2dip (distribute) ;
+    ] 2dip (distribute) ; inline
 
 M: ##mul-imm rewrite
     {
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index bdf8b330af..035b23d976 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -1624,7 +1624,7 @@ cell 8 = [
 ] [
     {
         T{ ##load-reference f 1 f }
-        T{ ##load-integer f 2 1 }
+        T{ ##tagged>integer f 2 1 }
         T{ ##and-imm f 3 2 15 }
     } value-numbering-step
 ] unit-test

From c81063614bdfcc4cd346d280853ede84aa1779cd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 Apr 2010 04:25:40 -0400
Subject: [PATCH 108/158] compiler.tests.low-level-ir: update for recent
 changes

---
 basis/compiler/tests/low-level-ir.factor | 18 ++++++------------
 1 file changed, 6 insertions(+), 12 deletions(-)

diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index 5f00d251cf..ca02e80922 100644
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -34,12 +34,6 @@ IN: compiler.tests.low-level-ir
     execute( -- result ) ;
 
 ! loading constants
-[ f ] [
-    V{
-        T{ ##load-constant f 0 f }
-    } compile-test-bb
-] unit-test
-
 [ "hello" ] [
     V{
         T{ ##load-reference f 0 "hello" }
@@ -50,7 +44,7 @@ IN: compiler.tests.low-level-ir
 ! one of the sources
 [ t ] [
     V{
-        T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
+        T{ ##load-tagged f 1 $[ 2 cell log2 shift array type-number - ] }
         T{ ##load-reference f 0 { t f t } }
         T{ ##slot f 0 0 1 }
     } compile-test-bb
@@ -65,7 +59,7 @@ IN: compiler.tests.low-level-ir
 
 [ t ] [
     V{
-        T{ ##load-immediate f 1 $[ 2 cell log2 shift array type-number - ] }
+        T{ ##load-tagged f 1 $[ 2 cell log2 shift array type-number - ] }
         T{ ##load-reference f 0 { t f t } }
         T{ ##set-slot f 0 0 1 }
     } compile-test-bb
@@ -82,14 +76,14 @@ IN: compiler.tests.low-level-ir
 
 [ 4 ] [
     V{
-        T{ ##load-immediate f 0 4 }
+        T{ ##load-tagged f 0 4 }
         T{ ##shl f 0 0 0 }
     } compile-test-bb
 ] unit-test
 
 [ 4 ] [
     V{
-        T{ ##load-immediate f 0 4 }
+        T{ ##load-tagged f 0 4 }
         T{ ##shl-imm f 0 0 4 }
     } compile-test-bb
 ] unit-test
@@ -106,7 +100,7 @@ IN: compiler.tests.low-level-ir
 [ CHAR: l ] [
     V{
         T{ ##load-reference f 0 "hello world" }
-        T{ ##load-immediate f 1 3 }
+        T{ ##load-tagged f 1 3 }
         T{ ##string-nth f 0 0 1 2 }
         T{ ##shl-imm f 0 0 4 }
     } compile-test-bb
@@ -114,7 +108,7 @@ IN: compiler.tests.low-level-ir
 
 [ 1 ] [
     V{
-        T{ ##load-immediate f 0 32 }
+        T{ ##load-tagged f 0 32 }
         T{ ##add-imm f 0 0 -16 }
     } compile-test-bb
 ] unit-test

From 279eb461b1c67e9869ce6911560dbd2e6553fe46 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 Apr 2010 06:48:58 -0400
Subject: [PATCH 109/158] compiler.cfg: remove ##set-string-nth-fast
 instruction since it can be expressed just as efficiently using other
 instructions

---
 basis/compiler/cfg/instructions/instructions.factor |  4 ----
 basis/compiler/cfg/intrinsics/intrinsics.factor     |  1 +
 basis/compiler/cfg/intrinsics/slots/slots.factor    |  6 ------
 basis/compiler/cfg/intrinsics/strings/authors.txt   |  1 +
 .../compiler/cfg/intrinsics/strings/strings.factor  | 13 +++++++++++++
 basis/compiler/codegen/codegen.factor               |  1 -
 basis/cpu/architecture/architecture.factor          |  1 -
 basis/cpu/ppc/ppc.factor                            |  4 ----
 basis/cpu/x86/x86.factor                            |  7 -------
 9 files changed, 15 insertions(+), 23 deletions(-)
 create mode 100644 basis/compiler/cfg/intrinsics/strings/authors.txt
 create mode 100644 basis/compiler/cfg/intrinsics/strings/strings.factor

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 2108d2e2a8..63b4ee22e3 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -93,10 +93,6 @@ def: dst/int-rep
 use: obj/tagged-rep index/int-rep
 temp: temp/int-rep ;
 
-INSN: ##set-string-nth-fast
-use: src/int-rep obj/tagged-rep index/int-rep
-temp: temp/int-rep ;
-
 ! Register transfers
 PURE-INSN: ##copy
 def: dst
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 535bcf4f7f..9f5167e116 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -9,6 +9,7 @@ compiler.cfg.intrinsics.allot
 compiler.cfg.intrinsics.fixnum
 compiler.cfg.intrinsics.float
 compiler.cfg.intrinsics.slots
+compiler.cfg.intrinsics.strings
 compiler.cfg.intrinsics.misc
 compiler.cfg.comparisons ;
 QUALIFIED: alien
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index 5203c8535c..1ec648b908 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -74,9 +74,3 @@ IN: compiler.cfg.intrinsics.slots
         dup third immediate-slot-offset?
         [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
     ] [ drop emit-primitive ] if ;
-
-: emit-string-nth ( -- )
-    2inputs swap ^^string-nth ds-push ;
-
-: emit-set-string-nth-fast ( -- )
-    3inputs swap next-vreg ##set-string-nth-fast ;
diff --git a/basis/compiler/cfg/intrinsics/strings/authors.txt b/basis/compiler/cfg/intrinsics/strings/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/intrinsics/strings/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/intrinsics/strings/strings.factor b/basis/compiler/cfg/intrinsics/strings/strings.factor
new file mode 100644
index 0000000000..40c54bdfdc
--- /dev/null
+++ b/basis/compiler/cfg/intrinsics/strings/strings.factor
@@ -0,0 +1,13 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel compiler.constants compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.stacks ;
+IN: compiler.cfg.intrinsics.strings
+
+: emit-string-nth ( -- )
+    2inputs swap ^^string-nth ds-push ;
+
+: emit-set-string-nth-fast ( -- )
+    3inputs ^^tagged>integer ^^add swap [ string-offset ] dip
+    ##set-alien-integer-1 ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 1e824dc706..a88c9a726f 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -94,7 +94,6 @@ CODEGEN: ##slot-imm %slot-imm
 CODEGEN: ##set-slot %set-slot
 CODEGEN: ##set-slot-imm %set-slot-imm
 CODEGEN: ##string-nth %string-nth
-CODEGEN: ##set-string-nth-fast %set-string-nth-fast
 CODEGEN: ##add %add
 CODEGEN: ##add-imm %add-imm
 CODEGEN: ##sub %sub
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index a2e5050edf..ab335ba188 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -226,7 +226,6 @@ HOOK: %set-slot cpu ( src obj slot -- )
 HOOK: %set-slot-imm cpu ( src obj slot tag -- )
 
 HOOK: %string-nth cpu ( dst obj index temp -- )
-HOOK: %set-string-nth-fast cpu ( ch obj index temp -- )
 
 HOOK: %add     cpu ( dst src1 src2 -- )
 HOOK: %add-imm cpu ( dst src1 src2 -- )
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 6f9354a767..3c23ae1b5f 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -160,10 +160,6 @@ M:: ppc %string-nth ( dst src index temp -- )
         "end" resolve-label
     ] with-scope ;
 
-M:: ppc %set-string-nth-fast ( ch obj index temp -- )
-    temp obj index ADD
-    ch temp string-offset STB ;
-
 M: ppc %add     ADD ;
 M: ppc %add-imm ADDI ;
 M: ppc %sub     swap SUBF ;
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index fe2f0da02d..8e57f36be9 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -354,13 +354,6 @@ M:: x86 %string-nth ( dst src index temp -- )
         dst new-dst int-rep %copy
     ] with-small-register ;
 
-M:: x86 %set-string-nth-fast ( ch str index temp -- )
-    ch { index str temp } 8 [| new-ch |
-        new-ch ch int-rep %copy
-        temp str index [+] LEA
-        temp string-offset [+] new-ch 8-bit-version-of MOV
-    ] with-small-register ;
-
 :: %alien-integer-getter ( dst src offset size quot -- )
     dst { src } size [| new-dst |
         new-dst dup size n-bit-version-of dup src offset [+] MOV

From 0ddaba8adba9da87dfb62d692fbc29a81f16e97f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 Apr 2010 07:43:36 -0400
Subject: [PATCH 110/158] benchmark.yuv-to-rgb: use TYPED: instead of HINTS:

---
 extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor | 13 ++++++-------
 1 file changed, 6 insertions(+), 7 deletions(-)

diff --git a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor
index b182b4f832..4a5a0285fc 100644
--- a/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor
+++ b/extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor
@@ -1,11 +1,12 @@
 ! Copyright (C) Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.accessors alien.c-types alien.syntax byte-arrays
-destructors generalizations hints kernel libc locals math math.order
-sequences sequences.private classes.struct accessors alien.data ;
+destructors generalizations kernel libc locals math math.order
+sequences sequences.private classes.struct accessors alien.data
+typed ;
 IN: benchmark.yuv-to-rgb
 
-STRUCT: yuv_buffer
+STRUCT: yuv-buffer
     { y_width int }
     { y_height int }
     { y_stride int }
@@ -19,7 +20,7 @@ STRUCT: yuv_buffer
 :: fake-data ( -- rgb yuv )
     1600 :> w
     1200 :> h
-    yuv_buffer <struct> :> buffer
+    yuv-buffer <struct> :> buffer
     w h * 3 * <byte-array> :> rgb
     rgb buffer
         w >>y_width
@@ -79,14 +80,12 @@ STRUCT: yuv_buffer
     pick y_width>> iota
     [ yuv>rgb-pixel ] with with with with each ; inline
 
-: yuv>rgb ( rgb yuv -- )
+TYPED: yuv>rgb ( rgb: byte-array yuv: yuv-buffer -- )
     [ 0 ] 2dip
     dup y_height>> iota
     [ yuv>rgb-row ] with with each
     drop ;
 
-HINTS: yuv>rgb byte-array yuv_buffer ;
-
 : yuv>rgb-benchmark ( -- )
     [ fake-data yuv>rgb ] with-destructors ;
 

From 913b95192ebcd33c009e80af18a9969e118909b4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 Apr 2010 18:42:09 -0400
Subject: [PATCH 111/158] compiler.cfg: merge all alien accessors into
 ##load-memory-imm and ##store-memory-imm

---
 .../compiler/cfg/builder/builder-tests.factor |  20 ++-
 .../cfg/instructions/instructions.factor      |  91 ++------------
 .../cfg/intrinsics/alien/alien.factor         | 116 +++++++-----------
 .../compiler/cfg/intrinsics/intrinsics.factor |  37 +++---
 .../compiler/cfg/intrinsics/misc/misc.factor  |   5 +-
 .../intrinsics/simd/backend/backend.factor    |   2 +-
 .../compiler/cfg/intrinsics/simd/simd.factor  |  14 +--
 .../cfg/intrinsics/strings/strings.factor     |   8 +-
 .../conversion/conversion.factor              |  14 +--
 .../representations-tests.factor              |  34 ++++-
 .../cfg/value-numbering/alien/alien.factor    |  19 +--
 .../cfg/value-numbering/simd/simd.factor      |   3 -
 .../value-numbering-tests.factor              |  38 ++++++
 .../value-numbering/value-numbering.factor    |   2 +-
 basis/compiler/codegen/codegen.factor         |  19 +--
 basis/compiler/tests/low-level-ir.factor      |   4 +-
 basis/cpu/architecture/architecture.factor    |  20 +--
 basis/cpu/x86/x86.factor                      |  63 +++++-----
 18 files changed, 221 insertions(+), 288 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index b2c05edf73..d28d7920ac 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -172,17 +172,29 @@ IN: compiler.cfg.builder.tests
 
 [ t ] [
     [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
-    [ ##set-alien-integer-1? ] contains-insn?
+    [ ##store-memory-imm? ] contains-insn?
 ] unit-test
 
 [ t ] [
     [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
-    [ ##set-alien-integer-1? ] contains-insn?
+    [ ##store-memory-imm? ] contains-insn?
 ] unit-test
 
 [ f ] [
     [ { byte-array fixnum } declare set-alien-unsigned-1 ]
-    [ ##set-alien-integer-1? ] contains-insn?
+    [ ##store-memory-imm? ] contains-insn?
+] unit-test
+
+[ t t ] [
+    [ { byte-array fixnum } declare alien-cell ]
+    [ [ ##load-memory-imm? ] contains-insn? ]
+    [ [ ##box-alien? ] contains-insn? ]
+    bi
+] unit-test
+
+[ f ] [
+    [ { byte-array integer } declare alien-cell ]
+    [ ##load-memory-imm? ] contains-insn?
 ] unit-test
 
 [ f ] [
@@ -209,7 +221,7 @@ IN: compiler.cfg.builder.tests
         [ [ ##allot? ] contains-insn? ] bi
     ] unit-test
     
-    [ 1 ] [ [ dup float+ ] [ ##alien-double? ] count-insns ] unit-test
+    [ 1 ] [ [ dup float+ ] [ ##load-memory-imm? ] count-insns ] unit-test
 ] when
 
 ! Regression. Make sure everything is inlined correctly
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 63b4ee22e3..4023247b82 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -550,92 +550,15 @@ PURE-INSN: ##unbox-alien
 def: dst/int-rep
 use: src/tagged-rep ;
 
-! Alien accessors
-INSN: ##alien-unsigned-1
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-unsigned-2
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-unsigned-4
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-1
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-2
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-signed-4
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-cell
-def: dst/int-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-float
-def: dst/float-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-double
-def: dst/double-rep
-use: src/int-rep
-literal: offset ;
-
-INSN: ##alien-vector
+! Raw memory accessors
+INSN: ##load-memory-imm
 def: dst
-use: src/int-rep
-literal: offset rep ;
+use: base/int-rep
+literal: offset rep c-type ;
 
-INSN: ##set-alien-integer-1
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
-
-INSN: ##set-alien-integer-2
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
-
-INSN: ##set-alien-integer-4
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
-
-INSN: ##set-alien-cell
-use: src/int-rep
-literal: offset
-use: value/int-rep ;
-
-INSN: ##set-alien-float
-use: src/int-rep
-literal: offset
-use: value/float-rep ;
-
-INSN: ##set-alien-double
-use: src/int-rep
-literal: offset
-use: value/double-rep ;
-
-INSN: ##set-alien-vector
-use: src/int-rep
-literal: offset
-use: value
-literal: rep ;
+INSN: ##store-memory-imm
+use: src base/int-rep
+literal: offset rep c-type ;
 
 ! Memory allocation
 INSN: ##allot
diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor
index 452a48ea54..23143b2f86 100644
--- a/basis/compiler/cfg/intrinsics/alien/alien.factor
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences alien math classes.algebra fry
 locals combinators combinators.short-circuit cpu.architecture
@@ -22,96 +22,66 @@ IN: compiler.cfg.intrinsics.alien
         ] binary-op
     ] [ emit-primitive ] if ;
 
-:: inline-alien ( node quot test -- )
+:: inline-accessor ( node quot test -- )
     node node-input-infos :> infos
     infos test call
     [ infos quot call ]
     [ node emit-primitive ] if ; inline
 
-: inline-alien-getter? ( infos -- ? )
+: inline-load-memory? ( infos -- ? )
     [ first class>> c-ptr class<= ]
     [ second class>> fixnum class<= ]
     bi and ;
 
-: prepare-alien-accessor ( info -- ptr-vreg offset )
-    class>> [ 2inputs swap ] dip ^^unbox-c-ptr ^^add 0 ;
+: prepare-accessor ( base offset info -- base offset )
+    class>> swap [ ^^unbox-c-ptr ] dip ^^add 0 ;
 
-: prepare-alien-getter ( infos -- ptr-vreg offset )
-    first prepare-alien-accessor ;
+: prepare-load-memory ( infos -- base offset )
+    [ 2inputs ] dip first prepare-accessor ;
 
-: inline-alien-getter ( node quot -- )
-    '[ prepare-alien-getter @ ds-push ]
-    [ inline-alien-getter? ] inline-alien ; inline
+: (emit-load-memory) ( node rep c-type quot -- )
+    '[ prepare-load-memory _ _ ^^load-memory-imm @ ds-push ]
+    [ inline-load-memory? ]
+    inline-accessor ; inline
 
-: inline-alien-setter? ( infos class -- ? )
+: emit-load-memory ( node rep c-type -- )
+    [ ] (emit-load-memory) ;
+
+: emit-alien-cell ( node -- )
+    int-rep f [ ^^box-alien ] (emit-load-memory) ;
+
+: inline-store-memory? ( infos class -- ? )
     '[ first class>> _ class<= ]
     [ second class>> c-ptr class<= ]
     [ third class>> fixnum class<= ]
     tri and and ;
 
-: prepare-alien-setter ( infos -- ptr-vreg offset )
-    second prepare-alien-accessor ;
+: prepare-store-memory ( infos -- value base offset )
+    [ 3inputs ] dip second prepare-accessor ;
 
-: inline-alien-integer-setter ( node quot -- )
-    '[ prepare-alien-setter ds-pop @ ]
-    [ fixnum inline-alien-setter? ]
-    inline-alien ; inline
+:: (emit-store-memory) ( node rep c-type prepare-quot test-quot -- )
+    node
+    [ prepare-quot call rep c-type ##store-memory-imm ]
+    [ test-quot call inline-store-memory? ]
+    inline-accessor ; inline
 
-: inline-alien-float-setter ( node quot -- )
-    '[ prepare-alien-setter ds-pop @ ]
-    [ float inline-alien-setter? ]
-    inline-alien ; inline
-
-: inline-alien-cell-setter ( node quot -- )
-    '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
-    [ pinned-c-ptr inline-alien-setter? ]
-    inline-alien ; inline
-
-: emit-alien-unsigned-getter ( node n -- )
-    '[
-        _ {
-            { 1 [ ^^alien-unsigned-1 ] }
-            { 2 [ ^^alien-unsigned-2 ] }
-            { 4 [ ^^alien-unsigned-4 ] }
+:: emit-store-memory ( node rep c-type -- )
+    node rep c-type
+    [ prepare-store-memory ]
+    [
+        rep {
+            { int-rep [ fixnum ] }
+            { float-rep [ float ] }
+            { double-rep [ float ] }
         } case
-    ] inline-alien-getter ;
+    ]
+    (emit-store-memory) ;
 
-: emit-alien-signed-getter ( node n -- )
-    '[
-        _ {
-            { 1 [ ^^alien-signed-1 ] }
-            { 2 [ ^^alien-signed-2 ] }
-            { 4 [ ^^alien-signed-4 ] }
-        } case
-    ] inline-alien-getter ;
-
-: emit-alien-integer-setter ( node n -- )
-    '[
-        _ {
-            { 1 [ ##set-alien-integer-1 ] }
-            { 2 [ ##set-alien-integer-2 ] }
-            { 4 [ ##set-alien-integer-4 ] }
-        } case
-    ] inline-alien-integer-setter ;
-
-: emit-alien-cell-getter ( node -- )
-    [ ^^alien-cell ^^box-alien ] inline-alien-getter ;
-
-: emit-alien-cell-setter ( node -- )
-    [ ##set-alien-cell ] inline-alien-cell-setter ;
-
-: emit-alien-float-getter ( node rep -- )
-    '[
-        _ {
-            { float-rep [ ^^alien-float ] }
-            { double-rep [ ^^alien-double ] }
-        } case
-    ] inline-alien-getter ;
-
-: emit-alien-float-setter ( node rep -- )
-    '[
-        _ {
-            { float-rep [ ##set-alien-float ] }
-            { double-rep [ ##set-alien-double ] }
-        } case
-    ] inline-alien-float-setter ;
+: emit-set-alien-cell ( node -- )
+    int-rep f
+    [
+        [ first class>> ] [ prepare-store-memory ] bi
+        [ swap ^^unbox-c-ptr ] 2dip
+    ]
+    [ pinned-c-ptr ]
+    (emit-store-memory) ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 9f5167e116..231cd5cee9 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -14,6 +14,7 @@ compiler.cfg.intrinsics.misc
 compiler.cfg.comparisons ;
 QUALIFIED: alien
 QUALIFIED: alien.accessors
+QUALIFIED: alien.c-types
 QUALIFIED: kernel
 QUALIFIED: arrays
 QUALIFIED: byte-arrays
@@ -63,24 +64,24 @@ IN: compiler.cfg.intrinsics
     { byte-arrays:(byte-array) [ emit-(byte-array) ] }
     { kernel:<wrapper> [ emit-simple-allot ] }
     { alien:<displaced-alien> [ emit-<displaced-alien> ] }
-    { alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
-    { alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
-    { alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
-    { alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
-    { alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
-    { alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
-    { alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
-    { alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
-    { alien.accessors:alien-cell [ emit-alien-cell-getter ] }
-    { alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+    { alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] }
+    { alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] }
+    { alien.accessors:alien-signed-1 [ int-rep alien.c-types:char emit-load-memory ] }
+    { alien.accessors:set-alien-signed-1 [ int-rep alien.c-types:char emit-store-memory ] }
+    { alien.accessors:alien-unsigned-2 [ int-rep alien.c-types:ushort emit-load-memory ] }
+    { alien.accessors:set-alien-unsigned-2 [ int-rep alien.c-types:ushort emit-store-memory ] }
+    { alien.accessors:alien-signed-2 [ int-rep alien.c-types:short emit-load-memory ] }
+    { alien.accessors:set-alien-signed-2 [ int-rep alien.c-types:short emit-store-memory ] }
+    { alien.accessors:alien-cell [ emit-alien-cell ] }
+    { alien.accessors:set-alien-cell [ emit-set-alien-cell ] }
 } enable-intrinsics
 
 : enable-alien-4-intrinsics ( -- )
     {
-        { alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
-        { alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
-        { alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
-        { alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+        { alien.accessors:alien-signed-4 [ int-rep alien.c-types:int emit-load-memory ] }
+        { alien.accessors:set-alien-signed-4 [ int-rep alien.c-types:int emit-store-memory ] }
+        { alien.accessors:alien-unsigned-4 [ int-rep alien.c-types:uint emit-load-memory ] }
+        { alien.accessors:set-alien-unsigned-4 [ int-rep alien.c-types:uint emit-store-memory ] }
     } enable-intrinsics ;
 
 : enable-float-intrinsics ( -- )
@@ -101,10 +102,10 @@ IN: compiler.cfg.intrinsics
         { math.private:float>fixnum [ drop [ ^^float>integer ] unary-op ] }
         { math.private:fixnum>float [ drop [ ^^integer>float ] unary-op ] }
         { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
-        { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
-        { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
-        { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] }
-        { alien.accessors:set-alien-double [ double-rep emit-alien-float-setter ] }
+        { alien.accessors:alien-float [ float-rep f emit-load-memory ] }
+        { alien.accessors:set-alien-float [ float-rep f emit-store-memory ] }
+        { alien.accessors:alien-double [ double-rep f emit-load-memory ] }
+        { alien.accessors:set-alien-double [ double-rep f emit-store-memory ] }
     } enable-intrinsics ;
 
 : enable-fsqrt ( -- )
diff --git a/basis/compiler/cfg/intrinsics/misc/misc.factor b/basis/compiler/cfg/intrinsics/misc/misc.factor
index 952b8701da..31c3bac37b 100644
--- a/basis/compiler/cfg/intrinsics/misc/misc.factor
+++ b/basis/compiler/cfg/intrinsics/misc/misc.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors classes.algebra layouts kernel math namespaces
-sequences
+sequences cpu.architecture
 compiler.tree.propagation.info
 compiler.cfg.stacks
 compiler.cfg.hats
@@ -10,6 +10,7 @@ compiler.cfg.instructions
 compiler.cfg.builder.blocks
 compiler.cfg.utilities ;
 FROM: vm => context-field-offset vm-field-offset ;
+QUALIFIED-WITH: alien.c-types c
 IN: compiler.cfg.intrinsics.misc
 
 : emit-tag ( -- )
@@ -48,6 +49,6 @@ IN: compiler.cfg.intrinsics.misc
     [
         ^^tagged>integer
         tag-mask get bitnot ^^load-integer ^^and
-        0 ^^alien-cell
+        0 int-rep f ^^load-memory-imm
         hashcode-shift ^^shr-imm
     ] unary-op ;
diff --git a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor
index 2c2d1f1d3a..d9f3df000f 100644
--- a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor
+++ b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor
@@ -19,7 +19,7 @@ M: ##zero-vector insn-available? rep>> %zero-vector-reps member? ;
 M: ##fill-vector insn-available? rep>> %fill-vector-reps member? ;
 M: ##gather-vector-2 insn-available? rep>> %gather-vector-2-reps member? ;
 M: ##gather-vector-4 insn-available? rep>> %gather-vector-4-reps member? ;
-M: ##alien-vector insn-available? rep>> %alien-vector-reps member? ;
+M: ##store-memory-imm insn-available? rep>> %alien-vector-reps member? ;
 M: ##shuffle-vector insn-available? rep>> %shuffle-vector-reps member? ;
 M: ##shuffle-vector-imm insn-available? rep>> %shuffle-vector-imm-reps member? ;
 M: ##merge-vector-head insn-available? rep>> %merge-vector-reps member? ;
diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor
index eebd76a38c..a64aa828d0 100644
--- a/basis/compiler/cfg/intrinsics/simd/simd.factor
+++ b/basis/compiler/cfg/intrinsics/simd/simd.factor
@@ -587,20 +587,20 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
 : emit-alien-vector ( node -- )
     dup [
         '[
-            ds-drop prepare-alien-getter
-            _ ^^alien-vector ds-push
+            ds-drop prepare-load-memory
+            _ f ^^load-memory-imm ds-push
         ]
-        [ inline-alien-getter? ] inline-alien
+        [ inline-load-memory? ] inline-accessor
     ] with { [ %alien-vector-reps member? ] } if-literals-match ;
 
 : emit-set-alien-vector ( node -- )
     dup [
         '[
-            ds-drop prepare-alien-setter ds-pop
-            _ ##set-alien-vector
+            ds-drop prepare-store-memory
+            _ f ##store-memory-imm
         ]
-        [ byte-array inline-alien-setter? ]
-        inline-alien
+        [ byte-array inline-store-memory? ]
+        inline-accessor
     ] with { [ %alien-vector-reps member? ] } if-literals-match ;
 
 : enable-simd ( -- )
diff --git a/basis/compiler/cfg/intrinsics/strings/strings.factor b/basis/compiler/cfg/intrinsics/strings/strings.factor
index 40c54bdfdc..dea9510a99 100644
--- a/basis/compiler/cfg/intrinsics/strings/strings.factor
+++ b/basis/compiler/cfg/intrinsics/strings/strings.factor
@@ -1,13 +1,13 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.constants compiler.cfg.hats
+USING: alien.c-types kernel compiler.constants compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.stacks ;
+compiler.cfg.stacks cpu.architecture ;
 IN: compiler.cfg.intrinsics.strings
 
 : emit-string-nth ( -- )
     2inputs swap ^^string-nth ds-push ;
 
 : emit-set-string-nth-fast ( -- )
-    3inputs ^^tagged>integer ^^add swap [ string-offset ] dip
-    ##set-alien-integer-1 ;
+    3inputs ^^tagged>integer ^^add string-offset
+    int-rep uchar ##store-memory-imm ;
diff --git a/basis/compiler/cfg/representations/conversion/conversion.factor b/basis/compiler/cfg/representations/conversion/conversion.factor
index 87cca9204a..b8346fed6a 100644
--- a/basis/compiler/cfg/representations/conversion/conversion.factor
+++ b/basis/compiler/cfg/representations/conversion/conversion.factor
@@ -26,24 +26,22 @@ M:: float-rep tagged>rep ( dst src rep -- )
     temp src double-rep tagged>rep
     dst temp ##double>single-float ;
 
-M: double-rep rep>tagged
-    drop
-    [ drop 16 float int-rep next-vreg-rep ##allot ]
-    [ float-offset swap ##set-alien-double ]
-    2bi ;
+M:: double-rep rep>tagged ( dst src rep -- )
+    dst 16 float int-rep next-vreg-rep ##allot
+    src dst float-offset double-rep f ##store-memory-imm ;
 
 M: double-rep tagged>rep
-    drop float-offset ##alien-double ;
+    drop float-offset double-rep f ##load-memory-imm ;
 
 M:: vector-rep rep>tagged ( dst src rep -- )
     tagged-rep next-vreg-rep :> temp
     dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot
     temp 16 tag-fixnum ##load-tagged
     temp dst 1 byte-array type-number ##set-slot-imm
-    dst byte-array-offset src rep ##set-alien-vector ;
+    src dst byte-array-offset rep f ##store-memory-imm ;
 
 M: vector-rep tagged>rep
-    [ byte-array-offset ] dip ##alien-vector ;
+    [ byte-array-offset ] dip f ##load-memory-imm ;
 
 M:: scalar-rep rep>tagged ( dst src rep -- )
     tagged-rep next-vreg-rep :> temp
diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor
index fb03dfa2ea..7d644206a9 100644
--- a/basis/compiler/cfg/representations/representations-tests.factor
+++ b/basis/compiler/cfg/representations/representations-tests.factor
@@ -2,7 +2,8 @@ USING: accessors compiler.cfg compiler.cfg.debugger
 compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.representations.preferred cpu.architecture kernel
 namespaces tools.test sequences arrays system literals layouts
-math ;
+math compiler.constants compiler.cfg.representations.conversion
+compiler.cfg.representations.rewrite make ;
 IN: compiler.cfg.representations
 
 [ { double-rep double-rep } ] [
@@ -14,12 +15,39 @@ IN: compiler.cfg.representations
 ] unit-test
 
 [ double-rep ] [
-    T{ ##alien-double
+    T{ ##load-memory-imm
        { dst 5 }
-       { src 3 }
+       { base 3 }
+       { offset 0 }
+       { rep double-rep }
     } defs-vreg-rep
 ] unit-test
 
+H{ } clone representations set
+
+3 \ vreg-counter set-global
+
+[
+    {
+        T{ ##allot f 2 16 float 4 }
+        T{ ##store-memory-imm f 1 2 $[ float-offset ] double-rep f }
+    }
+] [
+    [
+        2 1 tagged-rep double-rep emit-conversion
+    ] { } make
+] unit-test
+
+[
+    {
+        T{ ##load-memory-imm f 2 1 $[ float-offset ] double-rep f }
+    }
+] [
+    [
+        2 1 double-rep tagged-rep emit-conversion
+    ] { } make
+] unit-test
+
 : test-representations ( -- )
     cfg new 0 get >>entry dup cfg set select-representations drop ;
 
diff --git a/basis/compiler/cfg/value-numbering/alien/alien.factor b/basis/compiler/cfg/value-numbering/alien/alien.factor
index db9e02d4a6..949cdc40b7 100644
--- a/basis/compiler/cfg/value-numbering/alien/alien.factor
+++ b/basis/compiler/cfg/value-numbering/alien/alien.factor
@@ -30,21 +30,10 @@ M: ##unbox-any-c-ptr rewrite
 
 ! More efficient addressing for alien intrinsics
 : rewrite-alien-addressing ( insn -- insn' )
-    dup src>> vreg>expr dup add-imm-expr? [
+    dup base>> vreg>expr dup add-imm-expr? [
         [ src1>> vn>vreg ] [ src2>> vn>integer ] bi
-        [ >>src ] [ '[ _ + ] change-offset ] bi*
+        [ >>base ] [ '[ _ + ] change-offset ] bi*
     ] [ 2drop f ] if ;
 
-M: ##alien-unsigned-1 rewrite rewrite-alien-addressing ;
-M: ##alien-unsigned-2 rewrite rewrite-alien-addressing ;
-M: ##alien-unsigned-4 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-1 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-2 rewrite rewrite-alien-addressing ;
-M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
-M: ##alien-float rewrite rewrite-alien-addressing ;
-M: ##alien-double rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
-M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
-M: ##set-alien-float rewrite rewrite-alien-addressing ;
-M: ##set-alien-double rewrite rewrite-alien-addressing ;
+M: ##load-memory-imm rewrite rewrite-alien-addressing ;
+M: ##store-memory-imm rewrite rewrite-alien-addressing ;
diff --git a/basis/compiler/cfg/value-numbering/simd/simd.factor b/basis/compiler/cfg/value-numbering/simd/simd.factor
index 4c4b422187..d37d16896b 100644
--- a/basis/compiler/cfg/value-numbering/simd/simd.factor
+++ b/basis/compiler/cfg/value-numbering/simd/simd.factor
@@ -16,9 +16,6 @@ compiler.cfg.value-numbering.rewrite
 compiler.cfg.value-numbering.simplify ;
 IN: compiler.cfg.value-numbering.simd
 
-M: ##alien-vector rewrite rewrite-alien-addressing ;
-M: ##set-alien-vector rewrite rewrite-alien-addressing ;
-
 ! Some lame constant folding for SIMD intrinsics. Eventually this
 ! should be redone completely.
 
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 035b23d976..0ad195f145 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -6,6 +6,7 @@ compiler.cfg.ssa.destruction compiler.cfg.loop-detection
 compiler.cfg.representations compiler.cfg assocs vectors arrays
 layouts literals namespaces alien compiler.cfg.value-numbering.simd
 system ;
+QUALIFIED-WITH: alien.c-types c
 IN: compiler.cfg.value-numbering.tests
 
 : trim-temps ( insns -- insns )
@@ -2207,3 +2208,40 @@ V{
 ] unit-test
 
 [ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
+
+! Alien addressing optimization
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##tagged>integer f 2 1 }
+        T{ ##add-imm f 3 2 10 }
+        T{ ##load-memory-imm f 4 2 10 int-rep c:uchar }
+    }
+] [
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##tagged>integer f 2 1 }
+        T{ ##add-imm f 3 2 10 }
+        T{ ##load-memory-imm f 4 3 0 int-rep c:uchar }
+    } value-numbering-step
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add-imm f 4 3 10 }
+        T{ ##store-memory-imm f 2 3 10 int-rep c:uchar }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add-imm f 4 3 10 }
+        T{ ##store-memory-imm f 2 4 0 int-rep c:uchar }
+    } value-numbering-step
+] unit-test
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index a7eb5dc0cd..5f8cf5f188 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -20,7 +20,7 @@ IN: compiler.cfg.value-numbering
 ! Local value numbering.
 
 : >copy ( insn -- insn/##copy )
-    dup defs-vreg dup vreg>vn vn>vreg
+    dup dst>> dup vreg>vn vn>vreg
     2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ;
 
 GENERIC: process-instruction ( insn -- insn' )
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index a88c9a726f..0bdde0b5f7 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -187,23 +187,8 @@ CODEGEN: ##box-alien %box-alien
 CODEGEN: ##box-displaced-alien %box-displaced-alien
 CODEGEN: ##unbox-alien %unbox-alien
 CODEGEN: ##unbox-any-c-ptr %unbox-any-c-ptr
-CODEGEN: ##alien-unsigned-1 %alien-unsigned-1
-CODEGEN: ##alien-unsigned-2 %alien-unsigned-2
-CODEGEN: ##alien-unsigned-4 %alien-unsigned-4
-CODEGEN: ##alien-signed-1 %alien-signed-1
-CODEGEN: ##alien-signed-2 %alien-signed-2
-CODEGEN: ##alien-signed-4 %alien-signed-4
-CODEGEN: ##alien-cell %alien-cell
-CODEGEN: ##alien-float %alien-float
-CODEGEN: ##alien-double %alien-double
-CODEGEN: ##alien-vector %alien-vector
-CODEGEN: ##set-alien-integer-1 %set-alien-integer-1
-CODEGEN: ##set-alien-integer-2 %set-alien-integer-2
-CODEGEN: ##set-alien-integer-4 %set-alien-integer-4
-CODEGEN: ##set-alien-cell %set-alien-cell
-CODEGEN: ##set-alien-float %set-alien-float
-CODEGEN: ##set-alien-double %set-alien-double
-CODEGEN: ##set-alien-vector %set-alien-vector
+CODEGEN: ##load-memory-imm %load-memory-imm
+CODEGEN: ##store-memory-imm %store-memory-imm
 CODEGEN: ##allot %allot
 CODEGEN: ##write-barrier %write-barrier
 CODEGEN: ##write-barrier-imm %write-barrier-imm
diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index ca02e80922..02f5c93352 100644
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -3,7 +3,7 @@ compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr
 compiler.cfg.registers compiler.codegen compiler.units
 cpu.architecture hashtables kernel namespaces sequences
 tools.test vectors words layouts literals math arrays
-alien.syntax math.private ;
+alien.c-types alien.syntax math.private ;
 IN: compiler.tests.low-level-ir
 
 : compile-cfg ( cfg -- word )
@@ -92,7 +92,7 @@ IN: compiler.tests.low-level-ir
     V{
         T{ ##load-reference f 1 B{ 31 67 52 } }
         T{ ##unbox-any-c-ptr f 0 1 }
-        T{ ##alien-unsigned-1 f 0 0 0 }
+        T{ ##load-memory-imm f 0 0 0 int-rep uchar }
         T{ ##shl-imm f 0 0 4 }
     } compile-test-bb
 ] unit-test
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index ab335ba188..c25ade8312 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -430,24 +430,8 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 HOOK: %box-alien cpu ( dst src temp -- )
 HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
 
-HOOK: %alien-unsigned-1 cpu ( dst src offset -- )
-HOOK: %alien-unsigned-2 cpu ( dst src offset -- )
-HOOK: %alien-unsigned-4 cpu ( dst src offset -- )
-HOOK: %alien-signed-1   cpu ( dst src offset -- )
-HOOK: %alien-signed-2   cpu ( dst src offset -- )
-HOOK: %alien-signed-4   cpu ( dst src offset -- )
-HOOK: %alien-cell       cpu ( dst src offset -- )
-HOOK: %alien-float      cpu ( dst src offset -- )
-HOOK: %alien-double     cpu ( dst src offset -- )
-HOOK: %alien-vector     cpu ( dst src offset rep -- )
-
-HOOK: %set-alien-integer-1 cpu ( ptr offset value -- )
-HOOK: %set-alien-integer-2 cpu ( ptr offset value -- )
-HOOK: %set-alien-integer-4 cpu ( ptr offset value -- )
-HOOK: %set-alien-cell      cpu ( ptr offset value -- )
-HOOK: %set-alien-float     cpu ( ptr offset value -- )
-HOOK: %set-alien-double    cpu ( ptr offset value -- )
-HOOK: %set-alien-vector    cpu ( ptr offset value rep -- )
+HOOK: %load-memory-imm cpu ( dst base offset rep c-type -- )
+HOOK: %store-memory-imm cpu ( value base offset rep c-type -- )
 
 HOOK: %alien-global cpu ( dst symbol library -- )
 HOOK: %vm-field cpu ( dst offset -- )
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 8e57f36be9..aee94724ff 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -12,6 +12,7 @@ compiler.cfg.intrinsics
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
 compiler.codegen.fixup ;
+QUALIFIED-WITH: alien.c-types c
 FROM: layouts => cell ;
 FROM: math => float ;
 IN: cpu.x86
@@ -66,7 +67,10 @@ HOOK: pic-tail-reg cpu ( -- reg )
 
 M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
 
-M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-literal ;
+M: x86 %load-reference
+    [ swap 0 MOV rc-absolute-cell rel-literal ]
+    [ \ f type-number MOV ]
+    if* ;
 
 HOOK: ds-reg cpu ( -- reg )
 HOOK: rs-reg cpu ( -- reg )
@@ -354,45 +358,48 @@ M:: x86 %string-nth ( dst src index temp -- )
         dst new-dst int-rep %copy
     ] with-small-register ;
 
-:: %alien-integer-getter ( dst src offset size quot -- )
-    dst { src } size [| new-dst |
-        new-dst dup size n-bit-version-of dup src offset [+] MOV
+:: %alien-integer-getter ( dst base offset bits quot -- )
+    dst { base } bits [| new-dst |
+        new-dst dup bits n-bit-version-of dup base offset [+] MOV
         quot call
         dst new-dst int-rep %copy
     ] with-small-register ; inline
 
-: %alien-unsigned-getter ( dst src offset size -- )
+: %alien-unsigned-getter ( dst base offset bits -- )
     [ MOVZX ] %alien-integer-getter ; inline
 
-: %alien-signed-getter ( dst src offset size -- )
+: %alien-signed-getter ( dst base offset bits -- )
     [ MOVSX ] %alien-integer-getter ; inline
 
-:: %alien-integer-setter ( ptr offset value size -- )
-    value { ptr } size [| new-value |
+:: %alien-integer-setter ( value base offset bits -- )
+    value { base } bits [| new-value |
         new-value value int-rep %copy
-        ptr offset [+] new-value size n-bit-version-of MOV
+        base offset [+] new-value bits n-bit-version-of MOV
     ] with-small-register ; inline
 
-M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
-M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
-M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
+M: x86 %load-memory-imm ( dst base offset rep c-type -- )
+    [
+        {
+            { c:char   [ 8 %alien-signed-getter ] }
+            { c:uchar  [ 8 %alien-unsigned-getter ] }
+            { c:short  [ 16 %alien-signed-getter ] }
+            { c:ushort [ 16 %alien-unsigned-getter ] }
+            { c:int    [ 32 [ 2drop ] %alien-integer-getter ] }
+            { c:uint   [ 32 %alien-signed-getter ] }
+        } case
+    ] [ [ [+] ] dip %copy ] ?if ;
 
-M: x86 %alien-signed-1 8 %alien-signed-getter ;
-M: x86 %alien-signed-2 16 %alien-signed-getter ;
-M: x86 %alien-signed-4 32 %alien-signed-getter ;
-
-M: x86 %alien-cell [+] MOV ;
-M: x86 %alien-float [+] MOVSS ;
-M: x86 %alien-double [+] MOVSD ;
-M: x86 %alien-vector [ [+] ] dip %copy ;
-
-M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
-M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
-M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
-M: x86 %set-alien-cell [ [+] ] dip MOV ;
-M: x86 %set-alien-float [ [+] ] dip MOVSS ;
-M: x86 %set-alien-double [ [+] ] dip MOVSD ;
-M: x86 %set-alien-vector [ [+] ] 2dip %copy ;
+M: x86 %store-memory-imm ( src base offset rep c-type -- )
+    [
+        {
+            { c:char   [ 8 %alien-integer-setter ] }
+            { c:uchar  [ 8 %alien-integer-setter ] }
+            { c:short  [ 16 %alien-integer-setter ] }
+            { c:ushort [ 16 %alien-integer-setter ] }
+            { c:int    [ 32 %alien-integer-setter ] }
+            { c:uint   [ 32 %alien-integer-setter ] }
+        } case
+    ] [ [ [+] swap ] dip %copy ] ?if ;
 
 : shift-count? ( reg -- ? ) { ECX RCX } member-eq? ;
 

From 6d41d2277f4ad9ec15b87ff2c825bd87e3f14372 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 Apr 2010 19:04:03 -0400
Subject: [PATCH 112/158] cpu.x86.assembler: support all addressing modes

---
 .../cpu/x86/assembler/assembler-tests.factor  | 87 +++++++++++--------
 .../x86/assembler/operands/operands.factor    | 30 +++++--
 basis/cpu/x86/x86.factor                      | 12 +--
 3 files changed, 79 insertions(+), 50 deletions(-)

diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor
index 8ed789f392..83186a7f24 100644
--- a/basis/cpu/x86/assembler/assembler-tests.factor
+++ b/basis/cpu/x86/assembler/assembler-tests.factor
@@ -11,6 +11,58 @@ IN: cpu.x86.assembler.tests
 [ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
 [ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
 
+! memory address modes
+[ { HEX: 8a HEX: 18         } ] [ [ BL RAX [] MOV ] { } make ] unit-test
+[ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX RAX [] MOV ] { } make ] unit-test
+[ { HEX: 8b HEX: 18         } ] [ [ EBX RAX [] MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 8b HEX: 18 } ] [ [ RBX RAX [] MOV ] { } make ] unit-test
+[ { HEX: 88 HEX: 18         } ] [ [ RAX [] BL MOV ] { } make ] unit-test
+[ { HEX: 66 HEX: 89 HEX: 18 } ] [ [ RAX [] BX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 18         } ] [ [ RAX [] EBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 18 } ] [ [ RAX [] RBX MOV ] { } make ] unit-test
+
+[ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test
+[ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test
+
+[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
+[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1a } ] [ [ R10 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1b } ] [ [ R11 RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1c } ] [ [ R12 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 04 HEX: 1c } ] [ [ RSP RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ R13 RBX [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ RBP RBX [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 4a HEX: 89 HEX: 04 HEX: 23 } ] [ [ RBX R12 [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 4a HEX: 89 HEX: 04 HEX: 2b } ] [ [ RBX R13 [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 4b HEX: 89 HEX: 44 HEX: 25 HEX: 00 } ] [ [ R13 R12 [+] RAX MOV ] { } make ] unit-test
+[ { HEX: 4b HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 R13 [+] RAX MOV ] { } make ] unit-test
+
+[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
+[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail
+
+[ { HEX: 89 HEX: 1c HEX: 11 } ] [ [ ECX EDX [+] EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 1c HEX: 51 } ] [ [ ECX EDX 1 0 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 1c HEX: 91 } ] [ [ ECX EDX 2 0 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 1c HEX: d1 } ] [ [ ECX EDX 3 0 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: 11 HEX: 64 } ] [ [ ECX EDX 0 100 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: 51 HEX: 64 } ] [ [ ECX EDX 1 100 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: 91 HEX: 64 } ] [ [ ECX EDX 2 100 <indirect> EBX MOV ] { } make ] unit-test
+[ { HEX: 89 HEX: 5c HEX: d1 HEX: 64 } ] [ [ ECX EDX 3 100 <indirect> EBX MOV ] { } make ] unit-test
+
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: 11 } ] [ [ RCX RDX [+] RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: 51 } ] [ [ RCX RDX 1 0 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: 91 } ] [ [ RCX RDX 2 0 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 1c HEX: d1 } ] [ [ RCX RDX 3 0 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: 11 HEX: 64 } ] [ [ RCX RDX 0 100 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: 51 HEX: 64 } ] [ [ RCX RDX 1 100 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: 91 HEX: 64 } ] [ [ RCX RDX 2 100 <indirect> RBX MOV ] { } make ] unit-test
+[ { HEX: 48 HEX: 89 HEX: 5c HEX: d1 HEX: 64 } ] [ [ RCX RDX 3 100 <indirect> RBX MOV ] { } make ] unit-test
+
 ! r-rm / m-r sse instruction
 [ { HEX: 0f HEX: 10 HEX: c1 } ] [ [ XMM0 XMM1 MOVUPS ] { } make ] unit-test
 [ { HEX: 0f HEX: 10 HEX: 01 } ] [ [ XMM0 ECX [] MOVUPS ] { } make ] unit-test
@@ -115,40 +167,7 @@ IN: cpu.x86.assembler.tests
 [ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: c1 } ] [ [ EAX ECX CRC32 ] { } make ] unit-test
 [ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: 01 } ] [ [ EAX ECX [] CRC32 ] { } make ] unit-test
 
-! memory address modes
-[ { HEX: 8a HEX: 18         } ] [ [ BL RAX [] MOV ] { } make ] unit-test
-[ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX RAX [] MOV ] { } make ] unit-test
-[ { HEX: 8b HEX: 18         } ] [ [ EBX RAX [] MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 8b HEX: 18 } ] [ [ RBX RAX [] MOV ] { } make ] unit-test
-[ { HEX: 88 HEX: 18         } ] [ [ RAX [] BL MOV ] { } make ] unit-test
-[ { HEX: 66 HEX: 89 HEX: 18 } ] [ [ RAX [] BX MOV ] { } make ] unit-test
-[ { HEX: 89 HEX: 18         } ] [ [ RAX [] EBX MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 89 HEX: 18 } ] [ [ RAX [] RBX MOV ] { } make ] unit-test
-
-[ { HEX: 0f HEX: be HEX: c3 } ] [ [ EAX BL MOVSX ] { } make ] unit-test
-[ { HEX: 0f HEX: bf HEX: c3 } ] [ [ EAX BX MOVSX ] { } make ] unit-test
-
-[ { HEX: 80 HEX: 08 HEX: 05 } ] [ [ EAX [] 5 <byte> OR ] { } make ] unit-test
-[ { HEX: c6 HEX: 00 HEX: 05 } ] [ [ EAX [] 5 <byte> MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1a } ] [ [ R10 RBX [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1b } ] [ [ R11 RBX [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 1c } ] [ [ R12 RBX [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 89 HEX: 04 HEX: 1c } ] [ [ RSP RBX [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ R13 RBX [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 48 HEX: 89 HEX: 44 HEX: 1d HEX: 00 } ] [ [ RBP RBX [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 4a HEX: 89 HEX: 04 HEX: 23 } ] [ [ RBX R12 [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 4a HEX: 89 HEX: 04 HEX: 2b } ] [ [ RBX R13 [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 4b HEX: 89 HEX: 44 HEX: 25 HEX: 00 } ] [ [ R13 R12 [+] RAX MOV ] { } make ] unit-test
-[ { HEX: 4b HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 R13 [+] RAX MOV ] { } make ] unit-test
-
-[ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
-[ [ R12 RSP [+] RAX MOV ] { } make ] must-fail
-
+! various oddities
 [ { HEX: 48 HEX: d3 HEX: e0 } ] [ [ RAX CL SHL ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
diff --git a/basis/cpu/x86/assembler/operands/operands.factor b/basis/cpu/x86/assembler/operands/operands.factor
index e8d98cde17..0ef2b030d1 100644
--- a/basis/cpu/x86/assembler/operands/operands.factor
+++ b/basis/cpu/x86/assembler/operands/operands.factor
@@ -53,6 +53,10 @@ TUPLE: indirect base index scale displacement ;
 
 M: indirect extended? base>> extended? ;
 
+: canonicalize-displacement ( indirect -- indirect )
+    dup [ base>> ] [ displacement>> 0 = ] bi and
+    [ f >>displacement ] when ;
+
 : canonicalize-EBP ( indirect -- indirect )
     #! { EBP } ==> { EBP 0 }
     dup [ base>> { EBP RBP R13 } member? ] [ displacement>> not ] bi and
@@ -66,10 +70,7 @@ ERROR: bad-index indirect ;
 : canonicalize ( indirect -- indirect )
     #! Modify the indirect to work around certain addressing mode
     #! quirks.
-    canonicalize-EBP check-ESP ;
-
-: <indirect> ( base index scale displacement -- indirect )
-    indirect boa canonicalize ;
+    canonicalize-displacement canonicalize-EBP check-ESP ;
 
 ! Utilities
 UNION: operand register indirect ;
@@ -85,7 +86,10 @@ M: object operand-64? drop f ;
 
 PRIVATE>
 
-: [] ( reg/displacement -- indirect )
+: <indirect> ( base index scale displacement -- indirect )
+    indirect boa canonicalize ;
+
+: [] ( base/displacement -- indirect )
     dup integer?
     [ [ f f bootstrap-cell 8 = 0 f ? ] dip <indirect> ]
     [ f f f <indirect> ]
@@ -94,12 +98,24 @@ PRIVATE>
 : [RIP+] ( displacement -- indirect )
     [ f f f ] dip <indirect> ;
 
-: [+] ( reg displacement -- indirect )
+: [+] ( base index/displacement -- indirect )
     dup integer?
-    [ dup zero? [ drop f ] when [ f f ] dip ]
+    [ [ f f ] dip ]
     [ f f ] if
     <indirect> ;
 
+: [++] ( base index displacement -- indirect )
+    [ f ] dip <indirect> ;
+
+: [+*2+] ( base index displacement -- indirect )
+    [ 1 ] dip <indirect> ;
+
+: [+*4+] ( base index displacement -- indirect )
+    [ 2 ] dip <indirect> ;
+
+: [+*8+] ( base index displacement -- indirect )
+    [ 3 ] dip <indirect> ;
+
 TUPLE: byte value ;
 
 C: <byte> byte
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index aee94724ff..86c8c5b46e 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -283,9 +283,7 @@ M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
 
         dst 1 alien@ base MOV
         dst 3 alien@ displacement MOV
-        temp base MOV
-        temp byte-array-offset ADD
-        temp displacement ADD
+        temp base displacement byte-array-offset [++] MOV
         dst 4 alien@ temp MOV
 
         "end" resolve-label
@@ -336,8 +334,7 @@ M:: x86 %string-nth ( dst src index temp -- )
         ! Load the least significant 7 bits into new-dst.
         ! 8th bit indicates whether we have to load from
         ! the aux vector or not.
-        temp src index [+] LEA
-        new-dst 8-bit-version-of temp string-offset [+] MOV
+        new-dst 8-bit-version-of src index string-offset [++] MOV
         new-dst new-dst 8-bit-version-of MOVZX
         ! Do we have to look at the aux vector?
         new-dst HEX: 80 CMP
@@ -345,11 +342,8 @@ M:: x86 %string-nth ( dst src index temp -- )
         ! Yes, this is a non-ASCII character. Load aux vector
         temp src string-aux-offset [+] MOV
         new-dst temp XCHG
-        ! Compute index
-        new-dst index ADD
-        new-dst index ADD
         ! Load high 16 bits
-        new-dst 16-bit-version-of new-dst byte-array-offset [+] MOV
+        new-dst 16-bit-version-of new-dst index byte-array-offset [+*2+] MOV
         new-dst new-dst 16-bit-version-of MOVZX
         new-dst 7 SHL
         ! Compute code point

From 2475699736f0cf51500320c39bbfd9c6ea5c03dd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 Apr 2010 20:20:06 -0400
Subject: [PATCH 113/158] compiler.cfg: more flexible addressing for ##slot and
 ##set-slot

---
 .../cfg/instructions/instructions.factor      |  9 ++++--
 .../cfg/intrinsics/slots/slots.factor         | 29 ++++++++++---------
 basis/compiler/tests/low-level-ir.factor      |  4 +--
 basis/cpu/architecture/architecture.factor    | 13 ++++++---
 basis/cpu/x86/x86.factor                      | 23 +++++++++------
 5 files changed, 47 insertions(+), 31 deletions(-)

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 4023247b82..4960722eb2 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -73,7 +73,8 @@ temp: temp/int-rep ;
 ! Slot access
 INSN: ##slot
 def: dst/tagged-rep
-use: obj/tagged-rep slot/int-rep ;
+use: obj/tagged-rep slot/int-rep
+literal: scale tag ;
 
 INSN: ##slot-imm
 def: dst/tagged-rep
@@ -81,7 +82,8 @@ use: obj/tagged-rep
 literal: slot tag ;
 
 INSN: ##set-slot
-use: src/tagged-rep obj/tagged-rep slot/int-rep ;
+use: src/tagged-rep obj/tagged-rep slot/int-rep
+literal: scale tag ;
 
 INSN: ##set-slot-imm
 use: src/tagged-rep obj/tagged-rep
@@ -568,11 +570,12 @@ temp: temp/int-rep ;
 
 INSN: ##write-barrier
 use: src/tagged-rep slot/int-rep
+literal: scale tag
 temp: temp1/int-rep temp2/int-rep ;
 
 INSN: ##write-barrier-imm
 use: src/tagged-rep
-literal: slot
+literal: slot tag
 temp: temp1/int-rep temp2/int-rep ;
 
 INSN: ##alien-global
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index 1ec648b908..a3f532b4db 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -1,9 +1,10 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: layouts namespaces kernel accessors sequences math
 classes.algebra classes.builtin locals combinators
-cpu.architecture compiler.tree.propagation.info
-compiler.cfg.stacks compiler.cfg.hats compiler.cfg.registers
+combinators.short-circuit cpu.architecture
+compiler.tree.propagation.info compiler.cfg.stacks
+compiler.cfg.hats compiler.cfg.registers
 compiler.cfg.instructions compiler.cfg.utilities
 compiler.cfg.builder.blocks compiler.constants ;
 IN: compiler.cfg.intrinsics.slots
@@ -13,12 +14,13 @@ IN: compiler.cfg.intrinsics.slots
 
 : value-tag ( info -- n ) class>> class-tag ;
 
-: ^^tag-offset>slot ( slot tag -- vreg' )
-    [ ^^offset>slot ] dip ^^sub-imm ;
+: slot-indexing ( slot tag -- slot scale tag )
+    complex-addressing?
+    [ [ cell log2 ] dip ] [ [ ^^offset>slot ] dip ^^sub-imm 0 0 ] if ;
 
 : (emit-slot) ( infos -- dst )
     [ 2inputs ] [ first value-tag ] bi*
-    ^^tag-offset>slot ^^slot ;
+    slot-indexing ^^slot ;
 
 : (emit-slot-imm) ( infos -- dst )
     ds-drop
@@ -28,9 +30,9 @@ IN: compiler.cfg.intrinsics.slots
 
 : immediate-slot-offset? ( value-info -- ? )
     literal>> {
-        { [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
-        [ drop f ]
-    } cond ;
+        [ fixnum? ]
+        [ cell * immediate-arithmetic? ]
+    } 1&& ;
 
 : emit-slot ( node -- )
     dup node-input-infos
@@ -47,12 +49,13 @@ IN: compiler.cfg.intrinsics.slots
 :: (emit-set-slot) ( infos -- )
     3inputs :> ( src obj slot )
 
-    slot infos second value-tag ^^tag-offset>slot :> slot
+    infos second value-tag :> tag
 
-    src obj slot ##set-slot
+    slot tag slot-indexing :> ( slot scale tag )
+    src obj slot scale tag ##set-slot
 
     infos emit-write-barrier?
-    [ obj slot next-vreg next-vreg ##write-barrier ] when ;
+    [ obj slot scale tag next-vreg next-vreg ##write-barrier ] when ;
 
 :: (emit-set-slot-imm) ( infos -- )
     ds-drop
@@ -65,7 +68,7 @@ IN: compiler.cfg.intrinsics.slots
     src obj slot tag ##set-slot-imm
 
     infos emit-write-barrier?
-    [ obj slot tag slot-offset next-vreg next-vreg ##write-barrier-imm ] when ;
+    [ obj slot tag next-vreg next-vreg ##write-barrier-imm ] when ;
 
 : emit-set-slot ( node -- )
     dup node-input-infos
diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index 02f5c93352..7ce43e9524 100644
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -46,7 +46,7 @@ IN: compiler.tests.low-level-ir
     V{
         T{ ##load-tagged f 1 $[ 2 cell log2 shift array type-number - ] }
         T{ ##load-reference f 0 { t f t } }
-        T{ ##slot f 0 0 1 }
+        T{ ##slot f 0 0 1 0 0 }
     } compile-test-bb
 ] unit-test
 
@@ -61,7 +61,7 @@ IN: compiler.tests.low-level-ir
     V{
         T{ ##load-tagged f 1 $[ 2 cell log2 shift array type-number - ] }
         T{ ##load-reference f 0 { t f t } }
-        T{ ##set-slot f 0 0 1 }
+        T{ ##set-slot f 0 0 1 0 0 }
     } compile-test-bb
     dup first eq?
 ] unit-test
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index c25ade8312..ea98a199ed 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -203,6 +203,11 @@ M: ulonglong-2-rep scalar-rep-of drop ulonglong-scalar-rep ;
 ! Mapping from register class to machine registers
 HOOK: machine-registers cpu ( -- assoc )
 
+! Specifies if %slot, %set-slot and %write-barrier accept the
+! 'scale' and 'tag' parameters, and if %load-memory and
+! %store-memory work
+HOOK: complex-addressing? cpu ( -- ? )
+
 HOOK: %load-immediate cpu ( reg val -- )
 HOOK: %load-reference cpu ( reg obj -- )
 HOOK: %load-double cpu ( reg val -- )
@@ -220,9 +225,9 @@ HOOK: %return cpu ( -- )
 
 HOOK: %dispatch cpu ( src temp -- )
 
-HOOK: %slot cpu ( dst obj slot -- )
+HOOK: %slot cpu ( dst obj slot scale tag -- )
 HOOK: %slot-imm cpu ( dst obj slot tag -- )
-HOOK: %set-slot cpu ( src obj slot -- )
+HOOK: %set-slot cpu ( src obj slot scale tag -- )
 HOOK: %set-slot-imm cpu ( src obj slot tag -- )
 
 HOOK: %string-nth cpu ( dst obj index temp -- )
@@ -440,8 +445,8 @@ HOOK: %set-vm-field cpu ( src offset -- )
 : %context ( dst -- ) 0 %vm-field ;
 
 HOOK: %allot cpu ( dst size class temp -- )
-HOOK: %write-barrier cpu ( src slot temp1 temp2 -- )
-HOOK: %write-barrier-imm cpu ( src slot temp1 temp2 -- )
+HOOK: %write-barrier cpu ( src slot scale tag temp1 temp2 -- )
+HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- )
 
 ! GC checks
 HOOK: %check-nursery cpu ( label size temp1 temp2 -- )
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 86c8c5b46e..01c11c6aec 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -65,6 +65,8 @@ HOOK: temp-reg cpu ( -- reg )
 
 HOOK: pic-tail-reg cpu ( -- reg )
 
+M: x86 complex-addressing? t ;
+
 M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
 
 M: x86 %load-reference
@@ -110,12 +112,12 @@ M: x86 %return ( -- ) 0 RET ;
 : align-code ( n -- )
     0 <repetition> % ;
 
-:: (%slot-imm) ( obj slot tag -- op )
-    obj slot tag slot-offset [+] ; inline
+: (%slot) ( obj slot scale tag -- op ) neg <indirect> ; inline
+: (%slot-imm) ( obj slot tag -- op ) slot-offset [+] ; inline
 
-M: x86 %slot ( dst obj slot -- ) [+] MOV ;
+M: x86 %slot ( dst obj slot scale tag -- ) (%slot) MOV ;
 M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
-M: x86 %set-slot ( src obj slot -- ) [+] swap MOV ;
+M: x86 %set-slot ( src obj slot scale tag -- ) (%slot) swap MOV ;
 M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
 
 :: two-operand ( dst src1 src2 rep -- dst src )
@@ -283,7 +285,7 @@ M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
 
         dst 1 alien@ base MOV
         dst 3 alien@ displacement MOV
-        temp base displacement byte-array-offset [++] MOV
+        temp base displacement byte-array-offset [++] LEA
         dst 4 alien@ temp MOV
 
         "end" resolve-label
@@ -445,16 +447,19 @@ M:: x86 %allot ( dst size class nursery-ptr -- )
 HOOK: %mark-card cpu ( card temp -- )
 HOOK: %mark-deck cpu ( card temp -- )
 
-:: (%write-barrier) ( src slot temp1 temp2 -- )
-    temp1 src slot [+] LEA
+:: (%write-barrier) ( temp1 temp2 -- )
     temp1 card-bits SHR
     temp1 temp2 %mark-card
     temp1 deck-bits card-bits - SHR
     temp1 temp2 %mark-deck ;
 
-M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ;
+M:: x86 %write-barrier ( src slot scale tag temp1 temp2 -- )
+    temp1 src slot scale tag (%slot) LEA
+    temp1 temp2 (%write-barrier) ;
 
-M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
+M:: x86 %write-barrier-imm ( src slot tag temp1 temp2 -- )
+    temp1 src slot tag (%slot-imm) LEA
+    temp1 temp2 (%write-barrier) ;
 
 M:: x86 %check-nursery ( label size temp1 temp2 -- )
     temp1 load-zone-offset

From b8d556514c549f7f6c614fff60bb2fceff7dfdbe Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 23 Apr 2010 20:52:59 -0400
Subject: [PATCH 114/158] compiler.cfg.value-numbering: add slot addressing
 rewrite rule to eliminate a redundant ##add-imm from array-nth and
 set-array-nth

---
 .../cfg/value-numbering/slots/authors.txt     |  1 +
 .../cfg/value-numbering/slots/slots.factor    | 25 +++++++++++++++++++
 .../value-numbering-tests.factor              | 19 ++++++++++++++
 .../value-numbering/value-numbering.factor    |  3 ++-
 4 files changed, 47 insertions(+), 1 deletion(-)
 create mode 100644 basis/compiler/cfg/value-numbering/slots/authors.txt
 create mode 100644 basis/compiler/cfg/value-numbering/slots/slots.factor

diff --git a/basis/compiler/cfg/value-numbering/slots/authors.txt b/basis/compiler/cfg/value-numbering/slots/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/slots/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/value-numbering/slots/slots.factor b/basis/compiler/cfg/value-numbering/slots/slots.factor
new file mode 100644
index 0000000000..0549765072
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/slots/slots.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit cpu.architecture fry
+kernel math
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite
+compiler.cfg.value-numbering.expressions ;
+IN: compiler.cfg.value-numbering.slots
+
+: simplify-slot-addressing? ( insn -- ? )
+    complex-addressing?
+    [ slot>> vreg>expr add-imm-expr? ] [ drop f ] if ;
+
+: simplify-slot-addressing ( insn -- insn/f )
+    dup simplify-slot-addressing? [
+        dup slot>> vreg>expr
+        [ src1>> vn>vreg >>slot ]
+        [ src2>> vn>integer over scale>> '[ _ _ shift - ] change-tag ]
+        bi
+    ] [ drop f ] if ;
+
+M: ##slot rewrite simplify-slot-addressing ;
+M: ##set-slot rewrite simplify-slot-addressing ;
+M: ##write-barrier rewrite simplify-slot-addressing ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 0ad195f145..ef7357ea61 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -2209,6 +2209,25 @@ V{
 
 [ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
 
+! Slot addressing optimization
+cpu x86? [
+    [
+        V{
+            T{ ##peek f 0 D 0 }
+            T{ ##peek f 1 D 1 }
+            T{ ##add-imm f 2 1 2 }
+            T{ ##slot f 3 0 1 2 $[ 7 2 cells - ] }
+        }
+    ] [
+        V{
+            T{ ##peek f 0 D 0 }
+            T{ ##peek f 1 D 1 }
+            T{ ##add-imm f 2 1 2 }
+            T{ ##slot f 3 0 2 2 7 }
+        } value-numbering-step
+    ] unit-test
+] when
+
 ! Alien addressing optimization
 [
     V{
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index 5f8cf5f188..60ff4b2d00 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -14,7 +14,8 @@ compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.math
 compiler.cfg.value-numbering.rewrite
-compiler.cfg.value-numbering.simplify ;
+compiler.cfg.value-numbering.simplify
+compiler.cfg.value-numbering.slots ;
 IN: compiler.cfg.value-numbering
 
 ! Local value numbering.

From 378c2b2a46659ffe0fe381d16350fc1d78ae3ae8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 24 Apr 2010 00:13:44 -0400
Subject: [PATCH 115/158] compiler.cfg: add ##load-memory and ##store-memory
 instructions implementing complex addressing modes, and associated value
 numbering optimizations

---
 .../cfg/instructions/instructions.factor      |   9 ++
 .../cfg/value-numbering/alien/alien.factor    |  88 +++++++++--
 .../value-numbering-tests.factor              | 143 ++++++++++++++++++
 basis/compiler/codegen/codegen.factor         |   2 +
 basis/cpu/architecture/architecture.factor    |   2 +
 basis/cpu/x86/x86.factor                      |  42 +++--
 6 files changed, 265 insertions(+), 21 deletions(-)

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 4960722eb2..184e4076a3 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -553,11 +553,20 @@ def: dst/int-rep
 use: src/tagged-rep ;
 
 ! Raw memory accessors
+INSN: ##load-memory
+def: dst
+use: base/int-rep displacement/int-rep
+literal: scale offset rep c-type ;
+
 INSN: ##load-memory-imm
 def: dst
 use: base/int-rep
 literal: offset rep c-type ;
 
+INSN: ##store-memory
+use: src base/int-rep displacement/int-rep
+literal: scale offset rep c-type ;
+
 INSN: ##store-memory-imm
 use: src base/int-rep
 literal: offset rep c-type ;
diff --git a/basis/compiler/cfg/value-numbering/alien/alien.factor b/basis/compiler/cfg/value-numbering/alien/alien.factor
index 949cdc40b7..5b9b72f1ab 100644
--- a/basis/compiler/cfg/value-numbering/alien/alien.factor
+++ b/basis/compiler/cfg/value-numbering/alien/alien.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors fry kernel make math
+USING: accessors combinators combinators.short-circuit fry
+kernel make math sequences
 compiler.cfg.hats
 compiler.cfg.instructions
 compiler.cfg.registers
@@ -28,12 +29,81 @@ M: ##unbox-any-c-ptr rewrite
     dup src>> vreg>expr dup box-displaced-alien-expr?
     [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
 
-! More efficient addressing for alien intrinsics
-: rewrite-alien-addressing ( insn -- insn' )
-    dup base>> vreg>expr dup add-imm-expr? [
-        [ src1>> vn>vreg ] [ src2>> vn>integer ] bi
-        [ >>base ] [ '[ _ + ] change-offset ] bi*
-    ] [ 2drop f ] if ;
+! Fuse ##add-imm into ##load-memory(-imm) and ##store-memory(-imm)
+! just update the offset in the instruction
+: fuse-base-offset? ( insn -- ? )
+    base>> vreg>expr add-imm-expr? ;
 
-M: ##load-memory-imm rewrite rewrite-alien-addressing ;
-M: ##store-memory-imm rewrite rewrite-alien-addressing ;
+: fuse-base-offset ( insn -- insn' )
+    dup base>> vreg>expr
+    [ src1>> vn>vreg ] [ src2>> vn>integer ] bi
+    [ >>base ] [ '[ _ + ] change-offset ] bi* ;
+
+! Fuse ##add-imm into ##load-memory and ##store-memory
+! just update the offset in the instruction
+: fuse-displacement-offset? ( insn -- ? )
+    { [ scale>> 0 = ] [ displacement>> vreg>expr add-imm-expr? ] } 1&& ;
+
+: fuse-displacement-offset ( insn -- insn' )
+    dup displacement>> vreg>expr
+    [ src1>> vn>vreg ] [ src2>> vn>integer ] bi
+    [ >>displacement ] [ '[ _ + ] change-offset ] bi* ;
+
+! Fuse ##add into ##load-memory-imm and ##store-memory-imm
+! construct a new ##load-memory or ##store-memory with the
+! ##add's operand as the displacement
+: fuse-displacement? ( insn -- ? )
+    base>> vreg>expr add-expr? ;
+
+GENERIC: alien-insn-value ( insn -- value )
+
+M: ##load-memory-imm alien-insn-value dst>> ;
+M: ##store-memory-imm alien-insn-value src>> ;
+
+GENERIC: new-alien-insn ( value base displacement scale offset rep c-type insn -- insn )
+
+M: ##load-memory-imm new-alien-insn drop \ ##load-memory new-insn ;
+M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ;
+
+: fuse-displacement ( insn -- insn' )
+    {
+        [ alien-insn-value ]
+        [ base>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>vreg ] bi ]
+        [ drop 0 ]
+        [ offset>> ]
+        [ rep>> ]
+        [ c-type>> ]
+        [ ]
+    } cleave new-alien-insn ;
+
+! Fuse ##shl-imm into ##load-memory or ##store-memory
+: scale-expr? ( expr -- ? )
+    { [ shl-imm-expr? ] [ src2>> vn>integer { 1 2 3 } member? ] } 1&& ;
+
+: fuse-scale? ( insn -- ? )
+    { [ scale>> 0 = ] [ displacement>> vreg>expr scale-expr? ] } 1&& ;
+
+: fuse-scale ( insn -- insn' )
+    dup displacement>> vreg>expr
+    [ src1>> vn>vreg ] [ src2>> vn>integer ] bi
+    [ >>displacement ] [ >>scale ] bi* ;
+
+: rewrite-memory-op ( insn -- insn/f )
+    {
+        { [ dup fuse-base-offset? ] [ fuse-base-offset ] }
+        { [ dup fuse-displacement-offset? ] [ fuse-displacement-offset ] }
+        { [ dup fuse-scale? ] [ fuse-scale ] }
+        [ drop f ]
+    } cond ;
+
+: rewrite-memory-imm-op ( insn -- insn/f )
+    {
+        { [ dup fuse-base-offset? ] [ fuse-base-offset ] }
+        { [ dup fuse-displacement? ] [ fuse-displacement ] }
+        [ drop f ]
+    } cond ;
+
+M: ##load-memory rewrite rewrite-memory-op ;
+M: ##load-memory-imm rewrite rewrite-memory-imm-op ;
+M: ##store-memory rewrite rewrite-memory-op ;
+M: ##store-memory-imm rewrite rewrite-memory-imm-op ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index ef7357ea61..851f096ea3 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -2229,6 +2229,8 @@ cpu x86? [
 ] when
 
 ! Alien addressing optimization
+
+! Base offset fusion on ##load/store-memory-imm
 [
     V{
         T{ ##peek f 1 D 0 }
@@ -2264,3 +2266,144 @@ cpu x86? [
         T{ ##store-memory-imm f 2 4 0 int-rep c:uchar }
     } value-numbering-step
 ] unit-test
+
+! Displacement fusion on ##load/store-memory-imm
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add f 4 2 3 }
+        T{ ##load-memory f 5 2 3 0 0 int-rep c:uchar }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add f 4 2 3 }
+        T{ ##load-memory-imm f 5 4 0 int-rep c:uchar }
+    } value-numbering-step
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add f 4 2 3 }
+        T{ ##store-memory f 5 2 3 0 0 int-rep c:uchar }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add f 4 2 3 }
+        T{ ##store-memory-imm f 5 4 0 int-rep c:uchar }
+    } value-numbering-step
+] unit-test
+
+! Base offset fusion on ##load/store-memory
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add-imm f 4 2 31337 }
+        T{ ##load-memory f 5 2 3 0 31337 int-rep c:uchar }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add-imm f 4 2 31337 }
+        T{ ##load-memory f 5 4 3 0 0 int-rep c:uchar }
+    } value-numbering-step
+] unit-test
+
+! Displacement offset fusion on ##load/store-memory
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add-imm f 4 3 31337 }
+        T{ ##load-memory f 5 2 3 0 31338 int-rep c:uchar }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add-imm f 4 3 31337 }
+        T{ ##load-memory f 5 2 4 0 1 int-rep c:uchar }
+    } value-numbering-step
+] unit-test
+
+! Displacement offset fusion should not occur on
+! ##load/store-memory with non-zero scale
+[ ] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##add-imm f 4 3 10 }
+        T{ ##load-memory f 5 2 4 1 1 int-rep c:uchar }
+    } dup value-numbering-step assert=
+] unit-test
+
+! Scale fusion on ##load/store-memory
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##shl-imm f 4 3 2 }
+        T{ ##load-memory f 5 2 3 2 0 int-rep c:uchar }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##shl-imm f 4 3 2 }
+        T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
+    } value-numbering-step
+] unit-test
+
+! Don't do scale fusion if there's already a scale
+[ ] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##shl-imm f 4 3 2 }
+        T{ ##load-memory f 5 2 4 1 0 int-rep c:uchar }
+    } dup value-numbering-step assert=
+] unit-test
+
+! Don't do scale fusion if the scale factor is out of range
+[ ] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 0 }
+        T{ ##tagged>integer f 3 1 }
+        T{ ##shl-imm f 4 3 4 }
+        T{ ##load-memory f 5 2 4 0 0 int-rep c:uchar }
+    } dup value-numbering-step assert=
+] unit-test
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 0bdde0b5f7..d0747d4a1e 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -187,7 +187,9 @@ CODEGEN: ##box-alien %box-alien
 CODEGEN: ##box-displaced-alien %box-displaced-alien
 CODEGEN: ##unbox-alien %unbox-alien
 CODEGEN: ##unbox-any-c-ptr %unbox-any-c-ptr
+CODEGEN: ##load-memory %load-memory
 CODEGEN: ##load-memory-imm %load-memory-imm
+CODEGEN: ##store-memory %store-memory
 CODEGEN: ##store-memory-imm %store-memory-imm
 CODEGEN: ##allot %allot
 CODEGEN: ##write-barrier %write-barrier
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index ea98a199ed..855e272f02 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -435,7 +435,9 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 HOOK: %box-alien cpu ( dst src temp -- )
 HOOK: %box-displaced-alien cpu ( dst displacement base temp base-class -- )
 
+HOOK: %load-memory cpu ( dst base displacement scale offset rep c-type -- )
 HOOK: %load-memory-imm cpu ( dst base offset rep c-type -- )
+HOOK: %store-memory cpu ( value base displacement scale offset rep c-type -- )
 HOOK: %store-memory-imm cpu ( value base offset rep c-type -- )
 
 HOOK: %alien-global cpu ( dst symbol library -- )
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 01c11c6aec..a7fd859c20 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -354,26 +354,32 @@ M:: x86 %string-nth ( dst src index temp -- )
         dst new-dst int-rep %copy
     ] with-small-register ;
 
-:: %alien-integer-getter ( dst base offset bits quot -- )
-    dst { base } bits [| new-dst |
-        new-dst dup bits n-bit-version-of dup base offset [+] MOV
+:: %alien-integer-getter ( dst exclude address bits quot -- )
+    dst exclude bits [| new-dst |
+        new-dst dup bits n-bit-version-of dup address MOV
         quot call
         dst new-dst int-rep %copy
     ] with-small-register ; inline
 
-: %alien-unsigned-getter ( dst base offset bits -- )
+: %alien-unsigned-getter ( dst exclude address bits -- )
     [ MOVZX ] %alien-integer-getter ; inline
 
-: %alien-signed-getter ( dst base offset bits -- )
+: %alien-signed-getter ( dst exclude address bits -- )
     [ MOVSX ] %alien-integer-getter ; inline
 
-:: %alien-integer-setter ( value base offset bits -- )
-    value { base } bits [| new-value |
+:: %alien-integer-setter ( value exclude address bits -- )
+    value exclude bits [| new-value |
         new-value value int-rep %copy
-        base offset [+] new-value bits n-bit-version-of MOV
+        address new-value bits n-bit-version-of MOV
     ] with-small-register ; inline
 
-M: x86 %load-memory-imm ( dst base offset rep c-type -- )
+: (%memory) ( base displacement scale offset rep c-type -- exclude address rep c-type )
+    [ [ [ 2array ] 2keep ] 2dip <indirect> ] 2dip ;
+
+: (%memory-imm) ( base offset rep c-type -- exclude address rep c-type )
+    [ [ drop 1array ] [ [+] ] 2bi ] 2dip ;
+
+: (%load-memory) ( dst exclude address rep c-type -- )
     [
         {
             { c:char   [ 8 %alien-signed-getter ] }
@@ -383,9 +389,15 @@ M: x86 %load-memory-imm ( dst base offset rep c-type -- )
             { c:int    [ 32 [ 2drop ] %alien-integer-getter ] }
             { c:uint   [ 32 %alien-signed-getter ] }
         } case
-    ] [ [ [+] ] dip %copy ] ?if ;
+    ] [ [ drop ] 2dip %copy ] ?if ;
 
-M: x86 %store-memory-imm ( src base offset rep c-type -- )
+M: x86 %load-memory ( dst base displacement scale offset rep c-type -- )
+    (%memory) (%load-memory) ;
+
+M: x86 %load-memory-imm ( dst base offset rep c-type -- )
+    (%memory-imm) (%load-memory) ;
+
+: (%store-memory) ( src exclude address rep c-type -- )
     [
         {
             { c:char   [ 8 %alien-integer-setter ] }
@@ -395,7 +407,13 @@ M: x86 %store-memory-imm ( src base offset rep c-type -- )
             { c:int    [ 32 %alien-integer-setter ] }
             { c:uint   [ 32 %alien-integer-setter ] }
         } case
-    ] [ [ [+] swap ] dip %copy ] ?if ;
+    ] [ [ nip swap ] dip %copy ] ?if ;
+
+M: x86 %store-memory ( src base displacement scale offset rep c-type -- )
+    (%memory) (%store-memory) ;
+
+M: x86 %store-memory-imm ( src base offset rep c-type -- )
+    (%memory-imm) (%store-memory) ;
 
 : shift-count? ( reg -- ? ) { ECX RCX } member-eq? ;
 

From f14f2cbdab2e59619e6de28587e931d8ab0bb4ab Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 24 Apr 2010 02:38:43 -0400
Subject: [PATCH 116/158] compiler.cfg.value-numbering: merge 'simplify' pass
 into 'rewrite'

---
 .../cfg/alias-analysis/alias-analysis.factor  |  10 +-
 .../cfg/instructions/instructions.factor      |   2 +-
 basis/compiler/cfg/utilities/utilities.factor |   4 +-
 .../cfg/value-numbering/alien/alien.factor    |  25 +-
 .../comparisons/comparisons.factor            |  17 +-
 .../expressions/expressions.factor            |   6 +
 .../cfg/value-numbering/math/math.factor      |  52 +++-
 .../cfg/value-numbering/simd/simd.factor      |  29 +-
 .../value-numbering/simplify/simplify.factor  | 136 ---------
 .../cfg/value-numbering/simplify/summary.txt  |   1 -
 .../value-numbering-tests.factor              | 261 ++++++++++++++++--
 .../value-numbering/value-numbering.factor    |  23 +-
 12 files changed, 350 insertions(+), 216 deletions(-)
 delete mode 100644 basis/compiler/cfg/value-numbering/simplify/simplify.factor
 delete mode 100644 basis/compiler/cfg/value-numbering/simplify/summary.txt

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 4a2f2bf9aa..ba2caa1e71 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -9,6 +9,7 @@ compiler.cfg.def-use
 compiler.cfg.liveness
 compiler.cfg.copy-prop
 compiler.cfg.registers
+compiler.cfg.utilities
 compiler.cfg.comparisons
 compiler.cfg.instructions
 compiler.cfg.representations.preferred ;
@@ -245,11 +246,10 @@ M: ##allocation analyze-aliases*
 M: ##read analyze-aliases*
     call-next-method
     dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
-    2dup live-slot dup [
-        2nip any-rep \ ##copy new-insn analyze-aliases* nip
-    ] [
-        drop remember-slot
-    ] if ;
+    2dup live-slot dup
+    [ 2nip <copy> analyze-aliases* nip ]
+    [ drop remember-slot ]
+    if ;
 
 : idempotent? ( value slot#/f vreg -- ? )
     #! Are we storing a value back to the same slot it was read
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 184e4076a3..3a4de986ad 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -96,7 +96,7 @@ use: obj/tagged-rep index/int-rep
 temp: temp/int-rep ;
 
 ! Register transfers
-PURE-INSN: ##copy
+INSN: ##copy
 def: dst
 use: src
 literal: rep ;
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index bee2226ec4..de2d238f1e 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators combinators.short-circuit
 cpu.architecture kernel layouts locals make math namespaces sequences
@@ -79,3 +79,5 @@ SYMBOL: visited
 : predecessor ( bb -- pred )
     predecessors>> first ; inline
 
+: <copy> ( dst src -- insn )
+    any-rep \ ##copy new-insn ;
diff --git a/basis/compiler/cfg/value-numbering/alien/alien.factor b/basis/compiler/cfg/value-numbering/alien/alien.factor
index 5b9b72f1ab..9fc1405f6c 100644
--- a/basis/compiler/cfg/value-numbering/alien/alien.factor
+++ b/basis/compiler/cfg/value-numbering/alien/alien.factor
@@ -2,14 +2,20 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.short-circuit fry
 kernel make math sequences
+cpu.architecture
 compiler.cfg.hats
-compiler.cfg.instructions
+compiler.cfg.utilities
 compiler.cfg.registers
+compiler.cfg.instructions
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.alien
 
+M: ##box-displaced-alien rewrite
+    dup displacement>> vreg>expr expr-zero?
+    [ [ dst>> ] [ base>> ] bi <copy> ] [ drop f ] if ;
+
 ! ##box-displaced-alien f 1 2 3 <class>
 ! ##unbox-c-ptr 4 1 <class>
 ! =>
@@ -17,6 +23,9 @@ IN: compiler.cfg.value-numbering.alien
 ! ##unbox-c-ptr 5 3 <class>
 ! ##add 4 5 2
 
+: rewrite-unbox-alien ( insn expr -- insn )
+    [ dst>> ] [ src>> vn>vreg ] bi* <copy> ;
+
 : rewrite-unbox-displaced-alien ( insn expr -- insns )
     [
         [ dst>> ]
@@ -25,9 +34,17 @@ IN: compiler.cfg.value-numbering.alien
         ##add
     ] { } make ;
 
-M: ##unbox-any-c-ptr rewrite
-    dup src>> vreg>expr dup box-displaced-alien-expr?
-    [ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
+: rewrite-unbox-any-c-ptr ( insn -- insn/f )
+    dup src>> vreg>expr
+    {
+        { [ dup box-alien-expr? ] [ rewrite-unbox-alien ] }
+        { [ dup box-displaced-alien-expr? ] [ rewrite-unbox-displaced-alien ] }
+        [ 2drop f ]
+    } cond ;
+
+M: ##unbox-any-c-ptr rewrite rewrite-unbox-any-c-ptr ;
+
+M: ##unbox-alien rewrite rewrite-unbox-any-c-ptr ;
 
 ! Fuse ##add-imm into ##load-memory(-imm) and ##store-memory(-imm)
 ! just update the offset in the instruction
diff --git a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
index cd2f420af9..43a04a999b 100644
--- a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
+++ b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
@@ -3,9 +3,11 @@
 USING: accessors combinators kernel math math.order namespaces
 sequences vectors combinators.short-circuit compiler.cfg
 compiler.cfg.comparisons compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.value-numbering.expressions
+compiler.cfg.registers
+compiler.cfg.value-numbering.math
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.rewrite ;
+compiler.cfg.value-numbering.rewrite
+compiler.cfg.value-numbering.expressions ;
 IN: compiler.cfg.value-numbering.comparisons
 
 ! Optimizations performed here:
@@ -127,9 +129,6 @@ M: ##compare-integer-imm-branch rewrite
     [ vreg>integer ] dip
     \ ##compare-integer-imm-branch new-insn ; inline
 
-: self-compare? ( insn -- ? )
-    [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
-
 : evaluate-self-compare ( insn -- ? )
     cc>> { cc= cc<= cc>= } member-eq? ;
 
@@ -140,7 +139,7 @@ M: ##compare-branch rewrite
     {
         { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm-branch ] }
         { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm-branch ] }
-        { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
+        { [ dup diagonal? ] [ rewrite-self-compare-branch ] }
         [ drop f ]
     } cond ;
 
@@ -148,7 +147,7 @@ M: ##compare-integer-branch rewrite
     {
         { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm-branch ] }
         { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm-branch ] }
-        { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
+        { [ dup diagonal? ] [ rewrite-self-compare-branch ] }
         [ drop f ]
     } cond ;
 
@@ -176,7 +175,7 @@ M: ##compare rewrite
     {
         { [ dup src1>> vreg-immediate-comparand? ] [ t >compare-imm ] }
         { [ dup src2>> vreg-immediate-comparand? ] [ f >compare-imm ] }
-        { [ dup self-compare? ] [ rewrite-self-compare ] }
+        { [ dup diagonal? ] [ rewrite-self-compare ] }
         [ drop f ]
     } cond ;
 
@@ -184,7 +183,7 @@ M: ##compare-integer rewrite
     {
         { [ dup src1>> vreg-immediate-arithmetic? ] [ t >compare-integer-imm ] }
         { [ dup src2>> vreg-immediate-arithmetic? ] [ f >compare-integer-imm ] }
-        { [ dup self-compare? ] [ rewrite-self-compare ] }
+        { [ dup diagonal? ] [ rewrite-self-compare ] }
         [ drop f ]
     } cond ;
 
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index 041432c089..78097b1635 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -14,6 +14,10 @@ TUPLE: integer-expr < expr value ;
 
 C: <integer-expr> integer-expr
 
+: expr-zero? ( expr -- ? ) T{ integer-expr f 0 } = ; inline
+: expr-one? ( expr -- ? ) T{ integer-expr f 1 } = ; inline
+: expr-neg-one? ( expr -- ? ) T{ integer-expr f -1 } = ; inline
+
 TUPLE: reference-expr < expr value ;
 
 C: <reference-expr> reference-expr
@@ -34,6 +38,8 @@ GENERIC: >expr ( insn -- expr )
 
 M: insn >expr drop next-input-expr ;
 
+M: ##copy >expr "Fail" throw ;
+
 M: ##load-integer >expr val>> <integer-expr> ;
 
 M: ##load-reference >expr obj>> <reference-expr> ;
diff --git a/basis/compiler/cfg/value-numbering/math/math.factor b/basis/compiler/cfg/value-numbering/math/math.factor
index 742e995f1d..498ca946f5 100644
--- a/basis/compiler/cfg/value-numbering/math/math.factor
+++ b/basis/compiler/cfg/value-numbering/math/math.factor
@@ -3,11 +3,11 @@
 USING: accessors combinators cpu.architecture fry kernel layouts
 locals make math sequences compiler.cfg.instructions
 compiler.cfg.registers
+compiler.cfg.utilities
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.folding
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.rewrite
-compiler.cfg.value-numbering.simplify ;
+compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.math
 
 : f-expr? ( expr -- ? ) T{ reference-expr f f } = ;
@@ -19,11 +19,25 @@ M: ##tagged>integer rewrite
         [ 2drop f ]
     } cond ;
 
+: self-inverse ( insn -- insn' )
+    [ dst>> ] [ src>> vreg>expr src>> vn>vreg ] bi <copy> ;
+
+: identity ( insn -- insn' )
+    [ dst>> ] [ src1>> ] bi <copy> ;
+
 M: ##neg rewrite
-    dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ;
+    {
+        { [ dup src>> vreg>expr neg-expr? ] [ self-inverse ] }
+        { [ dup unary-constant-fold? ] [ unary-constant-fold ] }
+        [ drop f ]
+    } cond ;
 
 M: ##not rewrite
-    dup unary-constant-fold? [ unary-constant-fold ] [ drop f ] if ;
+    {
+        { [ dup src>> vreg>expr not-expr? ] [ self-inverse ] }
+        { [ dup unary-constant-fold? ] [ unary-constant-fold ] }
+        [ drop f ]
+    } cond ;
 
 ! Reassociation converts
 ! ## *-imm 2 1 X
@@ -56,20 +70,18 @@ M: ##not rewrite
 
 M: ##add-imm rewrite
     {
+        { [ dup src2>> 0 = ] [ identity ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
         { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate-arithmetic ] }
         [ drop f ]
     } cond ;
 
 : sub-imm>add-imm ( insn -- insn' )
-    [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup immediate-arithmetic?
+    [ dst>> ] [ src1>> ] [ src2>> neg ] tri
+    dup immediate-arithmetic?
     \ ##add-imm ?new-insn ;
 
-M: ##sub-imm rewrite
-    {
-        { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
-        [ sub-imm>add-imm ]
-    } cond ;
+M: ##sub-imm rewrite sub-imm>add-imm ;
 
 ! Convert ##mul-imm -1 => ##neg
 : mul-to-neg? ( insn -- ? )
@@ -129,11 +141,15 @@ M: ##and-imm rewrite
     {
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
         { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate-bitwise ] }
+        { [ dup src2>> 0 = ] [ dst>> 0 \ ##load-integer new-insn ] }
+        { [ dup src2>> -1 = ] [ identity ] }
         [ drop f ]
     } cond ;
 
 M: ##or-imm rewrite
     {
+        { [ dup src2>> 0 = ] [ identity ] }
+        { [ dup src2>> -1 = ] [ dst>> -1 \ ##load-integer new-insn ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
         { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate-bitwise ] }
         [ drop f ]
@@ -141,6 +157,8 @@ M: ##or-imm rewrite
 
 M: ##xor-imm rewrite
     {
+        { [ dup src2>> 0 = ] [ identity ] }
+        { [ dup src2>> -1 = ] [ [ dst>> ] [ src1>> ] bi \ ##not new-insn ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
         { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate-bitwise ] }
         [ drop f ]
@@ -148,6 +166,7 @@ M: ##xor-imm rewrite
 
 M: ##shl-imm rewrite
     {
+        { [ dup src2>> 0 = ] [ identity ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
         { [ dup src1>> vreg>expr shl-imm-expr? ] [ \ ##shl-imm reassociate-shift ] }
         { [ dup distribute-over-add? ] [ \ ##add-imm \ ##shl-imm distribute ] }
@@ -157,6 +176,7 @@ M: ##shl-imm rewrite
 
 M: ##shr-imm rewrite
     {
+        { [ dup src2>> 0 = ] [ identity ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
         { [ dup src1>> vreg>expr shr-imm-expr? ] [ \ ##shr-imm reassociate-shift ] }
         [ drop f ]
@@ -164,6 +184,7 @@ M: ##shr-imm rewrite
 
 M: ##sar-imm rewrite
     {
+        { [ dup src2>> 0 = ] [ identity ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
         { [ dup src1>> vreg>expr sar-imm-expr? ] [ \ ##sar-imm reassociate-shift ] }
         [ drop f ]
@@ -187,10 +208,10 @@ M: ##add rewrite
         [ drop f ]
     } cond ;
 
-! ##sub 2 1 1 => ##load-integer 2 0
-: subtraction-identity? ( insn -- ? )
-    [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ;
+: diagonal? ( insn -- ? )
+    [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi = ; inline
 
+! ##sub 2 1 1 => ##load-integer 2 0
 : rewrite-subtraction-identity ( insn -- insn' )
     dst>> 0 \ ##load-integer new-insn ;
 
@@ -207,7 +228,7 @@ M: ##add rewrite
 M: ##sub rewrite
     {
         { [ dup sub-to-neg? ] [ sub-to-neg ] }
-        { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
+        { [ dup diagonal? ] [ rewrite-subtraction-identity ] }
         { [ dup src2>> vreg-immediate-arithmetic? ] [ \ ##sub-imm f insn>imm-insn ] }
         [ drop f ]
     } cond ;
@@ -221,6 +242,7 @@ M: ##mul rewrite
 
 M: ##and rewrite
     {
+        { [ dup diagonal? ] [ identity ] }
         { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##and-imm f insn>imm-insn ] }
         { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##and-imm t insn>imm-insn ] }
         [ drop f ]
@@ -228,6 +250,7 @@ M: ##and rewrite
 
 M: ##or rewrite
     {
+        { [ dup diagonal? ] [ identity ] }
         { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##or-imm f insn>imm-insn ] }
         { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##or-imm t insn>imm-insn ] }
         [ drop f ]
@@ -235,6 +258,7 @@ M: ##or rewrite
 
 M: ##xor rewrite
     {
+        { [ dup diagonal? ] [ dst>> 0 \ ##load-integer new-insn ] }
         { [ dup src2>> vreg-immediate-bitwise? ] [ \ ##xor-imm f insn>imm-insn ] }
         { [ dup src1>> vreg-immediate-bitwise? ] [ \ ##xor-imm t insn>imm-insn ] }
         [ drop f ]
diff --git a/basis/compiler/cfg/value-numbering/simd/simd.factor b/basis/compiler/cfg/value-numbering/simd/simd.factor
index d37d16896b..940e0d5acb 100644
--- a/basis/compiler/cfg/value-numbering/simd/simd.factor
+++ b/basis/compiler/cfg/value-numbering/simd/simd.factor
@@ -7,19 +7,22 @@ vectors locals make alien.c-types io.binary grouping
 math.vectors.simd.intrinsics
 compiler.cfg
 compiler.cfg.registers
+compiler.cfg.utilities
 compiler.cfg.comparisons
 compiler.cfg.instructions
 compiler.cfg.value-numbering.alien
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.rewrite
-compiler.cfg.value-numbering.simplify ;
+compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.simd
 
 ! Some lame constant folding for SIMD intrinsics. Eventually this
 ! should be redone completely.
 
-: rewrite-shuffle-vector-imm ( insn expr -- insn' )
+: useless-shuffle-vector-imm? ( insn -- ? )
+    [ shuffle>> ] [ rep>> rep-length iota ] bi sequence= ;
+
+: compose-shuffle-vector-imm ( insn expr -- insn' )
     2dup [ rep>> ] bi@ eq? [
         [ [ dst>> ] [ src>> vn>vreg ] bi* ]
         [ [ shuffle>> ] bi@ nths ]
@@ -36,7 +39,8 @@ IN: compiler.cfg.value-numbering.simd
 
 M: ##shuffle-vector-imm rewrite
     dup src>> vreg>expr {
-        { [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] }
+        { [ over useless-shuffle-vector-imm? ] [ drop [ dst>> ] [ src>> ] bi <copy> ] }
+        { [ dup shuffle-vector-imm-expr? ] [ compose-shuffle-vector-imm ] }
         { [ dup reference-expr? ] [ fold-shuffle-vector-imm ] }
         [ 2drop f ]
     } cond ;
@@ -53,8 +57,11 @@ M: ##shuffle-vector-imm rewrite
     } case ;
 
 M: ##scalar>vector rewrite
-    dup src>> vreg>expr dup reference-expr?
-    [ fold-scalar>vector ] [ 2drop f ] if ;
+    dup src>> vreg>expr {
+        { [ dup reference-expr? ] [ fold-scalar>vector ] }
+        { [ dup vector>scalar-expr? ] [ [ dst>> ] [ src>> ] bi* <copy> ] }
+        [ 2drop f ]
+    } cond ;
 
 M: ##xor-vector rewrite
     dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
@@ -104,13 +111,3 @@ M: ##andn-vector rewrite
             [ rep>> ]
         } cleave \ ##and-vector new-insn
     ] [ drop f ] if ;
-
-M: scalar>vector-expr simplify*
-    src>> vn>expr {
-        { [ dup vector>scalar-expr? ] [ src>> ] }
-        [ drop f ]
-    } cond ;
-
-M: shuffle-vector-imm-expr simplify*
-    [ src>> ] [ shuffle>> ] [ rep>> rep-length iota ] tri
-    sequence= [ drop f ] unless ;
diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
deleted file mode 100644
index 67203a9ca7..0000000000
--- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor
+++ /dev/null
@@ -1,136 +0,0 @@
-! Copyright (C) 2008, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators classes math layouts
-sequences 
-compiler.cfg.instructions
-compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions ;
-IN: compiler.cfg.value-numbering.simplify
-
-! Return value of f means we didn't simplify.
-GENERIC: simplify* ( expr -- vn/expr/f )
-
-M: copy-expr simplify* src>> ;
-
-: simplify-unbox-alien ( expr -- vn/expr/f )
-    src>> vn>expr dup box-alien-expr? [ src>> ] [ drop f ] if ;
-
-M: unbox-alien-expr simplify* simplify-unbox-alien ;
-
-M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ;
-
-: expr-zero? ( expr -- ? ) T{ integer-expr f 0 } = ; inline
-: expr-one? ( expr -- ? ) T{ integer-expr f 1 } = ; inline
-: expr-neg-one? ( expr -- ? ) T{ integer-expr f -1 } = ; inline
-
-: >unary-expr< ( expr -- in ) src>> vn>expr ; inline
-
-M: neg-expr simplify*
-    >unary-expr< {
-        { [ dup neg-expr? ] [ src>> ] }
-        [ drop f ]
-    } cond ;
-
-M: not-expr simplify*
-    >unary-expr< {
-        { [ dup not-expr? ] [ src>> ] }
-        [ drop f ]
-    } cond ;
-
-: >binary-expr< ( expr -- in1 in2 )
-    [ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline
-
-: simplify-add ( expr -- vn/expr/f )
-    >binary-expr< {
-        { [ over expr-zero? ] [ nip ] }
-        { [ dup expr-zero? ] [ drop ] }
-        [ 2drop f ]
-    } cond ; inline
-
-M: add-expr simplify* simplify-add ;
-M: add-imm-expr simplify* simplify-add ;
-
-: simplify-sub ( expr -- vn/expr/f )
-    >binary-expr< {
-        { [ dup expr-zero? ] [ drop ] }
-        [ 2drop f ]
-    } cond ; inline
-
-M: sub-expr simplify* simplify-sub ;
-M: sub-imm-expr simplify* simplify-sub ;
-
-: simplify-mul ( expr -- vn/expr/f )
-    >binary-expr< {
-        { [ over expr-one? ] [ drop ] }
-        { [ dup expr-one? ] [ drop ] }
-        [ 2drop f ]
-    } cond ; inline
-
-M: mul-expr simplify* simplify-mul ;
-M: mul-imm-expr simplify* simplify-mul ;
-
-: simplify-and ( expr -- vn/expr/f )
-    >binary-expr< {
-        { [ 2dup eq? ] [ drop ] }
-        [ 2drop f ]
-    } cond ; inline
-
-M: and-expr simplify* simplify-and ;
-M: and-imm-expr simplify* simplify-and ;
-
-: simplify-or ( expr -- vn/expr/f )
-    >binary-expr< {
-        { [ 2dup eq? ] [ drop ] }
-        { [ over expr-zero? ] [ nip ] }
-        { [ dup expr-zero? ] [ drop ] }
-        [ 2drop f ]
-    } cond ; inline
-
-M: or-expr simplify* simplify-or ;
-M: or-imm-expr simplify* simplify-or ;
-
-: simplify-xor ( expr -- vn/expr/f )
-    >binary-expr< {
-        { [ over expr-zero? ] [ nip ] }
-        { [ dup expr-zero? ] [ drop ] }
-        [ 2drop f ]
-    } cond ; inline
-
-M: xor-expr simplify* simplify-xor ;
-M: xor-imm-expr simplify* simplify-xor ;
-
-: simplify-shr ( expr -- vn/expr/f )
-    >binary-expr< {
-        { [ dup expr-zero? ] [ drop ] }
-        [ 2drop f ]
-    } cond ; inline
-
-M: shr-expr simplify* simplify-shr ;
-M: shr-imm-expr simplify* simplify-shr ;
-
-: simplify-shl ( expr -- vn/expr/f )
-    >binary-expr< {
-        { [ dup expr-zero? ] [ drop ] }
-        [ 2drop f ]
-    } cond ; inline
-
-M: shl-expr simplify* simplify-shl ;
-M: shl-imm-expr simplify* simplify-shl ;
-
-M: box-displaced-alien-expr simplify*
-    [ base>> ] [ displacement>> ] bi {
-        { [ dup vn>expr expr-zero? ] [ drop ] }
-        [ 2drop f ]
-    } cond ;
-
-M: expr simplify* drop f ;
-
-: simplify ( expr -- vn )
-    dup simplify* {
-        { [ dup not ] [ drop expr>vn ] }
-        { [ dup expr? ] [ expr>vn nip ] }
-        { [ dup integer? ] [ nip ] }
-    } cond ;
-
-: number-values ( insn -- )
-    [ >expr simplify ] [ dst>> ] bi set-vn ;
diff --git a/basis/compiler/cfg/value-numbering/simplify/summary.txt b/basis/compiler/cfg/value-numbering/simplify/summary.txt
deleted file mode 100644
index 1027c83ce4..0000000000
--- a/basis/compiler/cfg/value-numbering/simplify/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Algebraic simplification of expressions
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 851f096ea3..0c9d386544 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -392,6 +392,20 @@ cpu x86.32? [
     } value-numbering-step
 ] unit-test
 
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##neg f 1 0 }
+        T{ ##copy f 2 0 any-rep }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##neg f 1 0 }
+        T{ ##neg f 2 1 }
+    } value-numbering-step
+] unit-test
+
 [
     {
         T{ ##peek f 0 D 0 }
@@ -727,6 +741,20 @@ cpu x86.32? [
     } value-numbering-step
 ] unit-test
 
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##copy f 1 0 any-rep }
+        T{ ##load-reference f 2 f }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##copy f 1 0 any-rep }
+        T{ ##compare-integer f 2 0 1 cc< }
+    } value-numbering-step
+] unit-test
+
 [
     {
         T{ ##peek f 0 D 0 }
@@ -1314,7 +1342,6 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
-        T{ ##load-integer f 2 0 }
         T{ ##copy f 3 0 any-rep }
         T{ ##replace f 3 D 0 }
     }
@@ -1322,8 +1349,7 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
-        T{ ##sub f 2 1 1 }
-        T{ ##add f 3 0 2 }
+        T{ ##add-imm f 3 0 0 }
         T{ ##replace f 3 D 0 }
     } value-numbering-step
 ] unit-test
@@ -1332,7 +1358,6 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
-        T{ ##load-integer f 2 0 }
         T{ ##copy f 3 0 any-rep }
         T{ ##replace f 3 D 0 }
     }
@@ -1340,8 +1365,7 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
-        T{ ##sub f 2 1 1 }
-        T{ ##sub f 3 0 2 }
+        T{ ##or-imm f 3 0 0 }
         T{ ##replace f 3 D 0 }
     } value-numbering-step
 ] unit-test
@@ -1350,7 +1374,6 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
-        T{ ##load-integer f 2 0 }
         T{ ##copy f 3 0 any-rep }
         T{ ##replace f 3 D 0 }
     }
@@ -1358,8 +1381,7 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##peek f 1 D 1 }
-        T{ ##sub f 2 1 1 }
-        T{ ##or f 3 0 2 }
+        T{ ##xor-imm f 3 0 0 }
         T{ ##replace f 3 D 0 }
     } value-numbering-step
 ] unit-test
@@ -1367,33 +1389,181 @@ cpu x86.32? [
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##peek f 1 D 1 }
-        T{ ##load-integer f 2 0 }
-        T{ ##copy f 3 0 any-rep }
-        T{ ##replace f 3 D 0 }
+        T{ ##load-integer f 1 0 }
+        T{ ##replace f 1 D 0 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##peek f 1 D 1 }
-        T{ ##sub f 2 1 1 }
-        T{ ##xor f 3 0 2 }
-        T{ ##replace f 3 D 0 }
+        T{ ##and-imm f 1 0 0 }
+        T{ ##replace f 1 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##copy f 1 0 any-rep }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##and-imm f 1 0 -1 }
+        T{ ##replace f 1 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##copy f 1 0 any-rep }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##and f 1 0 0 }
+        T{ ##replace f 1 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##copy f 1 0 any-rep }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##or-imm f 1 0 0 }
+        T{ ##replace f 1 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-integer f 1 -1 }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##or-imm f 1 0 -1 }
+        T{ ##replace f 1 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##copy f 1 0 any-rep }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##or f 1 0 0 }
+        T{ ##replace f 1 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##copy f 1 0 any-rep }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##xor-imm f 1 0 0 }
+        T{ ##replace f 1 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##not f 1 0 }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##xor-imm f 1 0 -1 }
+        T{ ##replace f 1 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-integer f 1 0 }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##xor f 1 0 0 }
+        T{ ##replace f 1 D 0 }
     } value-numbering-step
 ] unit-test
 
 [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-integer f 1 1 }
         T{ ##copy f 2 0 any-rep }
         T{ ##replace f 2 D 0 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
-        T{ ##load-integer f 1 1 }
-        T{ ##mul f 2 0 1 }
+        T{ ##mul-imm f 2 0 1 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##copy f 2 0 any-rep }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shl-imm f 2 0 0 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##copy f 2 0 any-rep }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##shr-imm f 2 0 0 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##copy f 2 0 any-rep }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##sar-imm f 2 0 0 }
         T{ ##replace f 2 D 0 }
     } value-numbering-step
 ] unit-test
@@ -1644,7 +1814,55 @@ cell 8 = [
     } value-numbering-step
 ] unit-test
 
-! Displaced alien optimizations
+! Alien boxing and unboxing
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##box-alien f 1 0 }
+        T{ ##copy f 2 0 any-rep }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##box-alien f 1 0 }
+        T{ ##unbox-alien f 2 1 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##box-alien f 1 0 }
+        T{ ##copy f 2 0 any-rep }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##box-alien f 1 0 }
+        T{ ##unbox-any-c-ptr f 2 1 }
+        T{ ##replace f 2 D 0 }
+    } value-numbering-step
+] unit-test
+
+[
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-integer f 2 0 }
+        T{ ##copy f 1 0 any-rep }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f 0 D 0 }
+        T{ ##load-integer f 2 0 }
+        T{ ##box-displaced-alien f 1 2 0 c-ptr }
+        T{ ##replace f 1 D 0 }
+    } value-numbering-step
+] unit-test
+
 3 vreg-counter set-global
 
 [
@@ -1701,6 +1919,7 @@ cell 8 = [
     } value-numbering-step
 ] unit-test
 
+! Various SIMD simplifications
 [
     {
         T{ ##vector>scalar f 1 0 float-4-rep }
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index 60ff4b2d00..dced1debb4 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs kernel accessors
 sorting sets sequences arrays
@@ -7,6 +7,7 @@ sequences.deep
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.def-use
+compiler.cfg.utilities
 compiler.cfg.instructions
 compiler.cfg.value-numbering.alien
 compiler.cfg.value-numbering.comparisons
@@ -14,22 +15,28 @@ compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.math
 compiler.cfg.value-numbering.rewrite
-compiler.cfg.value-numbering.simplify
 compiler.cfg.value-numbering.slots ;
 IN: compiler.cfg.value-numbering
 
-! Local value numbering.
-
-: >copy ( insn -- insn/##copy )
-    dup dst>> dup vreg>vn vn>vreg
-    2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ;
+: >copy ( insn vn dst -- insn/##copy )
+    swap vn>vreg 2dup eq? [ 2drop ] [ <copy> nip ] if ;
 
 GENERIC: process-instruction ( insn -- insn' )
 
 M: insn process-instruction
     dup rewrite
     [ process-instruction ]
-    [ dup defs-vreg [ dup number-values >copy ] when ] ?if ;
+    [
+        dup defs-vreg [
+            dup [ >expr expr>vn ] [ dst>> ] bi
+            [ set-vn drop ]
+            [ >copy ]
+            3bi
+        ] when
+    ] ?if ;
+
+M: ##copy process-instruction
+    dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
 
 M: array process-instruction
     [ process-instruction ] map ;

From 732f57f31d873d0671f9eb135e85cc1823a5bc02 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 24 Apr 2010 02:38:54 -0400
Subject: [PATCH 117/158] compiler.cfg.builder: fix unit tests

---
 basis/compiler/cfg/builder/builder-tests.factor | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index d28d7920ac..792b5d0902 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -172,29 +172,29 @@ IN: compiler.cfg.builder.tests
 
 [ t ] [
     [ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
-    [ ##store-memory-imm? ] contains-insn?
+    [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
 ] unit-test
 
 [ t ] [
     [ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
-    [ ##store-memory-imm? ] contains-insn?
+    [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
 ] unit-test
 
 [ f ] [
     [ { byte-array fixnum } declare set-alien-unsigned-1 ]
-    [ ##store-memory-imm? ] contains-insn?
+    [ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
 ] unit-test
 
 [ t t ] [
     [ { byte-array fixnum } declare alien-cell ]
-    [ [ ##load-memory-imm? ] contains-insn? ]
+    [ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn? ]
     [ [ ##box-alien? ] contains-insn? ]
     bi
 ] unit-test
 
 [ f ] [
     [ { byte-array integer } declare alien-cell ]
-    [ ##load-memory-imm? ] contains-insn?
+    [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn?
 ] unit-test
 
 [ f ] [

From 9cea3f2c93effbe95e426da7062bc042ded30380 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 24 Apr 2010 03:08:17 -0400
Subject: [PATCH 118/158] compiler.cfg.ssa.liveness: remove unused pass

---
 .../cfg/ssa/liveness/liveness-tests.factor    | 291 ------------------
 .../compiler/cfg/ssa/liveness/liveness.factor | 130 --------
 2 files changed, 421 deletions(-)
 delete mode 100644 basis/compiler/cfg/ssa/liveness/liveness-tests.factor
 delete mode 100644 basis/compiler/cfg/ssa/liveness/liveness.factor

diff --git a/basis/compiler/cfg/ssa/liveness/liveness-tests.factor b/basis/compiler/cfg/ssa/liveness/liveness-tests.factor
deleted file mode 100644
index bc5807087d..0000000000
--- a/basis/compiler/cfg/ssa/liveness/liveness-tests.factor
+++ /dev/null
@@ -1,291 +0,0 @@
-! Copyright (C) 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test namespaces sequences vectors accessors sets
-arrays math.ranges assocs
-cpu.architecture
-compiler.cfg
-compiler.cfg.ssa.liveness.private
-compiler.cfg.ssa.liveness 
-compiler.cfg.debugger
-compiler.cfg.instructions
-compiler.cfg.predecessors
-compiler.cfg.registers
-compiler.cfg.dominance
-compiler.cfg.def-use ;
-IN: compiler.cfg.ssa.liveness
-
-[ t ] [ { 1 } 1 only? ] unit-test
-[ t ] [ { } 1 only? ] unit-test
-[ f ] [ { 2 1 } 1 only? ] unit-test
-[ f ] [ { 2 } 1 only? ] unit-test
-
-: test-liveness ( -- )
-    cfg new 0 get >>entry
-    dup compute-defs
-    dup compute-uses
-    needs-dominance
-    precompute-liveness ;
-
-V{
-    T{ ##peek f 0 D 0 }
-    T{ ##replace f 0 D 0 }
-    T{ ##replace f 1 D 1 }
-} 0 test-bb
-
-V{
-    T{ ##replace f 2 D 0 }
-} 1 test-bb
-
-V{
-    T{ ##replace f 3 D 0 }
-} 2 test-bb
-
-0 { 1 2 } edges
-
-[ ] [ test-liveness ] unit-test
-
-[ H{ } ] [ back-edge-targets get ] unit-test
-[ t ] [ 0 get R_q { 0 1 2 } [ get ] map unique = ] unit-test
-[ t ] [ 1 get R_q { 1 } [ get ] map unique = ] unit-test
-[ t ] [ 2 get R_q { 2 } [ get ] map unique = ] unit-test
-
-: self-T_q ( n -- ? )
-    get [ T_q ] [ 1array unique ] bi = ;
-
-[ t ] [ 0 self-T_q ] unit-test
-[ t ] [ 1 self-T_q ] unit-test
-[ t ] [ 2 self-T_q ] unit-test
-
-[ f ] [ 0 0 get live-in? ] unit-test
-[ t ] [ 1 0 get live-in? ] unit-test
-[ t ] [ 2 0 get live-in? ] unit-test
-[ t ] [ 3 0 get live-in? ] unit-test
-
-[ f ] [ 0 0 get live-out? ] unit-test
-[ f ] [ 1 0 get live-out? ] unit-test
-[ t ] [ 2 0 get live-out? ] unit-test
-[ t ] [ 3 0 get live-out? ] unit-test
-
-[ f ] [ 0 1 get live-in? ] unit-test
-[ f ] [ 1 1 get live-in? ] unit-test
-[ t ] [ 2 1 get live-in? ] unit-test
-[ f ] [ 3 1 get live-in? ] unit-test
-
-[ f ] [ 0 1 get live-out? ] unit-test
-[ f ] [ 1 1 get live-out? ] unit-test
-[ f ] [ 2 1 get live-out? ] unit-test
-[ f ] [ 3 1 get live-out? ] unit-test
-
-[ f ] [ 0 2 get live-in? ] unit-test
-[ f ] [ 1 2 get live-in? ] unit-test
-[ f ] [ 2 2 get live-in? ] unit-test
-[ t ] [ 3 2 get live-in? ] unit-test
-
-[ f ] [ 0 2 get live-out? ] unit-test
-[ f ] [ 1 2 get live-out? ] unit-test
-[ f ] [ 2 2 get live-out? ] unit-test
-[ f ] [ 3 2 get live-out? ] unit-test
-
-V{ } 0 test-bb
-V{ } 1 test-bb
-V{ } 2 test-bb
-V{ } 3 test-bb
-V{
-    T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
-} 4 test-bb
-test-diamond
-
-[ ] [ test-liveness ] unit-test
-
-[ t ] [ 0 1 get live-in? ] unit-test
-[ t ] [ 1 1 get live-in? ] unit-test
-[ f ] [ 2 1 get live-in? ] unit-test
-
-[ t ] [ 0 1 get live-out? ] unit-test
-[ t ] [ 1 1 get live-out? ] unit-test
-[ f ] [ 2 1 get live-out? ] unit-test
-
-[ t ] [ 0 2 get live-in? ] unit-test
-[ f ] [ 1 2 get live-in? ] unit-test
-[ f ] [ 2 2 get live-in? ] unit-test
-
-[ f ] [ 0 2 get live-out? ] unit-test
-[ f ] [ 1 2 get live-out? ] unit-test
-[ f ] [ 2 2 get live-out? ] unit-test
-
-[ f ] [ 0 3 get live-in? ] unit-test
-[ t ] [ 1 3 get live-in? ] unit-test
-[ f ] [ 2 3 get live-in? ] unit-test
-
-[ f ] [ 0 3 get live-out? ] unit-test
-[ f ] [ 1 3 get live-out? ] unit-test
-[ f ] [ 2 3 get live-out? ] unit-test
-
-[ f ] [ 0 4 get live-in? ] unit-test
-[ f ] [ 1 4 get live-in? ] unit-test
-[ f ] [ 2 4 get live-in? ] unit-test
-
-[ f ] [ 0 4 get live-out? ] unit-test
-[ f ] [ 1 4 get live-out? ] unit-test
-[ f ] [ 2 4 get live-out? ] unit-test
-
-! This is the CFG in Figure 3 from the paper
-V{ } 0 test-bb
-V{ } 1 test-bb
-0 1 edge
-V{ } 2 test-bb
-1 2 edge
-V{
-    T{ ##peek f 0 D 0 }
-    T{ ##peek f 1 D 0 }
-    T{ ##peek f 2 D 0 }
-} 3 test-bb
-V{ } 11 test-bb
-2 { 3 11 } edges
-V{
-    T{ ##replace f 0 D 0 }
-} 4 test-bb
-V{ } 8 test-bb
-3 { 8 4 } edges
-V{
-    T{ ##replace f 1 D 0 }
-} 9 test-bb
-8 9 edge
-V{
-    T{ ##replace f 2 D 0 }
-} 5 test-bb
-4 5 edge
-V{ } 10 test-bb
-V{ } 6 test-bb
-5 6 edge
-9 { 6 10 } edges
-V{ } 7 test-bb
-6 { 5 7 } edges
-10 8 edge
-7 2 edge
-
-[ ] [ test-liveness ] unit-test
-
-[ t ] [ 1 get R_q 1 11 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 2 get R_q 2 11 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 3 get R_q 3 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 4 get R_q 4 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 5 get R_q 5 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 6 get R_q 6 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 7 get R_q 7 7 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 8 get R_q 6 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 9 get R_q 8 6 10 [a,b] remove [ get ] map unique = ] unit-test
-[ t ] [ 10 get R_q 10 10 [a,b] [ get ] map unique = ] unit-test
-[ t ] [ 11 get R_q 11 11 [a,b] [ get ] map unique = ] unit-test
-
-[ t ] [ 1 get T_q 1 get 1array unique = ] unit-test
-[ t ] [ 2 get T_q 2 get 1array unique = ] unit-test
-[ t ] [ 3 get T_q 3 get 2 get 2array unique = ] unit-test
-[ t ] [ 4 get T_q 4 get 2 get 2array unique = ] unit-test
-[ t ] [ 5 get T_q 5 get 2 get 2array unique = ] unit-test
-[ t ] [ 6 get T_q { 6 2 5 } [ get ] map unique = ] unit-test
-[ t ] [ 7 get T_q { 7 2 } [ get ] map unique = ] unit-test
-[ t ] [ 8 get T_q { 8 2 5 } [ get ] map unique = ] unit-test
-[ t ] [ 9 get T_q { 2 5 8 9 } [ get ] map unique = ] unit-test
-[ t ] [ 10 get T_q { 2 5 8 10 } [ get ] map unique = ] unit-test
-[ t ] [ 11 get T_q 11 get 1array unique = ] unit-test
-
-[ f ] [ 1 get back-edge-target? ] unit-test
-[ t ] [ 2 get back-edge-target? ] unit-test
-[ f ] [ 3 get back-edge-target? ] unit-test
-[ f ] [ 4 get back-edge-target? ] unit-test
-[ t ] [ 5 get back-edge-target? ] unit-test
-[ f ] [ 6 get back-edge-target? ] unit-test
-[ f ] [ 7 get back-edge-target? ] unit-test
-[ t ] [ 8 get back-edge-target? ] unit-test
-[ f ] [ 9 get back-edge-target? ] unit-test
-[ f ] [ 10 get back-edge-target? ] unit-test
-[ f ] [ 11 get back-edge-target? ] unit-test
-
-[ f ] [ 0 1 get live-in? ] unit-test
-[ f ] [ 1 1 get live-in? ] unit-test
-[ f ] [ 2 1 get live-in? ] unit-test
-
-[ f ] [ 0 1 get live-out? ] unit-test
-[ f ] [ 1 1 get live-out? ] unit-test
-[ f ] [ 2 1 get live-out? ] unit-test
-
-[ f ] [ 0 2 get live-in? ] unit-test
-[ f ] [ 1 2 get live-in? ] unit-test
-[ f ] [ 2 2 get live-in? ] unit-test
-
-[ f ] [ 0 2 get live-out? ] unit-test
-[ f ] [ 1 2 get live-out? ] unit-test
-[ f ] [ 2 2 get live-out? ] unit-test
-
-[ f ] [ 0 3 get live-in? ] unit-test
-[ f ] [ 1 3 get live-in? ] unit-test
-[ f ] [ 2 3 get live-in? ] unit-test
-
-[ t ] [ 0 3 get live-out? ] unit-test
-[ t ] [ 1 3 get live-out? ] unit-test
-[ t ] [ 2 3 get live-out? ] unit-test
-
-[ t ] [ 0 4 get live-in? ] unit-test
-[ f ] [ 1 4 get live-in? ] unit-test
-[ t ] [ 2 4 get live-in? ] unit-test
-
-[ f ] [ 0 4 get live-out? ] unit-test
-[ f ] [ 1 4 get live-out? ] unit-test
-[ t ] [ 2 4 get live-out? ] unit-test
-
-[ f ] [ 0 5 get live-in? ] unit-test
-[ f ] [ 1 5 get live-in? ] unit-test
-[ t ] [ 2 5 get live-in? ] unit-test
-
-[ f ] [ 0 5 get live-out? ] unit-test
-[ f ] [ 1 5 get live-out? ] unit-test
-[ t ] [ 2 5 get live-out? ] unit-test
-
-[ f ] [ 0 6 get live-in? ] unit-test
-[ f ] [ 1 6 get live-in? ] unit-test
-[ t ] [ 2 6 get live-in? ] unit-test
-
-[ f ] [ 0 6 get live-out? ] unit-test
-[ f ] [ 1 6 get live-out? ] unit-test
-[ t ] [ 2 6 get live-out? ] unit-test
-
-[ f ] [ 0 7 get live-in? ] unit-test
-[ f ] [ 1 7 get live-in? ] unit-test
-[ f ] [ 2 7 get live-in? ] unit-test
-
-[ f ] [ 0 7 get live-out? ] unit-test
-[ f ] [ 1 7 get live-out? ] unit-test
-[ f ] [ 2 7 get live-out? ] unit-test
-
-[ f ] [ 0 8 get live-in? ] unit-test
-[ t ] [ 1 8 get live-in? ] unit-test
-[ t ] [ 2 8 get live-in? ] unit-test
-
-[ f ] [ 0 8 get live-out? ] unit-test
-[ t ] [ 1 8 get live-out? ] unit-test
-[ t ] [ 2 8 get live-out? ] unit-test
-
-[ f ] [ 0 9 get live-in? ] unit-test
-[ t ] [ 1 9 get live-in? ] unit-test
-[ t ] [ 2 9 get live-in? ] unit-test
-
-[ f ] [ 0 9 get live-out? ] unit-test
-[ t ] [ 1 9 get live-out? ] unit-test
-[ t ] [ 2 9 get live-out? ] unit-test
-
-[ f ] [ 0 10 get live-in? ] unit-test
-[ t ] [ 1 10 get live-in? ] unit-test
-[ t ] [ 2 10 get live-in? ] unit-test
-
-[ f ] [ 0 10 get live-out? ] unit-test
-[ t ] [ 1 10 get live-out? ] unit-test
-[ t ] [ 2 10 get live-out? ] unit-test
-
-[ f ] [ 0 11 get live-in? ] unit-test
-[ f ] [ 1 11 get live-in? ] unit-test
-[ f ] [ 2 11 get live-in? ] unit-test
-
-[ f ] [ 0 11 get live-out? ] unit-test
-[ f ] [ 1 11 get live-out? ] unit-test
-[ f ] [ 2 11 get live-out? ] unit-test
diff --git a/basis/compiler/cfg/ssa/liveness/liveness.factor b/basis/compiler/cfg/ssa/liveness/liveness.factor
deleted file mode 100644
index 6e84b8b77d..0000000000
--- a/basis/compiler/cfg/ssa/liveness/liveness.factor
+++ /dev/null
@@ -1,130 +0,0 @@
-! Copyright (C) 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences assocs accessors
-namespaces fry math sets combinators locals
-compiler.cfg.rpo
-compiler.cfg.dominance
-compiler.cfg.def-use
-compiler.cfg.instructions ;
-FROM: namespaces => set ;
-IN: compiler.cfg.ssa.liveness
-
-! Liveness checking on SSA IR, as described in
-! "Fast Liveness Checking for SSA-Form Programs", Sebastian Hack et al.
-! http://hal.archives-ouvertes.fr/docs/00/19/22/19/PDF/fast_liveness.pdf
-
-<PRIVATE
-
-! The sets T_q and R_q are described there
-SYMBOL: T_q-sets
-SYMBOL: R_q-sets
-
-! Targets of back edges
-SYMBOL: back-edge-targets
-
-: T_q ( q -- T_q )
-    T_q-sets get at ;
-
-: R_q ( q -- R_q )
-    R_q-sets get at ;
-
-: back-edge-target? ( block -- ? )
-    back-edge-targets get key? ;
-
-: next-R_q ( q -- R_q )
-    [ ] [ successors>> ] [ number>> ] tri
-    '[ number>> _ >= ] filter
-    [ R_q ] map assoc-combine
-    [ conjoin ] keep ;
-
-: set-R_q ( q -- )
-    [ next-R_q ] keep R_q-sets get set-at ;
-
-: set-back-edges ( q -- )
-    [ successors>> ] [ number>> ] bi '[
-        dup number>> _ < 
-        [ back-edge-targets get conjoin ] [ drop ] if
-    ] each ;
-
-: init-R_q ( -- )
-    H{ } clone R_q-sets set
-    H{ } clone back-edge-targets set ;
-
-: compute-R_q ( cfg -- )
-    init-R_q
-    post-order [
-        [ set-R_q ] [ set-back-edges ] bi
-    ] each ;
-
-! This algorithm for computing T_q uses equation (1)
-! but not the faster algorithm described in the paper
-
-: back-edges-from ( q -- edges )
-    R_q keys [
-        [ successors>> ] [ number>> ] bi
-        '[ number>> _ < ] filter
-    ] gather ;
-
-: T^_q ( q -- T^_q )
-    [ back-edges-from ] [ R_q ] bi
-    '[ _ key? not ] filter ;
-
-: next-T_q ( q -- T_q )
-    dup dup T^_q [ next-T_q keys ] map 
-    concat unique [ conjoin ] keep
-    [ swap T_q-sets get set-at ] keep ;
-
-: compute-T_q ( cfg -- )
-    H{ } T_q-sets set
-    [ next-T_q drop ] each-basic-block ;
-
-PRIVATE>
-
-: precompute-liveness ( cfg -- )
-    [ compute-R_q ] [ compute-T_q ] bi ;
-
-<PRIVATE
-
-! This doesn't take advantage of ordering T_q,a so you 
-! only have to check one if the CFG is reducible.
-! It should be changed to be more efficient.
-
-: only? ( seq obj -- ? )
-    '[ _ eq? ] all? ;
-
-: strictly-dominates? ( bb1 bb2 -- ? )
-    [ dominates? ] [ eq? not ] 2bi and ;
-
-: T_q,a ( a q -- T_q,a )
-    ! This could take advantage of the structure of dominance,
-    ! but probably I'll replace it with the algorithm that works
-    ! on reducible CFGs anyway
-    T_q keys swap def-of 
-    [ '[ _ swap strictly-dominates? ] filter ] when* ;
-
-: live? ( vreg node quot -- ? )
-    [ [ T_q,a ] [ drop uses-of ] 2bi ] dip
-    '[ [ R_q keys _ ] keep @ intersects? ] any? ; inline
-
-PRIVATE>
-
-: live-in? ( vreg node -- ? )
-    [ drop ] live? ;
-
-<PRIVATE
-
-: (live-out?) ( vreg node -- ? )
-    dup dup dup '[
-        _ = _ back-edge-target? not and
-        [ _ swap remove ] when
-    ] live? ;
-
-PRIVATE>
-
-:: live-out? ( vreg node -- ? )
-    vreg def-of :> def
-    {
-        { [ node def eq? ] [ vreg uses-of def only? not ] }
-        { [ def node strictly-dominates? ] [ vreg node (live-out?) ] }
-        [ f ]
-    } cond ;

From f548a086376864327ab53d07d686eb15a55aa478 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 24 Apr 2010 04:49:35 -0400
Subject: [PATCH 119/158] compiler.cfg.value-numbering: remove constant -vs-
 literal distinction

---
 .../cfg/instructions/instructions.factor      | 41 ++++++++-----------
 .../cfg/instructions/syntax/syntax.factor     |  3 +-
 .../cfg/value-numbering/alien/alien.factor    | 10 ++---
 .../comparisons/comparisons.factor            |  4 +-
 .../expressions/expressions.factor            | 27 +++---------
 .../cfg/value-numbering/graph/graph.factor    |  3 +-
 .../cfg/value-numbering/math/math.factor      |  8 ++--
 .../cfg/value-numbering/simd/simd.factor      |  2 +-
 .../cfg/value-numbering/slots/slots.factor    |  2 +-
 9 files changed, 39 insertions(+), 61 deletions(-)

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 3a4de986ad..13c9f55b9f 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -23,20 +23,20 @@ TUPLE: pure-insn < insn ;
 ! Constants
 INSN: ##load-integer
 def: dst/int-rep
-constant: val/int-rep ;
+literal: val ;
 
 INSN: ##load-reference
 def: dst/tagged-rep
-constant: obj/tagged-rep ;
+literal: obj ;
 
 ! These two are inserted by representation selection
 INSN: ##load-tagged
 def: dst/tagged-rep
-constant: val/tagged-rep ;
+literal: val ;
 
 INSN: ##load-double
 def: dst/double-rep
-constant: val/double-rep ;
+literal: val ;
 
 ! Stack operations
 INSN: ##peek
@@ -113,7 +113,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##add-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2/int-rep ;
+literal: src2 ;
 
 PURE-INSN: ##sub
 def: dst/int-rep
@@ -122,7 +122,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##sub-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2/int-rep ;
+literal: src2 ;
 
 PURE-INSN: ##mul
 def: dst/int-rep
@@ -131,7 +131,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##mul-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2/int-rep ;
+literal: src2 ;
 
 PURE-INSN: ##and
 def: dst/int-rep
@@ -140,7 +140,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##and-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2/int-rep ;
+literal: src2 ;
 
 PURE-INSN: ##or
 def: dst/int-rep
@@ -149,7 +149,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##or-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2/int-rep ;
+literal: src2 ;
 
 PURE-INSN: ##xor
 def: dst/int-rep
@@ -158,7 +158,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##xor-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2/int-rep ;
+literal: src2 ;
 
 PURE-INSN: ##shl
 def: dst/int-rep
@@ -167,7 +167,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##shl-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2/int-rep ;
+literal: src2 ;
 
 PURE-INSN: ##shr
 def: dst/int-rep
@@ -176,7 +176,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##shr-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2/int-rep ;
+literal: src2 ;
 
 PURE-INSN: ##sar
 def: dst/int-rep
@@ -185,7 +185,7 @@ use: src1/int-rep src2/int-rep ;
 PURE-INSN: ##sar-imm
 def: dst/int-rep
 use: src1/int-rep
-constant: src2/int-rep ;
+literal: src2 ;
 
 PURE-INSN: ##min
 def: dst/int-rep
@@ -629,8 +629,7 @@ literal: cc ;
 
 INSN: ##compare-imm-branch
 use: src1/tagged-rep
-constant: src2/tagged-rep
-literal: cc ;
+literal: src2 cc ;
 
 PURE-INSN: ##compare
 def: dst/tagged-rep
@@ -641,8 +640,7 @@ temp: temp/int-rep ;
 PURE-INSN: ##compare-imm
 def: dst/tagged-rep
 use: src1/tagged-rep
-constant: src2/tagged-rep
-literal: cc
+literal: src2 cc
 temp: temp/int-rep ;
 
 ! Integer conditionals
@@ -652,8 +650,7 @@ literal: cc ;
 
 INSN: ##compare-integer-imm-branch
 use: src1/int-rep
-constant: src2/int-rep
-literal: cc ;
+literal: src2 cc ;
 
 PURE-INSN: ##compare-integer
 def: dst/tagged-rep
@@ -664,8 +661,7 @@ temp: temp/int-rep ;
 PURE-INSN: ##compare-integer-imm
 def: dst/tagged-rep
 use: src1/int-rep
-constant: src2/int-rep
-literal: cc
+literal: src2 cc
 temp: temp/int-rep ;
 
 ! Float conditionals
@@ -739,8 +735,7 @@ literal: cc ;
 INSN: _compare-imm-branch
 literal: label
 use: src1
-constant: src2
-literal: cc ;
+literal: src2 cc ;
 
 INSN: _compare-float-unordered-branch
 literal: label
diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor
index afca252bdc..7b8327cf06 100644
--- a/basis/compiler/cfg/instructions/syntax/syntax.factor
+++ b/basis/compiler/cfg/instructions/syntax/syntax.factor
@@ -5,7 +5,7 @@ make fry sequences parser accessors effects namespaces
 combinators splitting classes.parser lexer quotations ;
 IN: compiler.cfg.instructions.syntax
 
-SYMBOLS: def use temp literal constant ;
+SYMBOLS: def use temp literal ;
 
 SYMBOL: scalar-rep
 
@@ -31,7 +31,6 @@ TUPLE: insn-slot-spec type name rep ;
                 { "use:" [ drop use ] }
                 { "temp:" [ drop temp ] }
                 { "literal:" [ drop literal ] }
-                { "constant:" [ drop constant ] }
                 [ dupd parse-insn-slot-spec , ]
             } case
         ] reduce drop
diff --git a/basis/compiler/cfg/value-numbering/alien/alien.factor b/basis/compiler/cfg/value-numbering/alien/alien.factor
index 9fc1405f6c..cdb56aa9d1 100644
--- a/basis/compiler/cfg/value-numbering/alien/alien.factor
+++ b/basis/compiler/cfg/value-numbering/alien/alien.factor
@@ -13,7 +13,7 @@ compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.alien
 
 M: ##box-displaced-alien rewrite
-    dup displacement>> vreg>expr expr-zero?
+    dup displacement>> vreg>expr zero-expr?
     [ [ dst>> ] [ base>> ] bi <copy> ] [ drop f ] if ;
 
 ! ##box-displaced-alien f 1 2 3 <class>
@@ -53,7 +53,7 @@ M: ##unbox-alien rewrite rewrite-unbox-any-c-ptr ;
 
 : fuse-base-offset ( insn -- insn' )
     dup base>> vreg>expr
-    [ src1>> vn>vreg ] [ src2>> vn>integer ] bi
+    [ src1>> vn>vreg ] [ src2>> ] bi
     [ >>base ] [ '[ _ + ] change-offset ] bi* ;
 
 ! Fuse ##add-imm into ##load-memory and ##store-memory
@@ -63,7 +63,7 @@ M: ##unbox-alien rewrite rewrite-unbox-any-c-ptr ;
 
 : fuse-displacement-offset ( insn -- insn' )
     dup displacement>> vreg>expr
-    [ src1>> vn>vreg ] [ src2>> vn>integer ] bi
+    [ src1>> vn>vreg ] [ src2>> ] bi
     [ >>displacement ] [ '[ _ + ] change-offset ] bi* ;
 
 ! Fuse ##add into ##load-memory-imm and ##store-memory-imm
@@ -95,14 +95,14 @@ M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ;
 
 ! Fuse ##shl-imm into ##load-memory or ##store-memory
 : scale-expr? ( expr -- ? )
-    { [ shl-imm-expr? ] [ src2>> vn>integer { 1 2 3 } member? ] } 1&& ;
+    { [ shl-imm-expr? ] [ src2>> { 1 2 3 } member? ] } 1&& ;
 
 : fuse-scale? ( insn -- ? )
     { [ scale>> 0 = ] [ displacement>> vreg>expr scale-expr? ] } 1&& ;
 
 : fuse-scale ( insn -- insn' )
     dup displacement>> vreg>expr
-    [ src1>> vn>vreg ] [ src2>> vn>integer ] bi
+    [ src1>> vn>vreg ] [ src2>> ] bi
     [ >>displacement ] [ >>scale ] bi* ;
 
 : rewrite-memory-op ( insn -- insn/f )
diff --git a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
index 43a04a999b..eb6d72f512 100644
--- a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
+++ b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
@@ -39,13 +39,13 @@ IN: compiler.cfg.value-numbering.comparisons
     [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
 
 : >compare-imm-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> vn>comparand ] [ cc>> ] tri ; inline
+    [ src1>> vn>vreg ] [ src2>> ] [ cc>> ] tri ; inline
 
 : >compare-integer-expr< ( expr -- in1 in2 cc )
     [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
 
 : >compare-integer-imm-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> vn>integer ] [ cc>> ] tri ; inline
+    [ src1>> vn>vreg ] [ src2>> ] [ cc>> ] tri ; inline
 
 : >test-vector-expr< ( expr -- src1 temp rep vcc )
     {
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index 78097b1635..b7b7155285 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -14,9 +14,7 @@ TUPLE: integer-expr < expr value ;
 
 C: <integer-expr> integer-expr
 
-: expr-zero? ( expr -- ? ) T{ integer-expr f 0 } = ; inline
-: expr-one? ( expr -- ? ) T{ integer-expr f 1 } = ; inline
-: expr-neg-one? ( expr -- ? ) T{ integer-expr f -1 } = ; inline
+: zero-expr? ( expr -- ? ) T{ integer-expr f 0 } = ; inline
 
 TUPLE: reference-expr < expr value ;
 
@@ -44,14 +42,6 @@ M: ##load-integer >expr val>> <integer-expr> ;
 
 M: ##load-reference >expr obj>> <reference-expr> ;
 
-GENERIC: expr>reference ( expr -- obj )
-
-M: reference-expr expr>reference value>> ;
-
-: vn>reference ( vn -- obj ) vn>expr expr>reference ;
-
-: vreg>reference ( vreg -- obj ) vreg>vn vn>reference ; inline
-
 GENERIC: expr>integer ( expr -- n )
 
 M: integer-expr expr>integer value>> ;
@@ -92,7 +82,7 @@ M: reference-expr expr>comparand value>> ;
 <<
 
 : input-values ( slot-specs -- slot-specs' )
-    [ type>> { use literal constant } member-eq? ] filter ;
+    [ type>> { use literal } member-eq? ] filter ;
 
 : expr-class ( insn -- expr )
     name>> "##" ?head drop "-expr" append create-class-in ;
@@ -100,20 +90,13 @@ M: reference-expr expr>comparand value>> ;
 : define-expr-class ( expr slot-specs -- )
     [ expr ] dip [ name>> ] map define-tuple-class ;
 
-: constant-quot ( rep -- quot )
-    {
-        { int-rep [ [ <integer-expr> ] ] }
-        { tagged-rep [ [ <reference-expr> ] ] }
-    } case [ expr>vn ] append ;
-
 : >expr-quot ( expr slot-specs -- quot )
      [
         [ name>> reader-word 1quotation ]
         [
-            [ rep>> ] [ type>> ] bi {
-                { use [ drop [ vreg>vn ] ] }
-                { literal [ drop [ ] ] }
-                { constant [ constant-quot ] }
+            type>> {
+                { use [ [ vreg>vn ] ] }
+                { literal [ [ ] ] }
             } case
         ] bi append
     ] map cleave>quot swap suffix \ boa suffix ;
diff --git a/basis/compiler/cfg/value-numbering/graph/graph.factor b/basis/compiler/cfg/value-numbering/graph/graph.factor
index 8ba09b125d..0e9dcb6076 100644
--- a/basis/compiler/cfg/value-numbering/graph/graph.factor
+++ b/basis/compiler/cfg/value-numbering/graph/graph.factor
@@ -3,9 +3,10 @@
 USING: accessors kernel math namespaces assocs biassocs ;
 IN: compiler.cfg.value-numbering.graph
 
+! Value numbers are negative, to catch confusion with vregs
 SYMBOL: vn-counter
 
-: next-vn ( -- vn ) vn-counter [ dup 1 + ] change ;
+: next-vn ( -- vn ) vn-counter [ 1 - dup ] change ;
 
 ! biassoc mapping expressions to value numbers
 SYMBOL: exprs>vns
diff --git a/basis/compiler/cfg/value-numbering/math/math.factor b/basis/compiler/cfg/value-numbering/math/math.factor
index 498ca946f5..219aa82795 100644
--- a/basis/compiler/cfg/value-numbering/math/math.factor
+++ b/basis/compiler/cfg/value-numbering/math/math.factor
@@ -10,7 +10,7 @@ compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.math
 
-: f-expr? ( expr -- ? ) T{ reference-expr f f } = ;
+: f-expr? ( expr -- ? ) T{ reference-expr f f } = ; inline
 
 M: ##tagged>integer rewrite
     [ dst>> ] [ src>> vreg>expr ] bi {
@@ -49,7 +49,7 @@ M: ##not rewrite
 : (reassociate) ( insn -- dst src1 src2' src2'' )
     {
         [ dst>> ]
-        [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>integer ] bi ]
+        [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> ] bi ]
         [ src2>> ]
     } cleave ; inline
 
@@ -122,7 +122,7 @@ M: ##sub-imm rewrite sub-imm>add-imm ;
 : distribute ( insn add-op mul-op -- new-insns/f )
     [
         dup src1>> vreg>expr
-        2dup src2>> vn>integer swap [ src2>> ] keep binary-constant-fold*
+        2dup src2>> swap [ src2>> ] keep binary-constant-fold*
         next-vreg
     ] 2dip (distribute) ; inline
 
@@ -220,7 +220,7 @@ M: ##add rewrite
 ! =>
 ! ##neg 3 2
 : sub-to-neg? ( ##sub -- ? )
-    src1>> vn>expr expr-zero? ;
+    src1>> vreg>expr zero-expr? ;
 
 : sub-to-neg ( ##sub -- insn )
     [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
diff --git a/basis/compiler/cfg/value-numbering/simd/simd.factor b/basis/compiler/cfg/value-numbering/simd/simd.factor
index 940e0d5acb..6d39a29c14 100644
--- a/basis/compiler/cfg/value-numbering/simd/simd.factor
+++ b/basis/compiler/cfg/value-numbering/simd/simd.factor
@@ -59,7 +59,7 @@ M: ##shuffle-vector-imm rewrite
 M: ##scalar>vector rewrite
     dup src>> vreg>expr {
         { [ dup reference-expr? ] [ fold-scalar>vector ] }
-        { [ dup vector>scalar-expr? ] [ [ dst>> ] [ src>> ] bi* <copy> ] }
+        { [ dup vector>scalar-expr? ] [ [ dst>> ] [ src>> vn>vreg ] bi* <copy> ] }
         [ 2drop f ]
     } cond ;
 
diff --git a/basis/compiler/cfg/value-numbering/slots/slots.factor b/basis/compiler/cfg/value-numbering/slots/slots.factor
index 0549765072..21dac9dcfb 100644
--- a/basis/compiler/cfg/value-numbering/slots/slots.factor
+++ b/basis/compiler/cfg/value-numbering/slots/slots.factor
@@ -16,7 +16,7 @@ IN: compiler.cfg.value-numbering.slots
     dup simplify-slot-addressing? [
         dup slot>> vreg>expr
         [ src1>> vn>vreg >>slot ]
-        [ src2>> vn>integer over scale>> '[ _ _ shift - ] change-tag ]
+        [ src2>> over scale>> '[ _ _ shift - ] change-tag ]
         bi
     ] [ drop f ] if ;
 

From edaf59bf468e944f94edffc0ac3a6d826fe6bc69 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 24 Apr 2010 06:06:16 -0400
Subject: [PATCH 120/158] compiler.cfg.value-numbering: maintain a VN to
 instruction mapping. This eliminates all instances of expression inspection,
 allowing the auto-generated expression classes to be removed

---
 .../cfg/value-numbering/alien/alien.factor    |  47 +++---
 .../comparisons/comparisons.factor            |  81 +++++------
 .../expressions/expressions.factor            | 134 ++++++++++--------
 .../value-numbering/folding/folding.factor    |   4 +-
 .../cfg/value-numbering/graph/graph.factor    |  37 +++--
 .../cfg/value-numbering/math/math.factor      |  55 +++----
 .../cfg/value-numbering/simd/simd.factor      |  61 ++++----
 .../cfg/value-numbering/slots/slots.factor    |   6 +-
 .../value-numbering/value-numbering.factor    |  30 ++--
 9 files changed, 231 insertions(+), 224 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/alien/alien.factor b/basis/compiler/cfg/value-numbering/alien/alien.factor
index cdb56aa9d1..8b508550b4 100644
--- a/basis/compiler/cfg/value-numbering/alien/alien.factor
+++ b/basis/compiler/cfg/value-numbering/alien/alien.factor
@@ -7,13 +7,14 @@ compiler.cfg.hats
 compiler.cfg.utilities
 compiler.cfg.registers
 compiler.cfg.instructions
-compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.math
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.rewrite ;
+compiler.cfg.value-numbering.rewrite
+compiler.cfg.value-numbering.expressions ;
 IN: compiler.cfg.value-numbering.alien
 
 M: ##box-displaced-alien rewrite
-    dup displacement>> vreg>expr zero-expr?
+    dup displacement>> vreg>insn zero-insn?
     [ [ dst>> ] [ base>> ] bi <copy> ] [ drop f ] if ;
 
 ! ##box-displaced-alien f 1 2 3 <class>
@@ -23,22 +24,22 @@ M: ##box-displaced-alien rewrite
 ! ##unbox-c-ptr 5 3 <class>
 ! ##add 4 5 2
 
-: rewrite-unbox-alien ( insn expr -- insn )
-    [ dst>> ] [ src>> vn>vreg ] bi* <copy> ;
+: rewrite-unbox-alien ( insn box-insn -- insn )
+    [ dst>> ] [ src>> ] bi* <copy> ;
 
-: rewrite-unbox-displaced-alien ( insn expr -- insns )
+: rewrite-unbox-displaced-alien ( insn box-insn -- insns )
     [
         [ dst>> ]
-        [ [ base>> vn>vreg ] [ base-class>> ] [ displacement>> vn>vreg ] tri ] bi*
+        [ [ base>> ] [ base-class>> ] [ displacement>> ] tri ] bi*
         [ ^^unbox-c-ptr ] dip
         ##add
     ] { } make ;
 
 : rewrite-unbox-any-c-ptr ( insn -- insn/f )
-    dup src>> vreg>expr
+    dup src>> vreg>insn
     {
-        { [ dup box-alien-expr? ] [ rewrite-unbox-alien ] }
-        { [ dup box-displaced-alien-expr? ] [ rewrite-unbox-displaced-alien ] }
+        { [ dup ##box-alien? ] [ rewrite-unbox-alien ] }
+        { [ dup ##box-displaced-alien? ] [ rewrite-unbox-displaced-alien ] }
         [ 2drop f ]
     } cond ;
 
@@ -49,28 +50,28 @@ M: ##unbox-alien rewrite rewrite-unbox-any-c-ptr ;
 ! Fuse ##add-imm into ##load-memory(-imm) and ##store-memory(-imm)
 ! just update the offset in the instruction
 : fuse-base-offset? ( insn -- ? )
-    base>> vreg>expr add-imm-expr? ;
+    base>> vreg>insn ##add-imm? ;
 
 : fuse-base-offset ( insn -- insn' )
-    dup base>> vreg>expr
-    [ src1>> vn>vreg ] [ src2>> ] bi
+    dup base>> vreg>insn
+    [ src1>> ] [ src2>> ] bi
     [ >>base ] [ '[ _ + ] change-offset ] bi* ;
 
 ! Fuse ##add-imm into ##load-memory and ##store-memory
 ! just update the offset in the instruction
 : fuse-displacement-offset? ( insn -- ? )
-    { [ scale>> 0 = ] [ displacement>> vreg>expr add-imm-expr? ] } 1&& ;
+    { [ scale>> 0 = ] [ displacement>> vreg>insn ##add-imm? ] } 1&& ;
 
 : fuse-displacement-offset ( insn -- insn' )
-    dup displacement>> vreg>expr
-    [ src1>> vn>vreg ] [ src2>> ] bi
+    dup displacement>> vreg>insn
+    [ src1>> ] [ src2>> ] bi
     [ >>displacement ] [ '[ _ + ] change-offset ] bi* ;
 
 ! Fuse ##add into ##load-memory-imm and ##store-memory-imm
 ! construct a new ##load-memory or ##store-memory with the
 ! ##add's operand as the displacement
 : fuse-displacement? ( insn -- ? )
-    base>> vreg>expr add-expr? ;
+    base>> vreg>insn ##add? ;
 
 GENERIC: alien-insn-value ( insn -- value )
 
@@ -85,7 +86,7 @@ M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ;
 : fuse-displacement ( insn -- insn' )
     {
         [ alien-insn-value ]
-        [ base>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>vreg ] bi ]
+        [ base>> vreg>insn [ src1>> ] [ src2>> ] bi ]
         [ drop 0 ]
         [ offset>> ]
         [ rep>> ]
@@ -94,15 +95,15 @@ M: ##store-memory-imm new-alien-insn drop \ ##store-memory new-insn ;
     } cleave new-alien-insn ;
 
 ! Fuse ##shl-imm into ##load-memory or ##store-memory
-: scale-expr? ( expr -- ? )
-    { [ shl-imm-expr? ] [ src2>> { 1 2 3 } member? ] } 1&& ;
+: scale-insn? ( insn -- ? )
+    { [ ##shl-imm? ] [ src2>> { 1 2 3 } member? ] } 1&& ;
 
 : fuse-scale? ( insn -- ? )
-    { [ scale>> 0 = ] [ displacement>> vreg>expr scale-expr? ] } 1&& ;
+    { [ scale>> 0 = ] [ displacement>> vreg>insn scale-insn? ] } 1&& ;
 
 : fuse-scale ( insn -- insn' )
-    dup displacement>> vreg>expr
-    [ src1>> vn>vreg ] [ src2>> ] bi
+    dup displacement>> vreg>insn
+    [ src1>> ] [ src2>> ] bi
     [ >>displacement ] [ >>scale ] bi* ;
 
 : rewrite-memory-op ( insn -- insn/f )
diff --git a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
index eb6d72f512..d9af124f30 100644
--- a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
+++ b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
@@ -18,8 +18,10 @@ IN: compiler.cfg.value-numbering.comparisons
 ! 3) Folding comparisons where both inputs are congruent
 ! 4) Converting compare instructions into compare-imm instructions
 
+UNION: literal-insn ##load-integer ##load-reference ;
+
 : fold-compare-imm? ( insn -- ? )
-    src1>> vreg>expr literal-expr? ;
+    src1>> vreg>insn literal-insn? ;
 
 : evaluate-compare-imm ( insn -- ? )
     [ src1>> vreg>comparand ] [ src2>> ] [ cc>> ] tri
@@ -29,64 +31,49 @@ IN: compiler.cfg.value-numbering.comparisons
     } case ;
 
 : fold-compare-integer-imm? ( insn -- ? )
-    src1>> vreg>expr integer-expr? ;
+    src1>> vreg>insn ##load-integer? ;
 
 : evaluate-compare-integer-imm ( insn -- ? )
     [ src1>> vreg>integer ] [ src2>> ] [ cc>> ] tri
     [ <=> ] dip evaluate-cc ;
 
-: >compare-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
+: >compare< ( insn -- in1 in2 cc )
+    [ src1>> ] [ src2>> ] [ cc>> ] tri ; inline
 
-: >compare-imm-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> ] [ cc>> ] tri ; inline
-
-: >compare-integer-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
-
-: >compare-integer-imm-expr< ( expr -- in1 in2 cc )
-    [ src1>> vn>vreg ] [ src2>> ] [ cc>> ] tri ; inline
-
-: >test-vector-expr< ( expr -- src1 temp rep vcc )
+: >test-vector< ( insn -- src1 temp rep vcc )
     {
-        [ src1>> vn>vreg ]
+        [ src1>> ]
         [ drop next-vreg ]
         [ rep>> ]
         [ vcc>> ]
     } cleave ; inline
 
-: scalar-compare-expr? ( insn -- ? )
-    {
-        [ compare-expr? ]
-        [ compare-imm-expr? ]
-        [ compare-integer-expr? ]
-        [ compare-integer-imm-expr? ]
-        [ compare-float-unordered-expr? ]
-        [ compare-float-ordered-expr? ]
-    } 1|| ;
+UNION: scalar-compare-insn
+    ##compare
+    ##compare-imm
+    ##compare-integer
+    ##compare-integer-imm
+    ##compare-float-unordered
+    ##compare-float-ordered ;
 
-: general-compare-expr? ( insn -- ? )
-    {
-        [ scalar-compare-expr? ]
-        [ test-vector-expr? ]
-    } 1|| ;
+UNION: general-compare-insn scalar-compare-insn ##test-vector ;
 
 : rewrite-boolean-comparison? ( insn -- ? )
     {
-        [ src1>> vreg>expr general-compare-expr? ]
+        [ src1>> vreg>insn general-compare-insn? ]
         [ src2>> not ]
         [ cc>> cc/= eq? ]
     } 1&& ; inline
 
-: rewrite-boolean-comparison ( expr -- insn )
-    src1>> vreg>expr {
-        { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
-        { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
-        { [ dup compare-integer-expr? ] [ >compare-integer-expr< \ ##compare-integer-branch new-insn ] }
-        { [ dup compare-integer-imm-expr? ] [ >compare-integer-imm-expr< \ ##compare-integer-imm-branch new-insn ] }
-        { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
-        { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] }
-        { [ dup test-vector-expr? ] [ >test-vector-expr< \ ##test-vector-branch new-insn ] }
+: rewrite-boolean-comparison ( insn -- insn )
+    src1>> vreg>insn {
+        { [ dup ##compare? ] [ >compare< \ ##compare-branch new-insn ] }
+        { [ dup ##compare-imm? ] [ >compare< \ ##compare-imm-branch new-insn ] }
+        { [ dup ##compare-integer? ] [ >compare< \ ##compare-integer-branch new-insn ] }
+        { [ dup ##compare-integer-imm? ] [ >compare< \ ##compare-integer-imm-branch new-insn ] }
+        { [ dup ##compare-float-unordered? ] [ >compare< \ ##compare-float-unordered-branch new-insn ] }
+        { [ dup ##compare-float-ordered? ] [ >compare< \ ##compare-float-ordered-branch new-insn ] }
+        { [ dup ##test-vector? ] [ >test-vector< \ ##test-vector-branch new-insn ] }
     } cond ;
 
 : fold-branch ( ? -- insn )
@@ -189,19 +176,19 @@ M: ##compare-integer rewrite
 
 : rewrite-redundant-comparison? ( insn -- ? )
     {
-        [ src1>> vreg>expr scalar-compare-expr? ]
+        [ src1>> vreg>insn scalar-compare-insn? ]
         [ src2>> not ]
         [ cc>> { cc= cc/= } member? ]
     } 1&& ; inline
 
 : rewrite-redundant-comparison ( insn -- insn' )
-    [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
-        { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
-        { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
-        { [ dup compare-integer-expr? ] [ >compare-integer-expr< next-vreg \ ##compare-integer new-insn ] }
-        { [ dup compare-integer-imm-expr? ] [ >compare-integer-imm-expr< next-vreg \ ##compare-integer-imm new-insn ] }
-        { [ dup compare-float-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
-        { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered new-insn ] }
+    [ cc>> ] [ dst>> ] [ src1>> vreg>insn ] tri {
+        { [ dup ##compare? ] [ >compare< next-vreg \ ##compare new-insn ] }
+        { [ dup ##compare-imm? ] [ >compare< next-vreg \ ##compare-imm new-insn ] }
+        { [ dup ##compare-integer? ] [ >compare< next-vreg \ ##compare-integer new-insn ] }
+        { [ dup ##compare-integer-imm? ] [ >compare< next-vreg \ ##compare-integer-imm new-insn ] }
+        { [ dup ##compare-float-unordered? ] [ >compare< next-vreg \ ##compare-float-unordered new-insn ] }
+        { [ dup ##compare-float-ordered? ] [ >compare< next-vreg \ ##compare-float-ordered new-insn ] }
     } cond
     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index b7b7155285..ffd2efbd21 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -1,22 +1,69 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes classes.algebra classes.parser
+USING: accessors arrays classes classes.algebra classes.parser
 classes.tuple combinators combinators.short-circuit fry
 generic.parser kernel layouts math namespaces quotations
-sequences slots splitting words
+sequences slots splitting words make
 cpu.architecture
 compiler.cfg.instructions
 compiler.cfg.instructions.syntax
 compiler.cfg.value-numbering.graph ;
+FROM: sequences.private => set-array-nth ;
 IN: compiler.cfg.value-numbering.expressions
 
-TUPLE: integer-expr < expr value ;
+<<
+
+GENERIC: >expr ( insn -- expr )
+
+: input-values ( slot-specs -- slot-specs' )
+    [ type>> { use literal } member-eq? ] filter ;
+
+: slot->expr-quot ( slot-spec -- quot )
+    [ name>> reader-word 1quotation ]
+    [
+        type>> {
+            { use [ [ vreg>vn ] ] }
+            { literal [ [ ] ] }
+        } case
+    ] bi append ;
+
+: narray-quot ( length -- quot )
+    [
+        [ , [ f <array> ] % ]
+        [ 
+            dup iota [
+                - 1 - , [ swap [ set-array-nth ] keep ] %
+            ] with each
+        ] bi
+    ] [ ] make ;
+
+: >expr-quot ( insn slot-specs -- quot )
+    [
+        [ literalize , \ swap , ]
+        [
+            [ [ slot->expr-quot ] map cleave>quot % ]
+            [ length 1 + narray-quot % ]
+            bi
+        ] bi*
+    ] [ ] make ;
+
+: define->expr-method ( insn slot-specs -- )
+    [ drop \ >expr create-method-in ] [ >expr-quot ] 2bi define ;
+
+insn-classes get
+[ pure-insn class<= ] filter
+[
+    dup "insn-slots" word-prop input-values
+    define->expr-method
+] each
+
+>>
+
+TUPLE: integer-expr value ;
 
 C: <integer-expr> integer-expr
 
-: zero-expr? ( expr -- ? ) T{ integer-expr f 0 } = ; inline
-
-TUPLE: reference-expr < expr value ;
+TUPLE: reference-expr value ;
 
 C: <reference-expr> reference-expr
 
@@ -30,9 +77,11 @@ M: reference-expr equal?
 M: reference-expr hashcode*
     nip value>> dup float? [ double>bits ] [ identity-hashcode ] if ;
 
-UNION: literal-expr integer-expr reference-expr ;
+! Expressions whose values are inputs to the basic block.
+TUPLE: input-expr n ;
 
-GENERIC: >expr ( insn -- expr )
+: next-input-expr ( -- expr )
+    input-expr-counter counter input-expr boa ;
 
 M: insn >expr drop next-input-expr ;
 
@@ -42,72 +91,35 @@ M: ##load-integer >expr val>> <integer-expr> ;
 
 M: ##load-reference >expr obj>> <reference-expr> ;
 
-GENERIC: expr>integer ( expr -- n )
+GENERIC: insn>integer ( insn -- n )
 
-M: integer-expr expr>integer value>> ;
+M: ##load-integer insn>integer val>> ;
 
-: vn>integer ( vn -- n ) vn>expr expr>integer ;
-
-: vreg>integer ( vreg -- n ) vreg>vn vn>integer ; inline
+: vreg>integer ( vreg -- n ) vreg>insn insn>integer ; inline
 
 : vreg-immediate-arithmetic? ( vreg -- ? )
-    vreg>expr {
-        [ integer-expr? ]
-        [ expr>integer immediate-arithmetic? ]
+    vreg>insn {
+        [ ##load-integer? ]
+        [ val>> immediate-arithmetic? ]
     } 1&& ;
 
 : vreg-immediate-bitwise? ( vreg -- ? )
-    vreg>expr {
-        [ integer-expr? ]
-        [ expr>integer immediate-bitwise? ]
+    vreg>insn {
+        [ ##load-integer? ]
+        [ val>> immediate-bitwise? ]
     } 1&& ;
 
-GENERIC: expr>comparand ( expr -- n )
+GENERIC: insn>comparand ( expr -- n )
 
-M: integer-expr expr>comparand value>> tag-fixnum ;
+M: ##load-integer insn>comparand val>> tag-fixnum ;
 
-M: reference-expr expr>comparand value>> ;
+M: ##load-reference insn>comparand obj>> ;
 
-: vn>comparand ( vn -- n ) vn>expr expr>comparand ;
-
-: vreg>comparand ( vreg -- n ) vreg>vn vn>comparand ; inline
+: vreg>comparand ( vreg -- n ) vreg>insn insn>comparand ; inline
 
 : vreg-immediate-comparand? ( vreg -- ? )
-    vreg>expr {
-        { [ dup integer-expr? ] [ expr>integer tag-fixnum immediate-comparand? ] }
-        { [ dup reference-expr? ] [ value>> immediate-comparand? ] }
+    vreg>insn {
+        { [ dup ##load-integer? ] [ val>> tag-fixnum immediate-comparand? ] }
+        { [ dup ##load-reference? ] [ obj>> immediate-comparand? ] }
         [ drop f ]
     } cond ;
-
-<<
-
-: input-values ( slot-specs -- slot-specs' )
-    [ type>> { use literal } member-eq? ] filter ;
-
-: expr-class ( insn -- expr )
-    name>> "##" ?head drop "-expr" append create-class-in ;
-
-: define-expr-class ( expr slot-specs -- )
-    [ expr ] dip [ name>> ] map define-tuple-class ;
-
-: >expr-quot ( expr slot-specs -- quot )
-     [
-        [ name>> reader-word 1quotation ]
-        [
-            type>> {
-                { use [ [ vreg>vn ] ] }
-                { literal [ [ ] ] }
-            } case
-        ] bi append
-    ] map cleave>quot swap suffix \ boa suffix ;
-
-: define->expr-method ( insn expr slot-specs -- )
-    [ \ >expr create-method-in ] 2dip >expr-quot define ;
-
-: handle-pure-insn ( insn -- )
-    [ ] [ expr-class ] [ "insn-slots" word-prop input-values ] tri
-    [ define-expr-class drop ] [ define->expr-method ] 3bi ;
-
-insn-classes get [ pure-insn class<= ] filter [ handle-pure-insn ] each
-
->>
diff --git a/basis/compiler/cfg/value-numbering/folding/folding.factor b/basis/compiler/cfg/value-numbering/folding/folding.factor
index 3cd9df8b4b..6e70e3f80f 100644
--- a/basis/compiler/cfg/value-numbering/folding/folding.factor
+++ b/basis/compiler/cfg/value-numbering/folding/folding.factor
@@ -7,7 +7,7 @@ compiler.cfg.value-numbering.graph ;
 IN: compiler.cfg.value-numbering.folding
 
 : binary-constant-fold? ( insn -- ? )
-    src1>> vreg>expr integer-expr? ; inline
+    src1>> vreg>insn ##load-integer? ; inline
 
 GENERIC: binary-constant-fold* ( x y insn -- z )
 
@@ -27,7 +27,7 @@ M: ##shl-imm binary-constant-fold* drop shift ;
     \ ##load-integer new-insn ; inline
 
 : unary-constant-fold? ( insn -- ? )
-    src>> vreg>expr integer-expr? ; inline
+    src>> vreg>insn ##load-integer? ; inline
 
 GENERIC: unary-constant-fold* ( x insn -- y )
 
diff --git a/basis/compiler/cfg/value-numbering/graph/graph.factor b/basis/compiler/cfg/value-numbering/graph/graph.factor
index 0e9dcb6076..bef4956f5e 100644
--- a/basis/compiler/cfg/value-numbering/graph/graph.factor
+++ b/basis/compiler/cfg/value-numbering/graph/graph.factor
@@ -6,38 +6,33 @@ IN: compiler.cfg.value-numbering.graph
 ! Value numbers are negative, to catch confusion with vregs
 SYMBOL: vn-counter
 
-: next-vn ( -- vn ) vn-counter [ 1 - dup ] change ;
-
-! biassoc mapping expressions to value numbers
-SYMBOL: exprs>vns
-
-TUPLE: expr ;
-
-: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
-
-: vn>expr ( vn -- expr ) exprs>vns get value-at ;
-
-! Expressions whose values are inputs to the basic block.
-TUPLE: input-expr < expr n ;
-
 SYMBOL: input-expr-counter
 
-: next-input-expr ( -- expr )
-    input-expr-counter counter input-expr boa ;
+: next-vn ( -- vn ) vn-counter [ 1 - dup ] change ;
 
+! assoc mapping expressions to value numbers
+SYMBOL: exprs>vns
+
+! assoc mapping value numbers to instructions
+SYMBOL: vns>insns
+
+: vn>insn ( vn -- insn ) vns>insns get at ;
+
+! biassocs mapping vregs to value numbers, and value numbers to
+! their primary vregs
 SYMBOL: vregs>vns
 
-: vreg>vn ( vreg -- vn )
-    vregs>vns get [ drop next-input-expr expr>vn ] cache ;
+: vreg>vn ( vreg -- vn ) vregs>vns get [ drop next-vn ] cache ;
 
 : vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
 
 : set-vn ( vn vreg -- ) vregs>vns get set-at ;
 
-: vreg>expr ( vreg -- expr ) vreg>vn vn>expr ; inline
+: vreg>insn ( vreg -- insn ) vreg>vn vn>insn ; inline
 
 : init-value-graph ( -- )
     0 vn-counter set
     0 input-expr-counter set
-    <bihash> exprs>vns set
-    <bihash> vregs>vns set ;
+    <bihash> vregs>vns set
+    H{ } clone exprs>vns set
+    H{ } clone vns>insns set ;
diff --git a/basis/compiler/cfg/value-numbering/math/math.factor b/basis/compiler/cfg/value-numbering/math/math.factor
index 219aa82795..557fce7d50 100644
--- a/basis/compiler/cfg/value-numbering/math/math.factor
+++ b/basis/compiler/cfg/value-numbering/math/math.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators cpu.architecture fry kernel layouts
-locals make math sequences compiler.cfg.instructions
+USING: accessors combinators combinators.short-circuit
+cpu.architecture fry kernel layouts locals make math sequences
+compiler.cfg.instructions
 compiler.cfg.registers
 compiler.cfg.utilities
 compiler.cfg.value-numbering.expressions
@@ -10,31 +11,35 @@ compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.math
 
-: f-expr? ( expr -- ? ) T{ reference-expr f f } = ; inline
+: f-insn? ( insn -- ? )
+    { [ ##load-reference? ] [ obj>> not ] } 1&& ; inline
+
+: zero-insn? ( insn -- ? )
+    { [ ##load-integer? ] [ val>> 0 = ] } 1&& ; inline
 
 M: ##tagged>integer rewrite
-    [ dst>> ] [ src>> vreg>expr ] bi {
-        { [ dup integer-expr? ] [ value>> tag-fixnum \ ##load-integer new-insn ] }
-        { [ dup f-expr? ] [ drop \ f type-number \ ##load-integer new-insn ] }
+    [ dst>> ] [ src>> vreg>insn ] bi {
+        { [ dup ##load-integer? ] [ val>> tag-fixnum \ ##load-integer new-insn ] }
+        { [ dup f-insn? ] [ drop \ f type-number \ ##load-integer new-insn ] }
         [ 2drop f ]
     } cond ;
 
 : self-inverse ( insn -- insn' )
-    [ dst>> ] [ src>> vreg>expr src>> vn>vreg ] bi <copy> ;
+    [ dst>> ] [ src>> vreg>insn src>> ] bi <copy> ;
 
 : identity ( insn -- insn' )
     [ dst>> ] [ src1>> ] bi <copy> ;
 
 M: ##neg rewrite
     {
-        { [ dup src>> vreg>expr neg-expr? ] [ self-inverse ] }
+        { [ dup src>> vreg>insn ##neg? ] [ self-inverse ] }
         { [ dup unary-constant-fold? ] [ unary-constant-fold ] }
         [ drop f ]
     } cond ;
 
 M: ##not rewrite
     {
-        { [ dup src>> vreg>expr not-expr? ] [ self-inverse ] }
+        { [ dup src>> vreg>insn ##not? ] [ self-inverse ] }
         { [ dup unary-constant-fold? ] [ unary-constant-fold ] }
         [ drop f ]
     } cond ;
@@ -49,7 +54,7 @@ M: ##not rewrite
 : (reassociate) ( insn -- dst src1 src2' src2'' )
     {
         [ dst>> ]
-        [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> ] bi ]
+        [ src1>> vreg>insn [ src1>> ] [ src2>> ] bi ]
         [ src2>> ]
     } cleave ; inline
 
@@ -72,7 +77,7 @@ M: ##add-imm rewrite
     {
         { [ dup src2>> 0 = ] [ identity ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
-        { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate-arithmetic ] }
+        { [ dup src1>> vreg>insn ##add-imm? ] [ \ ##add-imm reassociate-arithmetic ] }
         [ drop f ]
     } cond ;
 
@@ -105,23 +110,23 @@ M: ##sub-imm rewrite sub-imm>add-imm ;
 ! ##+-imm 3 4 X*Y
 ! Where * is mul or shl, + is add or sub
 ! Have to make sure that X*Y fits in an immediate
-:: (distribute) ( insn expr imm temp add-op mul-op -- new-insns/f )
+:: (distribute) ( outer inner imm temp add-op mul-op -- new-outers/f )
     imm immediate-arithmetic? [
         [
-            temp expr src1>> vn>vreg insn src2>> mul-op execute
-            insn dst>> temp imm add-op execute
+            temp inner src1>> outer src2>> mul-op execute
+            outer dst>> temp imm add-op execute
         ] { } make
     ] [ f ] if ; inline
 
 : distribute-over-add? ( insn -- ? )
-    src1>> vreg>expr add-imm-expr? ;
+    src1>> vreg>insn ##add-imm? ;
 
 : distribute-over-sub? ( insn -- ? )
-    src1>> vreg>expr sub-imm-expr? ;
+    src1>> vreg>insn ##sub-imm? ;
 
 : distribute ( insn add-op mul-op -- new-insns/f )
     [
-        dup src1>> vreg>expr
+        dup src1>> vreg>insn
         2dup src2>> swap [ src2>> ] keep binary-constant-fold*
         next-vreg
     ] 2dip (distribute) ; inline
@@ -131,7 +136,7 @@ M: ##mul-imm rewrite
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
         { [ dup mul-to-neg? ] [ mul-to-neg ] }
         { [ dup mul-to-shl? ] [ mul-to-shl ] }
-        { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate-arithmetic ] }
+        { [ dup src1>> vreg>insn ##mul-imm? ] [ \ ##mul-imm reassociate-arithmetic ] }
         { [ dup distribute-over-add? ] [ \ ##add-imm \ ##mul-imm distribute ] }
         { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##mul-imm distribute ] }
         [ drop f ]
@@ -140,7 +145,7 @@ M: ##mul-imm rewrite
 M: ##and-imm rewrite
     {
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
-        { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate-bitwise ] }
+        { [ dup src1>> vreg>insn ##and-imm? ] [ \ ##and-imm reassociate-bitwise ] }
         { [ dup src2>> 0 = ] [ dst>> 0 \ ##load-integer new-insn ] }
         { [ dup src2>> -1 = ] [ identity ] }
         [ drop f ]
@@ -151,7 +156,7 @@ M: ##or-imm rewrite
         { [ dup src2>> 0 = ] [ identity ] }
         { [ dup src2>> -1 = ] [ dst>> -1 \ ##load-integer new-insn ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
-        { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate-bitwise ] }
+        { [ dup src1>> vreg>insn ##or-imm? ] [ \ ##or-imm reassociate-bitwise ] }
         [ drop f ]
     } cond ;
 
@@ -160,7 +165,7 @@ M: ##xor-imm rewrite
         { [ dup src2>> 0 = ] [ identity ] }
         { [ dup src2>> -1 = ] [ [ dst>> ] [ src1>> ] bi \ ##not new-insn ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
-        { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate-bitwise ] }
+        { [ dup src1>> vreg>insn ##xor-imm? ] [ \ ##xor-imm reassociate-bitwise ] }
         [ drop f ]
     } cond ;
 
@@ -168,7 +173,7 @@ M: ##shl-imm rewrite
     {
         { [ dup src2>> 0 = ] [ identity ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
-        { [ dup src1>> vreg>expr shl-imm-expr? ] [ \ ##shl-imm reassociate-shift ] }
+        { [ dup src1>> vreg>insn ##shl-imm? ] [ \ ##shl-imm reassociate-shift ] }
         { [ dup distribute-over-add? ] [ \ ##add-imm \ ##shl-imm distribute ] }
         { [ dup distribute-over-sub? ] [ \ ##sub-imm \ ##shl-imm distribute ] }
         [ drop f ]
@@ -178,7 +183,7 @@ M: ##shr-imm rewrite
     {
         { [ dup src2>> 0 = ] [ identity ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
-        { [ dup src1>> vreg>expr shr-imm-expr? ] [ \ ##shr-imm reassociate-shift ] }
+        { [ dup src1>> vreg>insn ##shr-imm? ] [ \ ##shr-imm reassociate-shift ] }
         [ drop f ]
     } cond ;
 
@@ -186,7 +191,7 @@ M: ##sar-imm rewrite
     {
         { [ dup src2>> 0 = ] [ identity ] }
         { [ dup binary-constant-fold? ] [ binary-constant-fold ] }
-        { [ dup src1>> vreg>expr sar-imm-expr? ] [ \ ##sar-imm reassociate-shift ] }
+        { [ dup src1>> vreg>insn ##sar-imm? ] [ \ ##sar-imm reassociate-shift ] }
         [ drop f ]
     } cond ;
 
@@ -220,7 +225,7 @@ M: ##add rewrite
 ! =>
 ! ##neg 3 2
 : sub-to-neg? ( ##sub -- ? )
-    src1>> vreg>expr zero-expr? ;
+    src1>> vreg>insn zero-insn? ;
 
 : sub-to-neg ( ##sub -- insn )
     [ dst>> ] [ src2>> ] bi \ ##neg new-insn ;
diff --git a/basis/compiler/cfg/value-numbering/simd/simd.factor b/basis/compiler/cfg/value-numbering/simd/simd.factor
index 6d39a29c14..4aabfd3d9a 100644
--- a/basis/compiler/cfg/value-numbering/simd/simd.factor
+++ b/basis/compiler/cfg/value-numbering/simd/simd.factor
@@ -10,9 +10,9 @@ compiler.cfg.registers
 compiler.cfg.utilities
 compiler.cfg.comparisons
 compiler.cfg.instructions
-compiler.cfg.value-numbering.alien
-compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.math
 compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.simd
 
@@ -22,9 +22,9 @@ IN: compiler.cfg.value-numbering.simd
 : useless-shuffle-vector-imm? ( insn -- ? )
     [ shuffle>> ] [ rep>> rep-length iota ] bi sequence= ;
 
-: compose-shuffle-vector-imm ( insn expr -- insn' )
+: compose-shuffle-vector-imm ( outer inner -- insn' )
     2dup [ rep>> ] bi@ eq? [
-        [ [ dst>> ] [ src>> vn>vreg ] bi* ]
+        [ [ dst>> ] [ src>> ] bi* ]
         [ [ shuffle>> ] bi@ nths ]
         [ drop rep>> ]
         2tri \ ##shuffle-vector-imm new-insn
@@ -33,15 +33,15 @@ IN: compiler.cfg.value-numbering.simd
 : (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' )
     2dup length swap length /i group nths concat ;
 
-: fold-shuffle-vector-imm ( insn expr -- insn' )
-    [ [ dst>> ] [ shuffle>> ] bi ] dip value>>
+: fold-shuffle-vector-imm ( outer inner -- insn' )
+    [ [ dst>> ] [ shuffle>> ] bi ] [ obj>> ] bi*
     (fold-shuffle-vector-imm) \ ##load-reference new-insn ;
 
 M: ##shuffle-vector-imm rewrite
-    dup src>> vreg>expr {
+    dup src>> vreg>insn {
         { [ over useless-shuffle-vector-imm? ] [ drop [ dst>> ] [ src>> ] bi <copy> ] }
-        { [ dup shuffle-vector-imm-expr? ] [ compose-shuffle-vector-imm ] }
-        { [ dup reference-expr? ] [ fold-shuffle-vector-imm ] }
+        { [ dup ##shuffle-vector-imm? ] [ compose-shuffle-vector-imm ] }
+        { [ dup ##load-reference? ] [ fold-shuffle-vector-imm ] }
         [ 2drop f ]
     } cond ;
 
@@ -49,52 +49,55 @@ M: ##shuffle-vector-imm rewrite
     [ [ dst>> ] [ rep>> rep-length ] bi ] dip <repetition> concat
     \ ##load-reference new-insn ;
 
-: fold-scalar>vector ( insn expr -- insn' )
-    value>> over rep>> {
+: fold-scalar>vector ( outer inner -- insn' )
+    obj>> over rep>> {
         { float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
         { double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
         [ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ]
     } case ;
 
 M: ##scalar>vector rewrite
-    dup src>> vreg>expr {
-        { [ dup reference-expr? ] [ fold-scalar>vector ] }
-        { [ dup vector>scalar-expr? ] [ [ dst>> ] [ src>> vn>vreg ] bi* <copy> ] }
+    dup src>> vreg>insn {
+        { [ dup ##load-reference? ] [ fold-scalar>vector ] }
+        { [ dup ##vector>scalar? ] [ [ dst>> ] [ src>> ] bi* <copy> ] }
         [ 2drop f ]
     } cond ;
 
 M: ##xor-vector rewrite
-    dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
+    dup diagonal?
     [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
 
-: vector-not? ( expr -- ? )
+: vector-not? ( insn -- ? )
     {
-        [ not-vector-expr? ]
+        [ ##not-vector? ]
         [ {
-            [ xor-vector-expr? ]
-            [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
+            [ ##xor-vector? ]
+            [ [ src1>> ] [ src2>> ] bi [ vreg>insn ##fill-vector? ] either? ]
         } 1&& ]
     } 1|| ;
 
-GENERIC: vector-not-src ( expr -- vreg )
-M: not-vector-expr vector-not-src src>> vn>vreg ;
-M: xor-vector-expr vector-not-src
-    dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
+GENERIC: vector-not-src ( insn -- vreg )
+
+M: ##not-vector vector-not-src
+    src>> ;
+
+M: ##xor-vector vector-not-src
+    dup src1>> vreg>insn ##fill-vector? [ src2>> ] [ src1>> ] if ;
 
 M: ##and-vector rewrite 
     {
-        { [ dup src1>> vreg>expr vector-not? ] [
+        { [ dup src1>> vreg>insn vector-not? ] [
             {
                 [ dst>> ]
-                [ src1>> vreg>expr vector-not-src ]
+                [ src1>> vreg>insn vector-not-src ]
                 [ src2>> ]
                 [ rep>> ]
             } cleave \ ##andn-vector new-insn
         ] }
-        { [ dup src2>> vreg>expr vector-not? ] [
+        { [ dup src2>> vreg>insn vector-not? ] [
             {
                 [ dst>> ]
-                [ src2>> vreg>expr vector-not-src ]
+                [ src2>> vreg>insn vector-not-src ]
                 [ src1>> ]
                 [ rep>> ]
             } cleave \ ##andn-vector new-insn
@@ -103,10 +106,10 @@ M: ##and-vector rewrite
     } cond ;
 
 M: ##andn-vector rewrite
-    dup src1>> vreg>expr vector-not? [
+    dup src1>> vreg>insn vector-not? [
         {
             [ dst>> ]
-            [ src1>> vreg>expr vector-not-src ]
+            [ src1>> vreg>insn vector-not-src ]
             [ src2>> ]
             [ rep>> ]
         } cleave \ ##and-vector new-insn
diff --git a/basis/compiler/cfg/value-numbering/slots/slots.factor b/basis/compiler/cfg/value-numbering/slots/slots.factor
index 21dac9dcfb..8733e5f6e9 100644
--- a/basis/compiler/cfg/value-numbering/slots/slots.factor
+++ b/basis/compiler/cfg/value-numbering/slots/slots.factor
@@ -10,12 +10,12 @@ IN: compiler.cfg.value-numbering.slots
 
 : simplify-slot-addressing? ( insn -- ? )
     complex-addressing?
-    [ slot>> vreg>expr add-imm-expr? ] [ drop f ] if ;
+    [ slot>> vreg>insn ##add-imm? ] [ drop f ] if ;
 
 : simplify-slot-addressing ( insn -- insn/f )
     dup simplify-slot-addressing? [
-        dup slot>> vreg>expr
-        [ src1>> vn>vreg >>slot ]
+        dup slot>> vreg>insn
+        [ src1>> >>slot ]
         [ src2>> over scale>> '[ _ _ shift - ] change-tag ]
         bi
     ] [ drop f ] if ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index dced1debb4..a6a20b2229 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs kernel accessors
-sorting sets sequences arrays
+USING: namespaces arrays assocs kernel accessors
+sorting sets sequences locals
 cpu.architecture
 sequences.deep
 compiler.cfg
@@ -18,22 +18,26 @@ compiler.cfg.value-numbering.rewrite
 compiler.cfg.value-numbering.slots ;
 IN: compiler.cfg.value-numbering
 
-: >copy ( insn vn dst -- insn/##copy )
-    swap vn>vreg 2dup eq? [ 2drop ] [ <copy> nip ] if ;
-
 GENERIC: process-instruction ( insn -- insn' )
 
+: redundant-instruction ( insn vn -- insn' )
+    [ dst>> ] dip [ swap set-vn ] [ vn>vreg <copy> ] 2bi ;
+
+:: useful-instruction ( insn expr -- insn' )
+    next-vn :> vn
+    vn insn dst>> vregs>vns get set-at
+    vn expr exprs>vns get set-at
+    insn vn vns>insns get set-at
+    insn ;
+
+: check-redundancy ( insn -- insn' )
+    dup >expr dup exprs>vns get at
+    [ redundant-instruction ] [ useful-instruction ] ?if ;
+
 M: insn process-instruction
     dup rewrite
     [ process-instruction ]
-    [
-        dup defs-vreg [
-            dup [ >expr expr>vn ] [ dst>> ] bi
-            [ set-vn drop ]
-            [ >copy ]
-            3bi
-        ] when
-    ] ?if ;
+    [ dup defs-vreg [ check-redundancy ] when ] ?if ;
 
 M: ##copy process-instruction
     dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;

From ef8094e3b31230f08e6b9a0241b7af1f3808f284 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 24 Apr 2010 06:15:41 -0400
Subject: [PATCH 121/158] compiler.cfg.value-numbering: identify VNs with their
 representative vregs, eliminating the vn>vreg hash

---
 .../expressions/expressions.factor            |  8 +------
 .../cfg/value-numbering/graph/graph.factor    | 22 ++++++-------------
 .../value-numbering/value-numbering.factor    |  6 ++---
 3 files changed, 11 insertions(+), 25 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index ffd2efbd21..087aedf50d 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -77,13 +77,7 @@ M: reference-expr equal?
 M: reference-expr hashcode*
     nip value>> dup float? [ double>bits ] [ identity-hashcode ] if ;
 
-! Expressions whose values are inputs to the basic block.
-TUPLE: input-expr n ;
-
-: next-input-expr ( -- expr )
-    input-expr-counter counter input-expr boa ;
-
-M: insn >expr drop next-input-expr ;
+M: insn >expr drop input-expr-counter counter neg ;
 
 M: ##copy >expr "Fail" throw ;
 
diff --git a/basis/compiler/cfg/value-numbering/graph/graph.factor b/basis/compiler/cfg/value-numbering/graph/graph.factor
index bef4956f5e..1ea1a52d02 100644
--- a/basis/compiler/cfg/value-numbering/graph/graph.factor
+++ b/basis/compiler/cfg/value-numbering/graph/graph.factor
@@ -1,14 +1,13 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math namespaces assocs biassocs ;
+USING: accessors kernel math namespaces assocs ;
 IN: compiler.cfg.value-numbering.graph
 
-! Value numbers are negative, to catch confusion with vregs
-SYMBOL: vn-counter
-
 SYMBOL: input-expr-counter
 
-: next-vn ( -- vn ) vn-counter [ 1 - dup ] change ;
+! assoc mapping vregs to value numbers
+! this is the identity on canonical representatives
+SYMBOL: vregs>vns
 
 ! assoc mapping expressions to value numbers
 SYMBOL: exprs>vns
@@ -18,21 +17,14 @@ SYMBOL: vns>insns
 
 : vn>insn ( vn -- insn ) vns>insns get at ;
 
-! biassocs mapping vregs to value numbers, and value numbers to
-! their primary vregs
-SYMBOL: vregs>vns
-
-: vreg>vn ( vreg -- vn ) vregs>vns get [ drop next-vn ] cache ;
-
-: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
+: vreg>vn ( vreg -- vn ) vregs>vns get [ ] cache ;
 
 : set-vn ( vn vreg -- ) vregs>vns get set-at ;
 
-: vreg>insn ( vreg -- insn ) vreg>vn vn>insn ; inline
+: vreg>insn ( vreg -- insn ) vreg>vn vn>insn ;
 
 : init-value-graph ( -- )
-    0 vn-counter set
     0 input-expr-counter set
-    <bihash> vregs>vns set
+    H{ } clone vregs>vns set
     H{ } clone exprs>vns set
     H{ } clone vns>insns set ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index a6a20b2229..01b095fbd7 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -21,11 +21,11 @@ IN: compiler.cfg.value-numbering
 GENERIC: process-instruction ( insn -- insn' )
 
 : redundant-instruction ( insn vn -- insn' )
-    [ dst>> ] dip [ swap set-vn ] [ vn>vreg <copy> ] 2bi ;
+    [ dst>> ] dip [ swap set-vn ] [ <copy> ] 2bi ;
 
 :: useful-instruction ( insn expr -- insn' )
-    next-vn :> vn
-    vn insn dst>> vregs>vns get set-at
+    insn dst>> :> vn
+    vn vn vregs>vns get set-at
     vn expr exprs>vns get set-at
     insn vn vns>insns get set-at
     insn ;

From a141df595bd0e91e821ee0e48fc5d781cecc85b3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 24 Apr 2010 06:32:46 -0400
Subject: [PATCH 122/158] compiler.cfg.value-numbering: more cleanups

---
 .../cfg/value-numbering/alien/alien.factor    |  3 +-
 .../comparisons/comparisons.factor            |  3 +-
 .../expressions/expressions.factor            | 41 ++-----------------
 .../value-numbering/folding/folding.factor    |  4 +-
 .../cfg/value-numbering/math/math.factor      |  1 -
 .../value-numbering/rewrite/rewrite.factor    | 39 +++++++++++++++++-
 .../cfg/value-numbering/simd/simd.factor      |  1 -
 .../cfg/value-numbering/slots/slots.factor    |  3 +-
 .../value-numbering/value-numbering.factor    |  4 +-
 9 files changed, 48 insertions(+), 51 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/alien/alien.factor b/basis/compiler/cfg/value-numbering/alien/alien.factor
index 8b508550b4..190d911ad5 100644
--- a/basis/compiler/cfg/value-numbering/alien/alien.factor
+++ b/basis/compiler/cfg/value-numbering/alien/alien.factor
@@ -9,8 +9,7 @@ compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.value-numbering.math
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.rewrite
-compiler.cfg.value-numbering.expressions ;
+compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.alien
 
 M: ##box-displaced-alien rewrite
diff --git a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
index d9af124f30..63ac3575ef 100644
--- a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
+++ b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
@@ -6,8 +6,7 @@ compiler.cfg.comparisons compiler.cfg.instructions
 compiler.cfg.registers
 compiler.cfg.value-numbering.math
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.rewrite
-compiler.cfg.value-numbering.expressions ;
+compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.comparisons
 
 ! Optimizations performed here:
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index 087aedf50d..46e5a09907 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -1,10 +1,8 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes classes.algebra classes.parser
-classes.tuple combinators combinators.short-circuit fry
-generic.parser kernel layouts math namespaces quotations
-sequences slots splitting words make
-cpu.architecture
+USING: accessors arrays classes classes.algebra combinators fry
+generic.parser kernel math namespaces quotations sequences slots
+words make
 compiler.cfg.instructions
 compiler.cfg.instructions.syntax
 compiler.cfg.value-numbering.graph ;
@@ -84,36 +82,3 @@ M: ##copy >expr "Fail" throw ;
 M: ##load-integer >expr val>> <integer-expr> ;
 
 M: ##load-reference >expr obj>> <reference-expr> ;
-
-GENERIC: insn>integer ( insn -- n )
-
-M: ##load-integer insn>integer val>> ;
-
-: vreg>integer ( vreg -- n ) vreg>insn insn>integer ; inline
-
-: vreg-immediate-arithmetic? ( vreg -- ? )
-    vreg>insn {
-        [ ##load-integer? ]
-        [ val>> immediate-arithmetic? ]
-    } 1&& ;
-
-: vreg-immediate-bitwise? ( vreg -- ? )
-    vreg>insn {
-        [ ##load-integer? ]
-        [ val>> immediate-bitwise? ]
-    } 1&& ;
-
-GENERIC: insn>comparand ( expr -- n )
-
-M: ##load-integer insn>comparand val>> tag-fixnum ;
-
-M: ##load-reference insn>comparand obj>> ;
-
-: vreg>comparand ( vreg -- n ) vreg>insn insn>comparand ; inline
-
-: vreg-immediate-comparand? ( vreg -- ? )
-    vreg>insn {
-        { [ dup ##load-integer? ] [ val>> tag-fixnum immediate-comparand? ] }
-        { [ dup ##load-reference? ] [ obj>> immediate-comparand? ] }
-        [ drop f ]
-    } cond ;
diff --git a/basis/compiler/cfg/value-numbering/folding/folding.factor b/basis/compiler/cfg/value-numbering/folding/folding.factor
index 6e70e3f80f..4d79ed5655 100644
--- a/basis/compiler/cfg/value-numbering/folding/folding.factor
+++ b/basis/compiler/cfg/value-numbering/folding/folding.factor
@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel layouts math math.bitwise
 compiler.cfg.instructions
-compiler.cfg.value-numbering.expressions
-compiler.cfg.value-numbering.graph ;
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.folding
 
 : binary-constant-fold? ( insn -- ? )
diff --git a/basis/compiler/cfg/value-numbering/math/math.factor b/basis/compiler/cfg/value-numbering/math/math.factor
index 557fce7d50..c2f63692ac 100644
--- a/basis/compiler/cfg/value-numbering/math/math.factor
+++ b/basis/compiler/cfg/value-numbering/math/math.factor
@@ -5,7 +5,6 @@ cpu.architecture fry kernel layouts locals make math sequences
 compiler.cfg.instructions
 compiler.cfg.registers
 compiler.cfg.utilities
-compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.folding
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.rewrite ;
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index dc34f2dcd8..1e2327d765 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -1,9 +1,46 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.instructions ;
+USING: accessors combinators combinators.short-circuit kernel layouts
+cpu.architecture
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph ;
 IN: compiler.cfg.value-numbering.rewrite
 
 ! Outputs f to mean no change
 GENERIC: rewrite ( insn -- insn/f )
 
 M: insn rewrite drop f ;
+
+! Utilities
+GENERIC: insn>integer ( insn -- n )
+
+M: ##load-integer insn>integer val>> ;
+
+: vreg>integer ( vreg -- n ) vreg>insn insn>integer ; inline
+
+: vreg-immediate-arithmetic? ( vreg -- ? )
+    vreg>insn {
+        [ ##load-integer? ]
+        [ val>> immediate-arithmetic? ]
+    } 1&& ;
+
+: vreg-immediate-bitwise? ( vreg -- ? )
+    vreg>insn {
+        [ ##load-integer? ]
+        [ val>> immediate-bitwise? ]
+    } 1&& ;
+
+GENERIC: insn>comparand ( expr -- n )
+
+M: ##load-integer insn>comparand val>> tag-fixnum ;
+
+M: ##load-reference insn>comparand obj>> ;
+
+: vreg>comparand ( vreg -- n ) vreg>insn insn>comparand ; inline
+
+: vreg-immediate-comparand? ( vreg -- ? )
+    vreg>insn {
+        { [ dup ##load-integer? ] [ val>> tag-fixnum immediate-comparand? ] }
+        { [ dup ##load-reference? ] [ obj>> immediate-comparand? ] }
+        [ drop f ]
+    } cond ;
diff --git a/basis/compiler/cfg/value-numbering/simd/simd.factor b/basis/compiler/cfg/value-numbering/simd/simd.factor
index 4aabfd3d9a..1983c07190 100644
--- a/basis/compiler/cfg/value-numbering/simd/simd.factor
+++ b/basis/compiler/cfg/value-numbering/simd/simd.factor
@@ -12,7 +12,6 @@ compiler.cfg.comparisons
 compiler.cfg.instructions
 compiler.cfg.value-numbering.math
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.simd
 
diff --git a/basis/compiler/cfg/value-numbering/slots/slots.factor b/basis/compiler/cfg/value-numbering/slots/slots.factor
index 8733e5f6e9..7c2b562a84 100644
--- a/basis/compiler/cfg/value-numbering/slots/slots.factor
+++ b/basis/compiler/cfg/value-numbering/slots/slots.factor
@@ -4,8 +4,7 @@ USING: accessors combinators.short-circuit cpu.architecture fry
 kernel math
 compiler.cfg.instructions
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.rewrite
-compiler.cfg.value-numbering.expressions ;
+compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.slots
 
 : simplify-slot-addressing? ( insn -- ? )
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index 01b095fbd7..ad3ccb1693 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -11,11 +11,11 @@ compiler.cfg.utilities
 compiler.cfg.instructions
 compiler.cfg.value-numbering.alien
 compiler.cfg.value-numbering.comparisons
-compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.math
 compiler.cfg.value-numbering.rewrite
-compiler.cfg.value-numbering.slots ;
+compiler.cfg.value-numbering.slots
+compiler.cfg.value-numbering.expressions ;
 IN: compiler.cfg.value-numbering
 
 GENERIC: process-instruction ( insn -- insn' )

From 456743a6ce31fc107cd8ba9c3035995732fd6600 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 24 Apr 2010 20:05:52 -0400
Subject: [PATCH 123/158] compiler.cfg.representations: add more peephole
 optimizations to reduce fixnum tagging and untagging overhead

---
 .../cfg/loop-detection/loop-detection.factor  |   2 +
 .../representations/peephole/peephole.factor  | 161 +++++++--
 .../representations-tests.factor              | 336 +++++++++++++++---
 .../representations/representations.factor    |   1 +
 .../representations/rewrite/rewrite.factor    |  17 +-
 .../selection/selection.factor                |  99 +++---
 6 files changed, 493 insertions(+), 123 deletions(-)

diff --git a/basis/compiler/cfg/loop-detection/loop-detection.factor b/basis/compiler/cfg/loop-detection/loop-detection.factor
index 2e2dab00f1..d8fc92aaa6 100644
--- a/basis/compiler/cfg/loop-detection/loop-detection.factor
+++ b/basis/compiler/cfg/loop-detection/loop-detection.factor
@@ -79,6 +79,8 @@ PRIVATE>
 
 : loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ;
 
+: current-loop-nesting ( -- n ) basic-block get loop-nesting-at ;
+
 : needs-loops ( cfg -- cfg' )
     needs-predecessors
     dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
diff --git a/basis/compiler/cfg/representations/peephole/peephole.factor b/basis/compiler/cfg/representations/peephole/peephole.factor
index 94f9dd8aeb..117ce6da7e 100644
--- a/basis/compiler/cfg/representations/peephole/peephole.factor
+++ b/basis/compiler/cfg/representations/peephole/peephole.factor
@@ -1,20 +1,43 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.short-circuit kernel
-layouts math namespaces cpu.architecture
+layouts locals make math namespaces sequences cpu.architecture
 compiler.cfg.registers
 compiler.cfg.instructions
-compiler.cfg.representations.rewrite ;
+compiler.cfg.representations.rewrite
+compiler.cfg.representations.selection ;
 IN: compiler.cfg.representations.peephole
 
 ! Representation selection performs some peephole optimizations
 ! when inserting conversions to optimize for a few common cases
 
-M: ##load-integer conversions-for-insn
+GENERIC: optimize-insn ( insn -- )
+
+SYMBOL: insn-index
+
+: here ( -- )
+    building get length 1 - insn-index set ;
+
+: finish ( insn -- ) , here ;
+
+: unchanged ( insn -- )
+    [ no-use-conversion ] [ finish ] [ no-def-conversion ] tri ;
+
+: last-insn ( -- insn ) insn-index get building get nth ;
+
+M: vreg-insn conversions-for-insn
+    init-renaming-set
+    optimize-insn
+    last-insn perform-renaming ;
+
+M: vreg-insn optimize-insn
+    [ emit-use-conversion ] [ finish ] [ emit-def-conversion ] tri ;
+
+M: ##load-integer optimize-insn
     {
         {
             [ dup dst>> rep-of tagged-rep? ]
-            [ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged ]
+            [ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged here ]
         }
         [ call-next-method ]
     } cond ;
@@ -48,19 +71,19 @@ M: ##load-integer conversions-for-insn
 : (convert-to-zero/fill-vector) ( insn -- dst rep )
     dst>> dup rep-of ; inline
 
-M: ##load-reference conversions-for-insn
+M: ##load-reference optimize-insn
     {
         {
             [ dup convert-to-load-double? ]
-            [ (convert-to-load-double) ##load-double ]
+            [ (convert-to-load-double) ##load-double here ]
         }
         {
             [ dup convert-to-zero-vector? ]
-            [ (convert-to-zero/fill-vector) ##zero-vector ]
+            [ (convert-to-zero/fill-vector) ##zero-vector here ]
         }
         {
             [ dup convert-to-fill-vector? ]
-            [ (convert-to-zero/fill-vector) ##fill-vector ]
+            [ (convert-to-zero/fill-vector) ##fill-vector here ]
         }
         [ call-next-method ]
     } cond ;
@@ -71,21 +94,42 @@ M: ##load-reference conversions-for-insn
 ! Into either
 ! ##shl-imm by X - tag-bits, or
 ! ##sar-imm by tag-bits - X.
-: combine-shl-imm? ( insn -- ? )
-    src1>> rep-of tagged-rep? ;
+: combine-shl-imm-input? ( insn -- ? )
+     ;
 
-: combine-shl-imm ( insn -- )
+: combine-shl-imm-input ( insn -- )
     [ dst>> ] [ src1>> ] [ src2>> ] tri tag-bits get {
-        { [ 2dup < ] [ swap - ##sar-imm ] }
-        { [ 2dup > ] [ - ##shl-imm ] }
-        [ 2drop int-rep ##copy ]
+        { [ 2dup < ] [ swap - ##sar-imm here ] }
+        { [ 2dup > ] [ - ##shl-imm here ] }
+        [ 2drop int-rep ##copy here ]
     } cond ;
 
-M: ##shl-imm conversions-for-insn
+: inert-tag/untag-imm? ( insn -- ? )
+    [ dst>> ] [ src1>> ] bi [ rep-of tagged-rep? ] both? ;
+
+M: ##shl-imm optimize-insn
     {
         {
-            [ dup combine-shl-imm? ]
-            [ [ combine-shl-imm ] [ emit-def-conversion ] bi ]
+            [ dup inert-tag/untag-imm? ]
+            [ unchanged ]
+        }
+        {
+            [ dup dst>> rep-of tagged-rep? ]
+            [
+                [ emit-use-conversion ]
+                [ [ tag-bits get + ] change-src2 finish ]
+                [ no-def-conversion ]
+                tri
+            ]
+        }
+        {
+            [ dup src1>> rep-of tagged-rep? ]
+            [
+                [ no-use-conversion ]
+                [ combine-shl-imm-input ]
+                [ emit-def-conversion ]
+                tri
+            ]
         }
         [ call-next-method ]
     } cond ;
@@ -103,13 +147,90 @@ M: ##shl-imm conversions-for-insn
     } 1&& ;
 
 : combine-sar-imm ( insn -- )
-    [ dst>> ] [ src1>> ] [ src2>> tag-bits get + ] tri ##sar-imm ;
+    [ dst>> ] [ src1>> ] [ src2>> tag-bits get + ] tri ##sar-imm here ;
 
-M: ##sar-imm conversions-for-insn
+M: ##sar-imm optimize-insn
     {
         {
             [ dup combine-sar-imm? ]
-            [ [ combine-sar-imm ] [ emit-def-conversion ] bi ]
+            [
+                [ no-use-conversion ]
+                [ combine-sar-imm ]
+                [ emit-def-conversion ]
+                tri
+            ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+! Peephole optimization: for X = add, sub, and, or, xor, min, max
+! we have
+! tag(untag(a) X untag(b)) = a X b
+!
+! so if all inputs and outputs of ##X or ##X-imm are tagged,
+! don't have to insert any conversions
+: inert-tag/untag? ( insn -- ? )
+    {
+        [ dst>> rep-of tagged-rep? ]
+        [ src1>> rep-of tagged-rep? ]
+        [ src2>> rep-of tagged-rep? ]
+    } 1&& ;
+
+M: inert-tag-untag-insn optimize-insn
+    {
+        { [ dup inert-tag/untag? ] [ unchanged ] }
+        [ call-next-method ]
+    } cond ;
+
+! -imm variant of above
+M: inert-tag-untag-imm-insn optimize-insn
+    {
+        { [ dup inert-tag/untag-imm? ] [ [ tag-fixnum ] change-src2 unchanged ] }
+        [ call-next-method ]
+    } cond ;
+
+M: ##mul-imm optimize-insn
+    {
+        { [ dup inert-tag/untag-imm? ] [ unchanged ] }
+        { [ dup dst>> rep-of tagged-rep? ] [ [ tag-fixnum ] change-src2 unchanged ] }
+        [ call-next-method ]
+    } cond ;
+
+: inert-tag/untag-unary? ( insn -- ? )
+    [ dst>> ] [ src>> ] bi [ rep-of tagged-rep? ] both? ;
+
+: combine-neg-tag ( insn -- )
+    [ dst>> ] [ src>> ] bi tag-bits get 2^ neg ##mul-imm here ;
+
+M: ##neg optimize-insn
+    {
+        { [ dup inert-tag/untag-unary? ] [ unchanged ] }
+        {
+            [ dup dst>> rep-of tagged-rep? ]
+            [
+                [ emit-use-conversion ]
+                [ combine-neg-tag ]
+                [ no-def-conversion ] tri
+            ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+:: emit-tagged-not ( insn -- )
+    tagged-rep next-vreg-rep :> temp
+    temp insn src>> ##not
+    insn dst>> temp tag-mask get ##xor-imm here ;
+
+M: ##not optimize-insn
+    {
+        {
+            [ dup inert-tag/untag-unary? ]
+            [
+                [ no-use-conversion ]
+                [ emit-tagged-not ]
+                [ no-def-conversion ]
+                tri
+            ]
         }
         [ call-next-method ]
     } cond ;
diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor
index 7d644206a9..b8860d1445 100644
--- a/basis/compiler/cfg/representations/representations-tests.factor
+++ b/basis/compiler/cfg/representations/representations-tests.factor
@@ -79,15 +79,52 @@ V{
 
 [ 1 ] [ 1 get instructions>> [ ##allot? ] count ] unit-test
 
-! Converting a ##load-integer into a ##load-tagged
+! Don't dereference the result of a peek
 V{
     T{ ##prologue }
     T{ ##branch }
 } 0 test-bb
 
 V{
-    T{ ##load-integer f 1 100 }
-    T{ ##replace f 1 D 0 }
+    T{ ##peek f 1 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##add-float f 2 1 1 }
+    T{ ##replace f 2 D 0 }
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+V{
+    T{ ##add-float f 3 1 1 }
+    T{ ##replace f 3 D 0 }
+    T{ ##epilogue }
+    T{ ##return }
+} 3 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+
+[ ] [ test-representations ] unit-test
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##branch }
+    }
+] [ 1 get instructions>> ] unit-test
+
+! But its ok to untag-fixnum the result of a peek if there are
+! no usages of it as a tagged-rep
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 1 D 0 }
     T{ ##branch }
 } 1 test-bb
 
@@ -96,14 +133,33 @@ V{
     T{ ##return }
 } 2 test-bb
 
+V{
+    T{ ##add f 2 1 1 }
+    T{ ##replace f 2 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
 0 1 edge
-1 2 edge
+1 { 2 3 } edges
+3 { 3 4 } edges
+2 4 edge
+
+3 \ vreg-counter set-global
 
 [ ] [ test-representations ] unit-test
 
-[ T{ ##load-tagged f 1 $[ 100 tag-fixnum ] } ]
-[ 1 get instructions>> first ]
-unit-test
+[
+    V{
+        T{ ##peek f 4 D 0 }
+        T{ ##sar-imm f 1 4 $[ tag-bits get ] }
+        T{ ##branch }
+    }
+] [ 1 get instructions>> ] unit-test
 
 ! scalar-rep => int-rep conversion
 V{
@@ -115,8 +171,7 @@ V{
     T{ ##peek f 1 D 0 }
     T{ ##peek f 2 D 0 }
     T{ ##vector>scalar f 3 2 int-4-rep }
-    T{ ##shl f 4 1 3 }
-    T{ ##replace f 4 D 0 }
+    T{ ##replace f 3 D 0 }
     T{ ##branch }
 } 1 test-bb
 
@@ -208,75 +263,252 @@ cpu x86.32? [
     [ t ] [ 4 get instructions>> first ##phi? ] unit-test
 ] when
 
-! Peephole optimization if input to ##shl-imm is tagged
-
-3 \ vreg-counter set-global
+: test-peephole ( insns -- insns )
+    0 test-bb
+    test-representations
+    0 get instructions>> ;
 
+! Converting a ##load-integer into a ##load-tagged
 V{
-    T{ ##peek f 1 D 0 }
-    T{ ##shl-imm f 2 1 3 }
-    T{ ##replace f 2 D 0 }
+    T{ ##prologue }
+    T{ ##branch }
 } 0 test-bb
 
-[ ] [ test-representations ] unit-test
+[
+    V{
+        T{ ##load-tagged f 1 $[ 100 tag-fixnum ] }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    V{
+        T{ ##load-integer f 1 100 }
+        T{ ##replace f 1 D 0 }
+    } test-peephole
+] unit-test
+
+! Peephole optimization if input to ##shl-imm is tagged
+3 \ vreg-counter set-global
 
 [
     V{
         T{ ##peek f 1 D 0 }
         T{ ##sar-imm f 2 1 1 }
-        T{ ##shl-imm f 4 2 $[ tag-bits get ] }
-        T{ ##replace f 4 D 0 }
+        T{ ##add f 4 2 2 }
+        T{ ##shl-imm f 3 4 $[ tag-bits get ] }
+        T{ ##replace f 3 D 0 }
     }
-] [ 0 get instructions>> ] unit-test
+] [
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##shl-imm f 2 1 3 }
+        T{ ##add f 3 2 2 }
+        T{ ##replace f 3 D 0 }
+    } test-peephole
+] unit-test
 
-V{
-    T{ ##peek f 1 D 0 }
-    T{ ##shl-imm f 2 1 10 }
-    T{ ##replace f 2 D 0 }
-} 0 test-bb
-
-[ ] [ test-representations ] unit-test
+3 \ vreg-counter set-global
 
 [
     V{
         T{ ##peek f 1 D 0 }
         T{ ##shl-imm f 2 1 $[ 10 tag-bits get - ] }
-        T{ ##shl-imm f 5 2 $[ tag-bits get ] }
-        T{ ##replace f 5 D 0 }
+        T{ ##add f 4 2 2 }
+        T{ ##shl-imm f 3 4 $[ tag-bits get ] }
+        T{ ##replace f 3 D 0 }
     }
-] [ 0 get instructions>> ] unit-test
-
-V{
-    T{ ##peek f 1 D 0 }
-    T{ ##shl-imm f 2 1 $[ tag-bits get ] }
-    T{ ##replace f 2 D 0 }
-} 0 test-bb
-
-[ ] [ test-representations ] unit-test
+] [
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##shl-imm f 2 1 10 }
+        T{ ##add f 3 2 2 }
+        T{ ##replace f 3 D 0 }
+    } test-peephole
+] unit-test
 
 [
     V{
         T{ ##peek f 1 D 0 }
         T{ ##copy f 2 1 int-rep }
-        T{ ##shl-imm f 6 2 $[ tag-bits get ] }
-        T{ ##replace f 6 D 0 }
+        T{ ##add f 5 2 2 }
+        T{ ##shl-imm f 3 5 $[ tag-bits get ] }
+        T{ ##replace f 3 D 0 }
     }
-] [ 0 get instructions>> ] unit-test
+] [
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##shl-imm f 2 1 $[ tag-bits get ] }
+        T{ ##add f 3 2 2 }
+        T{ ##replace f 3 D 0 }
+    } test-peephole
+] unit-test
+
+! Peephole optimization if output of ##shl-imm needs to be tagged
+[
+    V{
+        T{ ##load-integer f 1 100 }
+        T{ ##shl-imm f 2 1 $[ 3 tag-bits get + ] }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    V{
+        T{ ##load-integer f 1 100 }
+        T{ ##shl-imm f 2 1 3 }
+        T{ ##replace f 2 D 0 }
+    } test-peephole
+] unit-test
+
+! Peephole optimization if both input and output of ##shl-imm
+! needs to be tagged
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##shl-imm f 1 0 3 }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##shl-imm f 1 0 3 }
+        T{ ##replace f 1 D 0 }
+    } test-peephole
+] unit-test
+
+6 \ vreg-counter set-global
 
 ! Peephole optimization if input to ##sar-imm is tagged
-V{
-    T{ ##peek f 1 D 0 }
-    T{ ##sar-imm f 2 1 3 }
-    T{ ##replace f 2 D 0 }
-} 0 test-bb
-
-[ ] [ test-representations ] unit-test
-
 [
     V{
         T{ ##peek f 1 D 0 }
-        T{ ##sar-imm f 2 1 $[ 3 tag-bits get + ] }
-        T{ ##shl-imm f 7 2 $[ tag-bits get ] }
-        T{ ##replace f 7 D 0 }
+        T{ ##sar-imm f 7 1 $[ 3 tag-bits get + ] }
+        T{ ##shl-imm f 2 7 $[ tag-bits get ] }
+        T{ ##replace f 2 D 0 }
     }
-] [ 0 get instructions>> ] unit-test
\ No newline at end of file
+] [
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##sar-imm f 2 1 3 }
+        T{ ##replace f 2 D 0 }
+    } test-peephole
+] unit-test
+
+! Tag/untag elimination
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##add-imm f 2 1 $[ 100 tag-fixnum ] }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##add-imm f 2 1 100 }
+        T{ ##replace f 2 D 0 }
+    } test-peephole
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##add f 2 0 1 }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##add f 2 0 1 }
+        T{ ##replace f 2 D 0 }
+    } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##mul-imm
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##mul-imm f 1 0 100 }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##mul-imm f 1 0 100 }
+        T{ ##replace f 1 D 0 }
+    } test-peephole
+] unit-test
+
+4 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##sar-imm f 5 1 $[ tag-bits get ] }
+        T{ ##add-imm f 2 5 30 }
+        T{ ##mul-imm f 3 2 $[ 100 tag-fixnum ] }
+        T{ ##replace f 3 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##add-imm f 2 1 30 }
+        T{ ##mul-imm f 3 2 100 }
+        T{ ##replace f 3 D 0 }
+    } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##neg
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##neg f 1 0 }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##neg f 1 0 }
+        T{ ##replace f 1 D 0 }
+    } test-peephole
+] unit-test
+
+4 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##peek f 5 D 0 }
+        T{ ##sar-imm f 0 5 $[ tag-bits get ] }
+        T{ ##peek f 6 D 1 }
+        T{ ##sar-imm f 1 6 $[ tag-bits get ] }
+        T{ ##mul f 2 0 1 }
+        T{ ##mul-imm f 3 2 -16 }
+        T{ ##replace f 3 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##mul f 2 0 1 }
+        T{ ##neg f 3 2 }
+        T{ ##replace f 3 D 0 }
+    } test-peephole
+] unit-test
+
+! Tag/untag elimination for ##not
+2 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##not f 3 0 }
+        T{ ##xor-imm f 1 3 $[ tag-mask get ] }
+        T{ ##replace f 1 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##not f 1 0 }
+        T{ ##replace f 1 D 0 }
+    } test-peephole
+] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor
index 22184ca284..ea32da2527 100644
--- a/basis/compiler/cfg/representations/representations.factor
+++ b/basis/compiler/cfg/representations/representations.factor
@@ -19,6 +19,7 @@ IN: compiler.cfg.representations
 
     {
         [ compute-possibilities ]
+        [ compute-restrictions ]
         [ compute-representations ]
         [ compute-phi-representations ]
         [ insert-conversions ]
diff --git a/basis/compiler/cfg/representations/rewrite/rewrite.factor b/basis/compiler/cfg/representations/rewrite/rewrite.factor
index 5b15e95c15..678417c8f7 100644
--- a/basis/compiler/cfg/representations/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/representations/rewrite/rewrite.factor
@@ -60,9 +60,15 @@ SYMBOLS: renaming-set needs-renaming? ;
 : emit-use-conversion ( insn -- )
     [ [ (emit-use-conversion) ] (compute-renaming-set) ] each-use-rep ;
 
+: no-use-conversion ( insn -- )
+    [ drop no-renaming ] each-use-rep ;
+
 : emit-def-conversion ( insn -- )
     [ [ (emit-def-conversion) ] (compute-renaming-set) ] each-def-rep ;
 
+: no-def-conversion ( insn -- )
+    [ drop no-renaming ] each-def-rep ;
+
 : converted-value ( vreg -- vreg' )
     renaming-set get pop first2 [ assert= ] dip ;
 
@@ -75,21 +81,10 @@ RENAMING: convert [ converted-value ] [ converted-value ] [ ]
         renaming-set get length 0 assert=
     ] [ drop ] if ;
 
-: with-conversions ( insn -- quot )
-    init-renaming-set [ perform-renaming ] bi ; inline
-
 GENERIC: conversions-for-insn ( insn -- )
 
 M: ##phi conversions-for-insn , ;
 
-M: vreg-insn conversions-for-insn
-    [
-        [ emit-use-conversion ]
-        [ , ]
-        [ emit-def-conversion ]
-        tri
-    ] with-conversions ;
-
 M: insn conversions-for-insn , ;
 
 : conversions-for-block ( bb -- )
diff --git a/basis/compiler/cfg/representations/selection/selection.factor b/basis/compiler/cfg/representations/selection/selection.factor
index 77ffde01ad..bd0b8b1e2e 100644
--- a/basis/compiler/cfg/representations/selection/selection.factor
+++ b/basis/compiler/cfg/representations/selection/selection.factor
@@ -17,23 +17,21 @@ SYMBOL: possibilities
     H{ } clone [ '[ swap _ adjoin-at ] with-vreg-reps ] keep
     [ members ] assoc-map possibilities set ;
 
-! Compute vregs which must remain tagged for their lifetime.
-SYMBOL: always-boxed
-
-:: (compute-always-boxed) ( vreg rep assoc -- )
+! Compute vregs for which dereferencing cannot be hoisted past
+! conditionals, because they might be immediate.
+:: check-restriction ( vreg rep -- )
     rep tagged-rep eq? [
-        tagged-rep vreg assoc set-at
+        vreg possibilities get
+        [ { tagged-rep int-rep } intersect ] change-at
     ] when ;
 
-: compute-always-boxed ( cfg -- assoc )
-    H{ } clone [
-        '[
-            [
-                dup ##load-reference?
-                [ drop ] [ [ _ (compute-always-boxed) ] each-def-rep ] if
-            ] each-non-phi
-        ] each-basic-block
-    ] keep ;
+: compute-restrictions ( cfg -- )
+    [
+        [
+            dup ##load-reference?
+            [ drop ] [ [ check-restriction ] each-def-rep ] if
+        ] each-non-phi
+    ] each-basic-block ;
 
 ! For every vreg, compute the cost of keeping it in every possible
 ! representation.
@@ -42,36 +40,61 @@ SYMBOL: always-boxed
 SYMBOL: costs
 
 : init-costs ( -- )
-    possibilities get [ drop H{ } clone ] assoc-map costs set ;
+    ! Initialize cost as 0 for each possibility.
+    possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
 
-: record-possibility ( rep vreg -- )
-    costs get at [ 0 or ] change-at ;
+: 10^ ( n -- x ) 10 <repetition> product ;
 
-: increase-cost ( rep vreg -- )
+: increase-cost ( rep vreg factor -- )
     ! Increase cost of keeping vreg in rep, making a choice of rep less
-    ! likely.
-    costs get at [ 0 or basic-block get loop-nesting-at 1 + + ] change-at ;
+    ! likely. If the rep is not in the cost alist, it means this
+    ! representation is prohibited.
+    [ costs get at 2dup key? ] dip
+    '[ [ current-loop-nesting 10^ _ * + ] change-at ] [ 2drop ] if ;
 
-: maybe-increase-cost ( possible vreg preferred -- )
-    pick eq? [ record-possibility ] [ increase-cost ] if ;
+:: increase-costs ( vreg preferred factor -- )
+    vreg possible [
+        dup preferred eq? [ drop ] [ vreg factor increase-cost ] if
+    ] each ; inline
 
-: representation-cost ( vreg preferred -- )
-    ! 'preferred' is a representation that the instruction can accept with no cost.
-    ! So, for each representation that's not preferred, increase the cost of keeping
-    ! the vreg in that representation.
-    [ drop possible ]
-    [ '[ _ _ maybe-increase-cost ] ]
-    2bi each ;
+UNION: inert-tag-untag-insn
+##add
+##sub
+##and
+##or
+##xor
+##min
+##max ;
+
+UNION: inert-tag-untag-imm-insn
+##add-imm
+##sub-imm
+##and-imm
+##or-imm
+##xor-imm ;
+
+GENERIC: has-peephole-opts? ( insn -- ? )
+
+M: insn                     has-peephole-opts? drop f ;
+M: ##load-integer           has-peephole-opts? drop t ;
+M: ##load-reference         has-peephole-opts? drop t ;
+M: inert-tag-untag-insn     has-peephole-opts? drop t ;
+M: inert-tag-untag-imm-insn has-peephole-opts? drop t ;
+M: ##mul-imm                has-peephole-opts? drop t ;
+M: ##shl-imm                has-peephole-opts? drop t ;
+M: ##shr-imm                has-peephole-opts? drop t ;
+M: ##sar-imm                has-peephole-opts? drop t ;
+M: ##neg                    has-peephole-opts? drop t ;
+M: ##not                    has-peephole-opts? drop t ;
 
 GENERIC: compute-insn-costs ( insn -- )
 
-! There's no cost to converting a constant's representation
-M: ##load-integer compute-insn-costs drop ;
-M: ##load-reference compute-insn-costs drop ;
+M: insn compute-insn-costs drop ;
 
-M: insn compute-insn-costs [ representation-cost ] each-rep ;
+M: vreg-insn compute-insn-costs
+    dup has-peephole-opts? 2 5 ? '[ _ increase-costs ] each-rep ;
 
-: compute-costs ( cfg -- costs )
+: compute-costs ( cfg -- )
     init-costs
     [
         [ basic-block set ]
@@ -80,8 +103,7 @@ M: insn compute-insn-costs [ representation-cost ] each-rep ;
                 compute-insn-costs
             ] each-non-phi
         ] bi
-    ] each-basic-block
-    costs get ;
+    ] each-basic-block ;
 
 ! For every vreg, compute preferred representation, that minimizes costs.
 : minimize-costs ( costs -- representations )
@@ -89,10 +111,7 @@ M: insn compute-insn-costs [ representation-cost ] each-rep ;
     [ >alist alist-min first ] assoc-map ;
 
 : compute-representations ( cfg -- )
-    [ compute-costs minimize-costs ]
-    [ compute-always-boxed ]
-    bi assoc-union
-    representations set ;
+    compute-costs costs get minimize-costs representations set ;
 
 ! PHI nodes require special treatment
 ! If the output of a phi instruction is only used as the input to another

From 0f5d9974a010a9e3853a6addcf61987f5b0204cb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 25 Apr 2010 05:13:04 -0400
Subject: [PATCH 124/158] compiler.cfg.representations: fix various bugs

---
 .../representations/coalescing/authors.txt    |   1 +
 .../coalescing/coalescing-tests.factor        |  43 +++++
 .../coalescing/coalescing.factor              |  43 +++++
 .../preferred/preferred.factor                |   2 +-
 .../representations-tests.factor              | 165 +++++++++++++++++-
 .../representations/representations.factor    |   8 +-
 .../representations/rewrite/rewrite.factor    |   2 +
 .../selection/selection.factor                | 153 ++++++++--------
 .../value-numbering-tests.factor              |   5 +-
 basis/cpu/architecture/architecture.factor    |  14 ++
 basis/disjoint-sets/disjoint-sets.factor      |   4 +
 11 files changed, 344 insertions(+), 96 deletions(-)
 create mode 100644 basis/compiler/cfg/representations/coalescing/authors.txt
 create mode 100644 basis/compiler/cfg/representations/coalescing/coalescing-tests.factor
 create mode 100644 basis/compiler/cfg/representations/coalescing/coalescing.factor

diff --git a/basis/compiler/cfg/representations/coalescing/authors.txt b/basis/compiler/cfg/representations/coalescing/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/representations/coalescing/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/representations/coalescing/coalescing-tests.factor b/basis/compiler/cfg/representations/coalescing/coalescing-tests.factor
new file mode 100644
index 0000000000..f22fe0d147
--- /dev/null
+++ b/basis/compiler/cfg/representations/coalescing/coalescing-tests.factor
@@ -0,0 +1,43 @@
+USING: arrays sequences kernel namespaces accessors compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.debugger
+compiler.cfg.representations.coalescing
+tools.test ;
+IN: compiler.cfg.representations.coalescing.tests
+
+: test-scc ( -- )
+    cfg new 0 get >>entry compute-components ;
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 2 D 0 }
+    T{ ##load-integer f 0 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-integer f 1 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f 3 }
+} 3 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+
+1 get 0 2array
+2 get 1 2array 2array 3 get instructions>> first (>>inputs)
+
+[ ] [ test-scc ] unit-test
+
+[ t ] [ 0 vreg>scc 1 vreg>scc = ] unit-test
+[ t ] [ 0 vreg>scc 3 vreg>scc = ] unit-test
+[ f ] [ 2 vreg>scc 3 vreg>scc = ] unit-test
diff --git a/basis/compiler/cfg/representations/coalescing/coalescing.factor b/basis/compiler/cfg/representations/coalescing/coalescing.factor
new file mode 100644
index 0000000000..20610649bc
--- /dev/null
+++ b/basis/compiler/cfg/representations/coalescing/coalescing.factor
@@ -0,0 +1,43 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs compiler.cfg.def-use
+compiler.cfg.instructions compiler.cfg.rpo disjoint-sets fry
+kernel namespaces sequences ;
+IN: compiler.cfg.representations.coalescing
+
+! Find all strongly connected components in the graph where the
+! edges are ##phi or ##copy vreg uses
+SYMBOL: components
+
+: init-components ( cfg components -- )
+    '[
+        instructions>> [
+            defs-vreg [ _ add-atom ] when*
+        ] each
+    ] each-basic-block ;
+
+GENERIC# visit-insn 1 ( insn disjoint-set -- )
+
+M: ##copy visit-insn
+    [ [ dst>> ] [ src>> ] bi ] dip equate ;
+
+M: ##phi visit-insn
+    [ [ inputs>> values ] [ dst>> ] bi ] dip equate-all-with ;
+
+M: insn visit-insn 2drop ;
+
+: merge-components ( cfg components -- )
+    '[
+        instructions>> [
+            _ visit-insn
+        ] each
+    ] each-basic-block ;
+
+: compute-components ( cfg -- )
+    <disjoint-set>
+    [ init-components ]
+    [ merge-components ]
+    [ components set drop ] 2tri ;
+
+: vreg>scc ( vreg -- scc )
+    components get representative ;
diff --git a/basis/compiler/cfg/representations/preferred/preferred.factor b/basis/compiler/cfg/representations/preferred/preferred.factor
index e4114c9249..e1a9ec0d93 100644
--- a/basis/compiler/cfg/representations/preferred/preferred.factor
+++ b/basis/compiler/cfg/representations/preferred/preferred.factor
@@ -80,7 +80,7 @@ PRIVATE>
 : each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
     [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline
 
-: with-vreg-reps ( ..a cfg vreg-quot: ( ..a vreg rep -- ..b ) -- ..b )
+: with-vreg-reps ( cfg vreg-quot: ( vreg rep -- ) -- )
     '[
         [ basic-block set ] [
             [
diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor
index b8860d1445..dcd7fc7241 100644
--- a/basis/compiler/cfg/representations/representations-tests.factor
+++ b/basis/compiler/cfg/representations/representations-tests.factor
@@ -3,7 +3,9 @@ compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.representations.preferred cpu.architecture kernel
 namespaces tools.test sequences arrays system literals layouts
 math compiler.constants compiler.cfg.representations.conversion
-compiler.cfg.representations.rewrite make ;
+compiler.cfg.representations.rewrite
+compiler.cfg.comparisons
+make ;
 IN: compiler.cfg.representations
 
 [ { double-rep double-rep } ] [
@@ -116,8 +118,51 @@ V{
     }
 ] [ 1 get instructions>> ] unit-test
 
-! But its ok to untag-fixnum the result of a peek if there are
-! no usages of it as a tagged-rep
+! We cannot untag-fixnum the result of a peek if there are usages
+! of it as a tagged-rep
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 1 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##replace f 1 R 0 }
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+V{
+    T{ ##mul f 2 1 1 }
+    T{ ##replace f 2 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+3 { 3 4 } edges
+2 4 edge
+
+[ ] [ test-representations ] unit-test
+
+[
+    V{
+        T{ ##peek f 1 D 0 }
+        T{ ##branch }
+    }
+] [ 1 get instructions>> ] unit-test
+
+! But its ok to untag-fixnum the result of a peek if all usages use
+! it as int-rep
 V{
     T{ ##prologue }
     T{ ##branch }
@@ -135,7 +180,9 @@ V{
 
 V{
     T{ ##add f 2 1 1 }
+    T{ ##mul f 3 1 1 }
     T{ ##replace f 2 D 0 }
+    T{ ##replace f 3 D 1 }
     T{ ##branch }
 } 3 test-bb
 
@@ -187,6 +234,93 @@ V{
 
 [ t ] [ 1 get instructions>> 4 swap nth ##scalar>integer? ] unit-test
 
+! Test phi node behavior
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##load-integer f 1 1 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-integer f 2 2 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f 3 }
+    T{ ##replace f 3 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+1 get 1 2array
+2 get 2 2array 2array 3 get instructions>> first (>>inputs)
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-representations ] unit-test
+
+[ T{ ##load-tagged f 1 $[ 1 tag-fixnum ] } ]
+[ 1 get instructions>> first ]
+unit-test
+
+[ T{ ##load-tagged f 2 $[ 2 tag-fixnum ] } ]
+[ 2 get instructions>> first ]
+unit-test
+
+! ##load-reference corner case
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 0 D 0 }
+    T{ ##peek f 1 D 1 }
+    T{ ##add f 2 0 1 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-reference f 3 f }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f 4 }
+    T{ ##replace f 4 D 0 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+1 get 2 2array
+2 get 3 2array 2array 3 get instructions>> first (>>inputs)
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-representations ] unit-test
+
+! Don't untag the f!
+[ 2 ] [ 2 get instructions>> length ] unit-test
+
 cpu x86.32? [
 
     ! Make sure load-constant is converted into load-double
@@ -223,7 +357,7 @@ cpu x86.32? [
 
     V{
         T{ ##peek f 1 D 0 }
-        T{ ##compare-imm-branch f 1 2 }
+        T{ ##compare-imm-branch f 1 2 cc= }
     } 1 test-bb
 
     V{
@@ -268,12 +402,25 @@ cpu x86.32? [
     test-representations
     0 get instructions>> ;
 
-! Converting a ##load-integer into a ##load-tagged
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
+! Don't convert the def site into anything but tagged-rep since
+! we might lose precision
+5 \ vreg-counter set-global
 
+[ f ] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##tagged>integer f 2 1 }
+        T{ ##add-float f 3 0 0 }
+        T{ ##store-memory-imm f 3 2 0 float-rep f }
+        T{ ##store-memory-imm f 3 2 4 float-rep f }
+        T{ ##mul-float f 4 0 0 }
+        T{ ##replace f 4 D 0 }
+    } test-peephole
+    [ ##single>double-float? ] any?
+] unit-test
+
+! Converting a ##load-integer into a ##load-tagged
 [
     V{
         T{ ##load-tagged f 1 $[ 100 tag-fixnum ] }
diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor
index ea32da2527..100da7a53f 100644
--- a/basis/compiler/cfg/representations/representations.factor
+++ b/basis/compiler/cfg/representations/representations.factor
@@ -3,10 +3,12 @@
 USING: accessors combinators namespaces
 compiler.cfg
 compiler.cfg.registers
+compiler.cfg.predecessors
 compiler.cfg.loop-detection
 compiler.cfg.representations.rewrite
 compiler.cfg.representations.peephole
-compiler.cfg.representations.selection ;
+compiler.cfg.representations.selection
+compiler.cfg.representations.coalescing ;
 IN: compiler.cfg.representations
 
 ! Virtual register representation selection. This is where
@@ -16,12 +18,12 @@ IN: compiler.cfg.representations
 
 : select-representations ( cfg -- cfg' )
     needs-loops
+    needs-predecessors
 
     {
+        [ compute-components ]
         [ compute-possibilities ]
-        [ compute-restrictions ]
         [ compute-representations ]
-        [ compute-phi-representations ]
         [ insert-conversions ]
         [ ]
     } cleave
diff --git a/basis/compiler/cfg/representations/rewrite/rewrite.factor b/basis/compiler/cfg/representations/rewrite/rewrite.factor
index 678417c8f7..b0da0d190a 100644
--- a/basis/compiler/cfg/representations/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/representations/rewrite/rewrite.factor
@@ -85,6 +85,8 @@ GENERIC: conversions-for-insn ( insn -- )
 
 M: ##phi conversions-for-insn , ;
 
+M: ##copy conversions-for-insn , ;
+
 M: insn conversions-for-insn , ;
 
 : conversions-for-block ( bb -- )
diff --git a/basis/compiler/cfg/representations/selection/selection.factor b/basis/compiler/cfg/representations/selection/selection.factor
index bd0b8b1e2e..23e1f78766 100644
--- a/basis/compiler/cfg/representations/selection/selection.factor
+++ b/basis/compiler/cfg/representations/selection/selection.factor
@@ -1,37 +1,71 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs compiler.cfg compiler.cfg.instructions
-compiler.cfg.loop-detection compiler.cfg.registers
-compiler.cfg.representations.preferred compiler.cfg.rpo
-compiler.cfg.utilities compiler.utilities cpu.architecture
-deques dlists fry kernel locals math namespaces sequences sets ;
+USING: accessors arrays assocs byte-arrays combinators
+disjoint-sets fry kernel locals math namespaces sequences sets
+compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.loop-detection
+compiler.cfg.registers
+compiler.cfg.representations.preferred
+compiler.cfg.representations.coalescing
+compiler.cfg.rpo
+compiler.cfg.utilities
+compiler.utilities
+cpu.architecture ;
 FROM: namespaces => set ;
 IN: compiler.cfg.representations.selection
 
-! For every vreg, compute possible representations.
+SYMBOL: scc-infos
+
+TUPLE: scc-info reps all-uses-untagged? ;
+
+: <scc-info> ( -- reps )
+    V{ } clone t \ scc-info boa ;
+
+: scc-info ( vreg -- info )
+    vreg>scc scc-infos get [ drop <scc-info> ] cache ;
+
+: handle-def ( vreg rep -- )
+    swap scc-info reps>> push ;
+
+: handle-use ( vreg rep -- )
+    int-rep eq? [ scc-info f >>all-uses-untagged? ] unless drop ;
+
+GENERIC: collect-scc-info ( insn -- )
+
+M: ##load-reference collect-scc-info
+    [ dst>> ] [ obj>> ] bi {
+        { [ dup float? ] [ drop { float-rep double-rep } ] }
+        { [ dup byte-array? ] [ drop vector-reps ] }
+        [ drop { } ]
+    } cond handle-def ;
+
+M: vreg-insn collect-scc-info
+    [ [ handle-use ] each-use-rep ]
+    [ [ 1array handle-def ] each-def-rep ]
+    [ [ 1array handle-def ] each-temp-rep ]
+    tri ;
+
+M: insn collect-scc-info drop ;
+
+: collect-scc-infos ( cfg -- )
+    H{ } clone scc-infos set
+    [ [ collect-scc-info ] each-non-phi ] each-basic-block ;
+
 SYMBOL: possibilities
 
-: possible ( vreg -- reps ) possibilities get at ;
+: permitted-reps ( scc-info -- seq )
+    reps>> [ ] [ intersect ] map-reduce
+    tagged-rep over member-eq? [ tagged-rep suffix ] unless ;
+
+: scc-reps ( scc-info -- seq )
+    dup permitted-reps
+    2dup [ all-uses-untagged?>> ] [ { tagged-rep } = ] bi* and
+    [ 2drop { tagged-rep int-rep } ] [ nip ] if ;
 
 : compute-possibilities ( cfg -- )
-    H{ } clone [ '[ swap _ adjoin-at ] with-vreg-reps ] keep
-    [ members ] assoc-map possibilities set ;
-
-! Compute vregs for which dereferencing cannot be hoisted past
-! conditionals, because they might be immediate.
-:: check-restriction ( vreg rep -- )
-    rep tagged-rep eq? [
-        vreg possibilities get
-        [ { tagged-rep int-rep } intersect ] change-at
-    ] when ;
-
-: compute-restrictions ( cfg -- )
-    [
-        [
-            dup ##load-reference?
-            [ drop ] [ [ check-restriction ] each-def-rep ] if
-        ] each-non-phi
-    ] each-basic-block ;
+    collect-scc-infos
+    scc-infos get [ scc-reps ] assoc-map possibilities set ;
 
 ! For every vreg, compute the cost of keeping it in every possible
 ! representation.
@@ -45,16 +79,20 @@ SYMBOL: costs
 
 : 10^ ( n -- x ) 10 <repetition> product ;
 
-: increase-cost ( rep vreg factor -- )
+: increase-cost ( rep scc factor -- )
     ! Increase cost of keeping vreg in rep, making a choice of rep less
     ! likely. If the rep is not in the cost alist, it means this
     ! representation is prohibited.
     [ costs get at 2dup key? ] dip
     '[ [ current-loop-nesting 10^ _ * + ] change-at ] [ 2drop ] if ;
 
+: possible-reps ( scc -- reps )
+    possibilities get at ;
+
 :: increase-costs ( vreg preferred factor -- )
-    vreg possible [
-        dup preferred eq? [ drop ] [ vreg factor increase-cost ] if
+    vreg vreg>scc :> scc
+    scc possible-reps [
+        dup preferred eq? [ drop ] [ scc factor increase-cost ] if
     ] each ; inline
 
 UNION: inert-tag-untag-insn
@@ -98,11 +136,7 @@ M: vreg-insn compute-insn-costs
     init-costs
     [
         [ basic-block set ]
-        [
-            [
-                compute-insn-costs
-            ] each-non-phi
-        ] bi
+        [ [ compute-insn-costs ] each-non-phi ] bi
     ] each-basic-block ;
 
 ! For every vreg, compute preferred representation, that minimizes costs.
@@ -111,52 +145,7 @@ M: vreg-insn compute-insn-costs
     [ >alist alist-min first ] assoc-map ;
 
 : compute-representations ( cfg -- )
-    compute-costs costs get minimize-costs representations set ;
-
-! PHI nodes require special treatment
-! If the output of a phi instruction is only used as the input to another
-! phi instruction, then we want to use the same representation for both
-! if possible.
-SYMBOL: phis
-
-: collect-phis ( cfg -- )
-    H{ } clone phis set
-    [
-        phis get
-        '[ [ inputs>> values ] [ dst>> ] bi _ set-at ] each-phi
-    ] each-basic-block ;
-
-SYMBOL: work-list
-
-: add-to-work-list ( vregs -- )
-    work-list get push-all-front ;
-
-: rep-assigned ( vregs -- vregs' )
-    representations get '[ _ key? ] filter ;
-
-: rep-not-assigned ( vregs -- vregs' )
-    representations get '[ _ key? not ] filter ;
-
-: add-ready-phis ( -- )
-    phis get keys rep-assigned add-to-work-list ;
-
-: process-phi ( dst -- )
-    ! If dst = phi(src1,src2,...) and dst's representation has been
-    ! determined, assign that representation to each one of src1,...
-    ! that does not have a representation yet, and process those, too.
-    dup phis get at* [
-        [ rep-of ] [ rep-not-assigned ] bi*
-        [ [ set-rep-of ] with each ] [ add-to-work-list ] bi
-    ] [ 2drop ] if ;
-
-: remaining-phis ( -- )
-    phis get keys rep-not-assigned { } assert-sequence= ;
-
-: process-phis ( -- )
-    <hashed-dlist> work-list set
-    add-ready-phis
-    work-list get [ process-phi ] slurp-deque
-    remaining-phis ;
-
-: compute-phi-representations ( cfg -- )
-    collect-phis process-phis ;
+    compute-costs costs get minimize-costs
+    [ components get [ disjoint-set-members ] keep ] dip
+    '[ dup _ representative _ at ] H{ } map>assoc
+    representations set ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 0c9d386544..0b1b8ab0fe 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -2302,11 +2302,14 @@ V{
 } 3 test-bb
 
 V{
-    T{ ##phi f 3 H{ { 2 1 } { 3 2 } } }
+    T{ ##phi f 3 }
     T{ ##replace f 3 D 0 }
     T{ ##return }
 } 4 test-bb
 
+2 get 1 2array
+3 get 2 2array 2array 4 get instructions>> first (>>inputs)
+
 test-diamond
 
 [ ] [
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 855e272f02..a77337d1a0 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -87,6 +87,20 @@ UNION: vector-rep
 int-vector-rep
 float-vector-rep ;
 
+CONSTANT: vector-reps
+    {
+        char-16-rep
+        uchar-16-rep
+        short-8-rep
+        ushort-8-rep
+        int-4-rep
+        uint-4-rep
+        longlong-2-rep
+        ulonglong-2-rep
+        float-4-rep
+        double-2-rep
+    }
+
 UNION: representation
 any-rep
 tagged-rep
diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor
index 05df13f073..a158302ecc 100644
--- a/basis/disjoint-sets/disjoint-sets.factor
+++ b/basis/disjoint-sets/disjoint-sets.factor
@@ -74,6 +74,10 @@ GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
 
 M: disjoint-set disjoint-set-member? parents>> key? ;
 
+GENERIC: disjoint-set-members ( disjoint-set -- seq )
+
+M: disjoint-set disjoint-set-members parents>> keys ;
+
 GENERIC: equiv-set-size ( a disjoint-set -- n )
 
 M: disjoint-set equiv-set-size [ representative ] keep count ;

From ed8c32989f0b269096c206f51a98eb88be8e5206 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 25 Apr 2010 05:30:38 -0400
Subject: [PATCH 125/158] compiler.cfg.representations: add peephole
 optimizations for integer comparisons

---
 .../representations/peephole/peephole.factor  | 46 +++++++++++++++++--
 .../representations-tests.factor              | 45 ++++++++++++++++++
 .../selection/selection.factor                | 24 ++++++----
 3 files changed, 100 insertions(+), 15 deletions(-)

diff --git a/basis/compiler/cfg/representations/peephole/peephole.factor b/basis/compiler/cfg/representations/peephole/peephole.factor
index 117ce6da7e..6c6347f11c 100644
--- a/basis/compiler/cfg/representations/peephole/peephole.factor
+++ b/basis/compiler/cfg/representations/peephole/peephole.factor
@@ -104,8 +104,14 @@ M: ##load-reference optimize-insn
         [ 2drop int-rep ##copy here ]
     } cond ;
 
+: inert-tag-imm? ( insn -- ? )
+    src1>> rep-of tagged-rep? ;
+
 : inert-tag/untag-imm? ( insn -- ? )
-    [ dst>> ] [ src1>> ] bi [ rep-of tagged-rep? ] both? ;
+    {
+        [ dst>> rep-of tagged-rep? ]
+        [ inert-tag-imm? ]
+    } 1&& ;
 
 M: ##shl-imm optimize-insn
     {
@@ -169,13 +175,15 @@ M: ##sar-imm optimize-insn
 !
 ! so if all inputs and outputs of ##X or ##X-imm are tagged,
 ! don't have to insert any conversions
-: inert-tag/untag? ( insn -- ? )
+: inert-tag? ( insn -- ? )
     {
-        [ dst>> rep-of tagged-rep? ]
         [ src1>> rep-of tagged-rep? ]
         [ src2>> rep-of tagged-rep? ]
     } 1&& ;
 
+: inert-tag/untag? ( insn -- ? )
+    { [ dst>> rep-of tagged-rep? ] [ inert-tag? ] } 1&& ;
+
 M: inert-tag-untag-insn optimize-insn
     {
         { [ dup inert-tag/untag? ] [ unchanged ] }
@@ -183,16 +191,44 @@ M: inert-tag-untag-insn optimize-insn
     } cond ;
 
 ! -imm variant of above
+: >tagged-imm ( insn -- )
+    [ tag-fixnum ] change-src2 unchanged ; inline
+
 M: inert-tag-untag-imm-insn optimize-insn
     {
-        { [ dup inert-tag/untag-imm? ] [ [ tag-fixnum ] change-src2 unchanged ] }
+        { [ dup inert-tag/untag-imm? ] [ >tagged-imm ] }
         [ call-next-method ]
     } cond ;
 
 M: ##mul-imm optimize-insn
     {
         { [ dup inert-tag/untag-imm? ] [ unchanged ] }
-        { [ dup dst>> rep-of tagged-rep? ] [ [ tag-fixnum ] change-src2 unchanged ] }
+        { [ dup dst>> rep-of tagged-rep? ] [ >tagged-imm ] }
+        [ call-next-method ]
+    } cond ;
+
+! Similar optimization for comparison operators
+M: ##compare-integer-imm optimize-insn
+    {
+        { [ dup inert-tag-imm? ] [ >tagged-imm ] }
+        [ call-next-method ]
+    } cond ;
+
+M: ##compare-integer-imm-branch optimize-insn
+    {
+        { [ dup inert-tag-imm? ] [ >tagged-imm ] }
+        [ call-next-method ]
+    } cond ;
+
+M: ##compare-integer optimize-insn
+    {
+        { [ dup inert-tag? ] [ unchanged ] }
+        [ call-next-method ]
+    } cond ;
+
+M: ##compare-integer-branch optimize-insn
+    {
+        { [ dup inert-tag? ] [ unchanged ] }
         [ call-next-method ]
     } cond ;
 
diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor
index dcd7fc7241..3f406660ca 100644
--- a/basis/compiler/cfg/representations/representations-tests.factor
+++ b/basis/compiler/cfg/representations/representations-tests.factor
@@ -605,6 +605,51 @@ cpu x86.32? [
     } test-peephole
 ] unit-test
 
+! Tag/untag elimination for ##compare-integer
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer f 2 0 1 cc= }
+        T{ ##replace f 2 D 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer f 2 0 1 cc= }
+        T{ ##replace f 2 D 0 }
+    } test-peephole
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-branch f 0 1 cc= }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-branch f 0 1 cc= }
+    } test-peephole
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-imm-branch f 0 $[ 10 tag-fixnum ] cc= }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##compare-integer-imm-branch f 0 10 cc= }
+    } test-peephole
+] unit-test
+
 ! Tag/untag elimination for ##neg
 [
     V{
diff --git a/basis/compiler/cfg/representations/selection/selection.factor b/basis/compiler/cfg/representations/selection/selection.factor
index 23e1f78766..e5f3bfff3b 100644
--- a/basis/compiler/cfg/representations/selection/selection.factor
+++ b/basis/compiler/cfg/representations/selection/selection.factor
@@ -113,17 +113,21 @@ UNION: inert-tag-untag-imm-insn
 
 GENERIC: has-peephole-opts? ( insn -- ? )
 
-M: insn                     has-peephole-opts? drop f ;
-M: ##load-integer           has-peephole-opts? drop t ;
-M: ##load-reference         has-peephole-opts? drop t ;
-M: inert-tag-untag-insn     has-peephole-opts? drop t ;
+M: insn has-peephole-opts? drop f ;
+M: ##load-integer has-peephole-opts? drop t ;
+M: ##load-reference has-peephole-opts? drop t ;
+M: ##neg has-peephole-opts? drop t ;
+M: ##not has-peephole-opts? drop t ;
+M: inert-tag-untag-insn has-peephole-opts? drop t ;
 M: inert-tag-untag-imm-insn has-peephole-opts? drop t ;
-M: ##mul-imm                has-peephole-opts? drop t ;
-M: ##shl-imm                has-peephole-opts? drop t ;
-M: ##shr-imm                has-peephole-opts? drop t ;
-M: ##sar-imm                has-peephole-opts? drop t ;
-M: ##neg                    has-peephole-opts? drop t ;
-M: ##not                    has-peephole-opts? drop t ;
+M: ##mul-imm has-peephole-opts? drop t ;
+M: ##shl-imm has-peephole-opts? drop t ;
+M: ##shr-imm has-peephole-opts? drop t ;
+M: ##sar-imm has-peephole-opts? drop t ;
+M: ##compare-integer-imm has-peephole-opts? drop t ;
+M: ##compare-integer has-peephole-opts? drop t ;
+M: ##compare-integer-imm-branch has-peephole-opts? drop t ;
+M: ##compare-integer-branch has-peephole-opts? drop t ;
 
 GENERIC: compute-insn-costs ( insn -- )
 

From 458fd007bee7255196cd27d87cc29aac6980a954 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 25 Apr 2010 16:07:08 -0400
Subject: [PATCH 126/158] compiler.cfg.representations: simplify a little

---
 .../selection/selection.factor                | 54 ++++++++-----------
 basis/compiler/cfg/ssa/cssa/cssa.factor       |  7 ++-
 2 files changed, 26 insertions(+), 35 deletions(-)

diff --git a/basis/compiler/cfg/representations/selection/selection.factor b/basis/compiler/cfg/representations/selection/selection.factor
index e5f3bfff3b..73e536ebee 100644
--- a/basis/compiler/cfg/representations/selection/selection.factor
+++ b/basis/compiler/cfg/representations/selection/selection.factor
@@ -15,57 +15,52 @@ cpu.architecture ;
 FROM: namespaces => set ;
 IN: compiler.cfg.representations.selection
 
-SYMBOL: scc-infos
+! vregs which must be tagged at the definition site because
+! there is at least one usage that is not int-rep. If all usages
+! are int-rep it is safe to untag at the definition site.
+SYMBOL: tagged-vregs
 
-TUPLE: scc-info reps all-uses-untagged? ;
-
-: <scc-info> ( -- reps )
-    V{ } clone t \ scc-info boa ;
-
-: scc-info ( vreg -- info )
-    vreg>scc scc-infos get [ drop <scc-info> ] cache ;
+SYMBOL: vreg-reps
 
 : handle-def ( vreg rep -- )
-    swap scc-info reps>> push ;
+    swap vreg>scc vreg-reps get
+    [ [ intersect ] when* ] change-at ;
 
 : handle-use ( vreg rep -- )
-    int-rep eq? [ scc-info f >>all-uses-untagged? ] unless drop ;
+    int-rep eq? [ drop ] [ vreg>scc tagged-vregs get adjoin ] if ;
 
-GENERIC: collect-scc-info ( insn -- )
+GENERIC: (collect-vreg-reps) ( insn -- )
 
-M: ##load-reference collect-scc-info
+M: ##load-reference (collect-vreg-reps)
     [ dst>> ] [ obj>> ] bi {
         { [ dup float? ] [ drop { float-rep double-rep } ] }
         { [ dup byte-array? ] [ drop vector-reps ] }
         [ drop { } ]
     } cond handle-def ;
 
-M: vreg-insn collect-scc-info
+M: vreg-insn (collect-vreg-reps)
     [ [ handle-use ] each-use-rep ]
     [ [ 1array handle-def ] each-def-rep ]
     [ [ 1array handle-def ] each-temp-rep ]
     tri ;
 
-M: insn collect-scc-info drop ;
+M: insn (collect-vreg-reps) drop ;
 
-: collect-scc-infos ( cfg -- )
-    H{ } clone scc-infos set
-    [ [ collect-scc-info ] each-non-phi ] each-basic-block ;
+: collect-vreg-reps ( cfg -- )
+    H{ } clone vreg-reps set
+    HS{ } clone tagged-vregs set
+    [ [ (collect-vreg-reps) ] each-non-phi ] each-basic-block ;
 
 SYMBOL: possibilities
 
-: permitted-reps ( scc-info -- seq )
-    reps>> [ ] [ intersect ] map-reduce
-    tagged-rep over member-eq? [ tagged-rep suffix ] unless ;
-
-: scc-reps ( scc-info -- seq )
-    dup permitted-reps
-    2dup [ all-uses-untagged?>> ] [ { tagged-rep } = ] bi* and
-    [ 2drop { tagged-rep int-rep } ] [ nip ] if ;
+: possible-reps ( vreg reps -- vreg reps )
+    { tagged-rep } union
+    2dup [ tagged-vregs get in? not ] [ { tagged-rep } = ] bi* and
+    [ drop { tagged-rep int-rep } ] [ ] if ;
 
 : compute-possibilities ( cfg -- )
-    collect-scc-infos
-    scc-infos get [ scc-reps ] assoc-map possibilities set ;
+    collect-vreg-reps
+    vreg-reps get [ possible-reps ] assoc-map possibilities set ;
 
 ! For every vreg, compute the cost of keeping it in every possible
 ! representation.
@@ -86,12 +81,9 @@ SYMBOL: costs
     [ costs get at 2dup key? ] dip
     '[ [ current-loop-nesting 10^ _ * + ] change-at ] [ 2drop ] if ;
 
-: possible-reps ( scc -- reps )
-    possibilities get at ;
-
 :: increase-costs ( vreg preferred factor -- )
     vreg vreg>scc :> scc
-    scc possible-reps [
+    scc possibilities get at [
         dup preferred eq? [ drop ] [ scc factor increase-cost ] if
     ] each ; inline
 
diff --git a/basis/compiler/cfg/ssa/cssa/cssa.factor b/basis/compiler/cfg/ssa/cssa/cssa.factor
index 611f722cb3..06ae6767ca 100644
--- a/basis/compiler/cfg/ssa/cssa/cssa.factor
+++ b/basis/compiler/cfg/ssa/cssa/cssa.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs kernel locals fry sequences
 cpu.architecture
@@ -6,8 +6,7 @@ compiler.cfg.rpo
 compiler.cfg.def-use
 compiler.cfg.utilities
 compiler.cfg.registers
-compiler.cfg.instructions
-compiler.cfg.representations.conversion ;
+compiler.cfg.instructions ;
 IN: compiler.cfg.ssa.cssa
 
 ! Convert SSA to conventional SSA. This pass runs after representation
@@ -24,7 +23,7 @@ IN: compiler.cfg.ssa.cssa
 :: insert-copy ( bb src rep -- bb dst )
     bb src insert-copy? [
         rep next-vreg-rep :> dst
-        bb [ dst src rep src rep-of emit-conversion ] add-instructions
+        bb [ dst src rep ##copy ] add-instructions
         bb dst
     ] [ bb src ] if ;
 

From a9ccfa8f05df3f7954dacc5d33f442f1bd373f31 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 25 Apr 2010 20:19:50 -0400
Subject: [PATCH 127/158] strings: move string-nth primitive out of the VM and
 into the library

---
 .../cfg/instructions/instructions.factor      |  7 --
 .../compiler/cfg/intrinsics/intrinsics.factor |  2 +-
 .../cfg/intrinsics/strings/strings.factor     | 10 +-
 basis/compiler/codegen/codegen.factor         |  1 -
 basis/compiler/tests/low-level-ir.factor      |  9 --
 .../known-words/known-words.factor            |  4 +-
 .../tree/propagation/propagation-tests.factor |  7 ++
 basis/cpu/architecture/architecture.factor    |  2 -
 basis/cpu/ppc/ppc.factor                      | 16 ---
 basis/cpu/x86/bootstrap.factor                | 18 +++-
 basis/cpu/x86/x86.factor                      | 26 -----
 .../known-words/known-words.factor            |  3 +-
 core/bootstrap/primitives.factor              |  3 +-
 core/strings/strings-tests.factor             |  3 +
 core/strings/strings.factor                   | 31 +++++-
 vm/debug.cpp                                  |  2 +-
 vm/layouts.hpp                                |  2 -
 vm/primitives.hpp                             |  2 -
 vm/strings.cpp                                | 98 +++----------------
 vm/utilities.hpp                              | 21 ++++
 vm/vm.hpp                                     |  6 --
 21 files changed, 103 insertions(+), 170 deletions(-)

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 13c9f55b9f..8ee21154fa 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -89,12 +89,6 @@ INSN: ##set-slot-imm
 use: src/tagged-rep obj/tagged-rep
 literal: slot tag ;
 
-! String element access
-INSN: ##string-nth
-def: dst/int-rep
-use: obj/tagged-rep index/int-rep
-temp: temp/int-rep ;
-
 ! Register transfers
 INSN: ##copy
 def: dst
@@ -806,7 +800,6 @@ UNION: kill-vreg-insn
 UNION: def-is-use-insn
 ##box-alien
 ##box-displaced-alien
-##string-nth
 ##unbox-any-c-ptr ;
 
 SYMBOL: vreg-insn
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 231cd5cee9..4faa4809e5 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -56,7 +56,7 @@ IN: compiler.cfg.intrinsics
     { kernel:eq? [ emit-eq ] }
     { slots.private:slot [ emit-slot ] }
     { slots.private:set-slot [ emit-set-slot ] }
-    { strings.private:string-nth [ drop emit-string-nth ] }
+    { strings.private:string-nth-fast [ drop emit-string-nth-fast ] }
     { strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
     { classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
     { arrays:<array> [ emit-<array> ] }
diff --git a/basis/compiler/cfg/intrinsics/strings/strings.factor b/basis/compiler/cfg/intrinsics/strings/strings.factor
index dea9510a99..70d8442a2b 100644
--- a/basis/compiler/cfg/intrinsics/strings/strings.factor
+++ b/basis/compiler/cfg/intrinsics/strings/strings.factor
@@ -5,9 +5,11 @@ compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.stacks cpu.architecture ;
 IN: compiler.cfg.intrinsics.strings
 
-: emit-string-nth ( -- )
-    2inputs swap ^^string-nth ds-push ;
+: (string-nth) ( n string -- base offset rep c-type )
+    ^^tagged>integer swap ^^add string-offset int-rep uchar ; inline
+
+: emit-string-nth-fast ( -- )
+    2inputs (string-nth) ^^load-memory-imm ds-push ;
 
 : emit-set-string-nth-fast ( -- )
-    3inputs ^^tagged>integer ^^add string-offset
-    int-rep uchar ##store-memory-imm ;
+    3inputs (string-nth) ##store-memory-imm ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index d0747d4a1e..63571e7874 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -93,7 +93,6 @@ CODEGEN: ##slot %slot
 CODEGEN: ##slot-imm %slot-imm
 CODEGEN: ##set-slot %set-slot
 CODEGEN: ##set-slot-imm %set-slot-imm
-CODEGEN: ##string-nth %string-nth
 CODEGEN: ##add %add
 CODEGEN: ##add-imm %add-imm
 CODEGEN: ##sub %sub
diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index 7ce43e9524..57612e730e 100644
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -97,15 +97,6 @@ IN: compiler.tests.low-level-ir
     } compile-test-bb
 ] unit-test
 
-[ CHAR: l ] [
-    V{
-        T{ ##load-reference f 0 "hello world" }
-        T{ ##load-tagged f 1 3 }
-        T{ ##string-nth f 0 0 1 2 }
-        T{ ##shl-imm f 0 0 4 }
-    } compile-test-bb
-] unit-test
-
 [ 1 ] [
     V{
         T{ ##load-tagged f 0 32 }
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 55629507ab..ada01e213a 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -254,8 +254,8 @@ generic-comparison-ops [
     ] "outputs" set-word-prop
 ] each
 
-\ string-nth [
-    2drop fixnum 0 23 2^ [a,b] <class/interval-info>
+\ string-nth-fast [
+    2drop fixnum 0 255 [a,b] <class/interval-info>
 ] "outputs" set-word-prop
 
 {
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index ad8a75ecdd..d1a1dd18a6 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -968,3 +968,10 @@ M: tuple-with-read-only-slot clone
 
 [ t ] [ [ { 1 } diff ] { diff } inlined? ] unit-test
 [ f ] [ [ { 1 } swap diff ] { diff } inlined? ] unit-test ! We could do this
+
+! Output range for string-nth now that string-nth is a library word and
+! not a primitive
+[ t ] [
+    ! Should actually be 0 23 2^ 1 - [a,b]
+    [ string-nth ] final-info first interval>> 0 23 2^ [a,b] =
+] unit-test
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index a77337d1a0..d7e77d6267 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -244,8 +244,6 @@ HOOK: %slot-imm cpu ( dst obj slot tag -- )
 HOOK: %set-slot cpu ( src obj slot scale tag -- )
 HOOK: %set-slot-imm cpu ( src obj slot tag -- )
 
-HOOK: %string-nth cpu ( dst obj index temp -- )
-
 HOOK: %add     cpu ( dst src1 src2 -- )
 HOOK: %add-imm cpu ( dst src1 src2 -- )
 HOOK: %sub     cpu ( dst src1 src2 -- )
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 3c23ae1b5f..70e8ef11ea 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -144,22 +144,6 @@ M: ppc %slot-imm ( dst obj slot tag -- ) slot-offset LWZ ;
 M: ppc %set-slot ( src obj slot -- ) swapd STWX ;
 M: ppc %set-slot-imm ( src obj slot tag -- ) slot-offset STW ;
 
-M:: ppc %string-nth ( dst src index temp -- )
-    [
-        "end" define-label
-        temp src index ADD
-        dst temp string-offset LBZ
-        0 dst HEX: 80 CMPI
-        "end" get BLT
-        temp src string-aux-offset LWZ
-        temp temp index ADD
-        temp temp index ADD
-        temp temp byte-array-offset LHZ
-        temp temp 7 SLWI
-        dst dst temp XOR
-        "end" resolve-label
-    ] with-scope ;
-
 M: ppc %add     ADD ;
 M: ppc %add-imm ADDI ;
 M: ppc %sub     swap SUBF ;
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 969c02c910..5bb55bead0 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -3,7 +3,8 @@
 USING: bootstrap.image.private compiler.constants
 compiler.units cpu.x86.assembler cpu.x86.assembler.operands
 kernel kernel.private layouts locals.backend make math
-math.private namespaces sequences slots.private vocabs ;
+math.private namespaces sequences slots.private strings.private
+vocabs ;
 IN: bootstrap.x86
 
 big-endian off
@@ -294,6 +295,21 @@ big-endian off
     ds-reg [] temp0 MOV
 ] \ slot define-sub-primitive
 
+[
+    ! load string index from stack
+    temp0 ds-reg bootstrap-cell neg [+] MOV
+    temp0 tag-bits get SHR
+    ! load string from stack
+    temp1 ds-reg [] MOV
+    ! load character
+    temp0 8-bit-version-of temp0 temp1 string-offset [++] MOV
+    temp0 temp0 8-bit-version-of MOVZX
+    temp0 tag-bits get SHL
+    ! store character to stack
+    ds-reg bootstrap-cell SUB
+    ds-reg [] temp0 MOV
+] \ string-nth-fast define-sub-primitive
+
 ! Shufflers
 [
     ds-reg bootstrap-cell SUB
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index a7fd859c20..d0afb7fa81 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -328,32 +328,6 @@ M: x86.64 has-small-reg? 2drop t ;
         [ quot call ] with-save/restore
     ] if ; inline
 
-M:: x86 %string-nth ( dst src index temp -- )
-    ! We request a small-reg of size 8 since those of size 16 are
-    ! a superset.
-    "end" define-label
-    dst { src index temp } 8 [| new-dst |
-        ! Load the least significant 7 bits into new-dst.
-        ! 8th bit indicates whether we have to load from
-        ! the aux vector or not.
-        new-dst 8-bit-version-of src index string-offset [++] MOV
-        new-dst new-dst 8-bit-version-of MOVZX
-        ! Do we have to look at the aux vector?
-        new-dst HEX: 80 CMP
-        "end" get JL
-        ! Yes, this is a non-ASCII character. Load aux vector
-        temp src string-aux-offset [+] MOV
-        new-dst temp XCHG
-        ! Load high 16 bits
-        new-dst 16-bit-version-of new-dst index byte-array-offset [+*2+] MOV
-        new-dst new-dst 16-bit-version-of MOVZX
-        new-dst 7 SHL
-        ! Compute code point
-        new-dst temp XOR
-        "end" resolve-label
-        dst new-dst int-rep %copy
-    ] with-small-register ;
-
 :: %alien-integer-getter ( dst exclude address bits quot -- )
     dst exclude bits [| new-dst |
         new-dst dup bits n-bit-version-of dup address MOV
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index c0d4b6c543..a652c500ba 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -454,11 +454,10 @@ M: bad-executable summary
 \ set-slot { object object fixnum } { } define-primitive
 \ set-special-object { object fixnum } { } define-primitive
 \ set-string-nth-fast { fixnum fixnum string } { } define-primitive
-\ set-string-nth-slow { fixnum fixnum string } { } define-primitive
 \ size { object } { fixnum } define-primitive \ size make-flushable
 \ slot { object fixnum } { object } define-primitive \ slot make-flushable
 \ special-object { fixnum } { object } define-primitive \ special-object make-flushable
-\ string-nth { fixnum string } { fixnum } define-primitive \ string-nth make-flushable
+\ string-nth-fast { fixnum string } { fixnum } define-primitive \ string-nth-fast make-flushable
 \ strip-stack-traces { } { } define-primitive
 \ system-micros { } { integer } define-primitive \ system-micros make-flushable
 \ tag { object } { fixnum } define-primitive \ tag make-foldable
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 27699725f1..c00199e9b3 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -370,6 +370,7 @@ tuple
     { "fixnum<=" "math.private" (( x y -- z )) }
     { "fixnum>" "math.private" (( x y -- ? )) }
     { "fixnum>=" "math.private" (( x y -- ? )) }
+    { "string-nth-fast" "strings.private" (( n string -- ch )) }
     { "(set-context)" "threads.private" (( obj context -- obj' )) }
     { "(set-context-and-delete)" "threads.private" (( obj context -- * )) }
     { "(start-context)" "threads.private" (( obj quot -- obj' )) }
@@ -533,8 +534,6 @@ tuple
     { "<string>" "strings" "primitive_string" (( n ch -- string )) }
     { "resize-string" "strings" "primitive_resize_string" (( n str -- newstr )) }
     { "set-string-nth-fast" "strings.private" "primitive_set_string_nth_fast" (( ch n string -- )) }
-    { "set-string-nth-slow" "strings.private" "primitive_set_string_nth_slow" (( ch n string -- )) }
-    { "string-nth" "strings.private" "primitive_string_nth" (( n string -- ch )) }
     { "(exit)" "system" "primitive_exit" (( n -- * )) }
     { "nano-count" "system" "primitive_nano_count" (( -- ns )) }
     { "system-micros" "system" "primitive_system_micros" (( -- us )) }
diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor
index b90d96a356..247bd8d007 100644
--- a/core/strings/strings-tests.factor
+++ b/core/strings/strings-tests.factor
@@ -85,6 +85,9 @@ unit-test
     "s" get >array
 ] unit-test
 
+! Make sure string initialization works
+[ HEX: 123456 ] [ 100 HEX: 123456 <string> first ] unit-test
+
 ! Make sure we clear aux vector when storing octets
 [ "\u123456hi" ] [ "ih\u123456" clone reverse! ] unit-test
 
diff --git a/core/strings/strings.factor b/core/strings/strings.factor
index 50d79a4d8a..f356d2a877 100644
--- a/core/strings/strings.factor
+++ b/core/strings/strings.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.private sequences kernel.private
-math sequences.private slots.private alien.accessors ;
+USING: accessors alien.accessors byte-arrays kernel math.private
+sequences kernel.private math sequences.private slots.private ;
 IN: strings
 
 <PRIVATE
@@ -16,8 +16,31 @@ IN: strings
 : rehash-string ( str -- )
     1 over sequence-hashcode swap set-string-hashcode ; inline
 
+: (aux) ( n string -- byte-array m )
+    aux>> { byte-array } declare swap 1 fixnum-shift-fast ; inline
+
+: small-char? ( ch -- ? ) HEX: 7f fixnum<= ; inline
+
+: string-nth ( n string -- ch )
+    2dup string-nth-fast dup small-char?
+    [ 2nip ] [
+        [ (aux) alien-unsigned-2 7 fixnum-shift-fast ] dip
+        fixnum-bitxor
+    ] if ; inline
+
+: ensure-aux ( string -- string )
+    dup aux>> [ dup length 2 * (byte-array) >>aux ] unless ; inline
+
+: set-string-nth-slow ( ch n string -- )
+    [ [ HEX: 80 fixnum-bitor ] 2dip set-string-nth-fast ]
+    [
+        ensure-aux
+        [ -7 fixnum-shift-fast 1 fixnum-bitxor ] 2dip
+        (aux) set-alien-unsigned-2
+    ] 3bi ;
+
 : set-string-nth ( ch n string -- )
-    pick HEX: 7f fixnum<=
+    pick small-char?
     [ set-string-nth-fast ] [ set-string-nth-slow ] if ; inline
 
 PRIVATE>
diff --git a/vm/debug.cpp b/vm/debug.cpp
index 85335d49ae..bb3a8b0ce5 100755
--- a/vm/debug.cpp
+++ b/vm/debug.cpp
@@ -6,7 +6,7 @@ namespace factor
 std::ostream &operator<<(std::ostream &out, const string *str)
 {
 	for(cell i = 0; i < string_capacity(str); i++)
-		out << (char)str->nth(i);
+		out << (char)str->data()[i];
 	return out;
 }
 
diff --git a/vm/layouts.hpp b/vm/layouts.hpp
index 3e51d1fa4d..0cf8607a05 100644
--- a/vm/layouts.hpp
+++ b/vm/layouts.hpp
@@ -205,8 +205,6 @@ struct string : public object {
 	cell hashcode;
 
 	u8 *data() const { return (u8 *)(this + 1); }
-
-	cell nth(cell i) const;
 };
 
 struct code_block;
diff --git a/vm/primitives.hpp b/vm/primitives.hpp
index a2bf912749..cf52168231 100644
--- a/vm/primitives.hpp
+++ b/vm/primitives.hpp
@@ -120,12 +120,10 @@ namespace factor
 	_(set_slot) \
 	_(set_special_object) \
 	_(set_string_nth_fast) \
-	_(set_string_nth_slow) \
 	_(size) \
 	_(sleep) \
 	_(special_object) \
 	_(string) \
-	_(string_nth) \
 	_(strip_stack_traces) \
 	_(system_micros) \
 	_(tuple) \
diff --git a/vm/strings.cpp b/vm/strings.cpp
index 5aad936a9e..aea4641905 100644
--- a/vm/strings.cpp
+++ b/vm/strings.cpp
@@ -3,66 +3,6 @@
 namespace factor
 {
 
-cell string::nth(cell index) const
-{
-	/* If high bit is set, the most significant 16 bits of the char
-	come from the aux vector. The least significant bit of the
-	corresponding aux vector entry is negated, so that we can
-	XOR the two components together and get the original code point
-	back. */
-	cell lo_bits = data()[index];
-
-	if((lo_bits & 0x80) == 0)
-		return lo_bits;
-	else
-	{
-		byte_array *aux = untag<byte_array>(this->aux);
-		cell hi_bits = aux->data<u16>()[index];
-		return (hi_bits << 7) ^ lo_bits;
-	}
-}
-
-void factor_vm::set_string_nth_fast(string *str, cell index, cell ch)
-{
-	str->data()[index] = (u8)ch;
-}
-
-void factor_vm::set_string_nth_slow(string *str_, cell index, cell ch)
-{
-	data_root<string> str(str_,this);
-
-	byte_array *aux;
-
-	str->data()[index] = ((ch & 0x7f) | 0x80);
-
-	if(to_boolean(str->aux))
-		aux = untag<byte_array>(str->aux);
-	else
-	{
-		/* We don't need to pre-initialize the
-		byte array with any data, since we
-		only ever read from the aux vector
-		if the most significant bit of a
-		character is set. Initially all of
-		the bits are clear. */
-		aux = allot_uninitialized_array<byte_array>(untag_fixnum(str->length) * sizeof(u16));
-
-		str->aux = tag<byte_array>(aux);
-		write_barrier(&str->aux);
-	}
-
-	aux->data<u16>()[index] = (u16)((ch >> 7) ^ 1);
-}
-
-/* allocates memory */
-void factor_vm::set_string_nth(string *str, cell index, cell ch)
-{
-	if(ch <= 0x7f)
-		set_string_nth_fast(str,index,ch);
-	else
-		set_string_nth_slow(str,index,ch);
-}
-
 /* Allocates memory */
 string *factor_vm::allot_string_internal(cell capacity)
 {
@@ -81,13 +21,23 @@ void factor_vm::fill_string(string *str_, cell start, cell capacity, cell fill)
 	data_root<string> str(str_,this);
 
 	if(fill <= 0x7f)
-		memset(&str->data()[start],(int)fill,capacity - start);
+		memset(&str->data()[start],(u8)fill,capacity - start);
 	else
 	{
-		cell i;
+		byte_array *aux;
+		if(to_boolean(str->aux))
+			aux = untag<byte_array>(str->aux);
+		else
+		{
+			aux = allot_uninitialized_array<byte_array>(untag_fixnum(str->length) * 2);
+			str->aux = tag<byte_array>(aux);
+			write_barrier(&str->aux);
+		}
 
-		for(i = start; i < capacity; i++)
-			set_string_nth(str.untagged(),i,fill);
+		u8 lo_fill = (u8)((fill & 0x7f) | 0x80);
+		u16 hi_fill = (u16)((fill >> 7) ^ 0x1);
+		memset(&str->data()[start],lo_fill,capacity - start);
+		memset_2(&aux->data<u16>()[start],hi_fill,(capacity - start) * sizeof(u16));
 	}
 }
 
@@ -141,8 +91,7 @@ string* factor_vm::reallot_string(string *str_, cell capacity)
 
 		if(to_boolean(str->aux))
 		{
-			byte_array *new_aux = allot_byte_array(capacity * sizeof(u16));
-
+			byte_array *new_aux = allot_uninitialized_array<byte_array>(capacity * 2);
 			new_str->aux = tag<byte_array>(new_aux);
 			write_barrier(&new_str->aux);
 
@@ -163,27 +112,12 @@ void factor_vm::primitive_resize_string()
 	ctx->push(tag<string>(reallot_string(str.untagged(),capacity)));
 }
 
-void factor_vm::primitive_string_nth()
-{
-	string *str = untag<string>(ctx->pop());
-	cell index = untag_fixnum(ctx->pop());
-	ctx->push(tag_fixnum(str->nth(index)));
-}
-
 void factor_vm::primitive_set_string_nth_fast()
 {
 	string *str = untag<string>(ctx->pop());
 	cell index = untag_fixnum(ctx->pop());
 	cell value = untag_fixnum(ctx->pop());
-	set_string_nth_fast(str,index,value);
-}
-
-void factor_vm::primitive_set_string_nth_slow()
-{
-	string *str = untag<string>(ctx->pop());
-	cell index = untag_fixnum(ctx->pop());
-	cell value = untag_fixnum(ctx->pop());
-	set_string_nth_slow(str,index,value);
+	str->data()[index] = (u8)value;
 }
 
 }
diff --git a/vm/utilities.hpp b/vm/utilities.hpp
index cea70c0c37..e75d3ece12 100755
--- a/vm/utilities.hpp
+++ b/vm/utilities.hpp
@@ -1,6 +1,27 @@
 namespace factor
 {
 
+inline static void memset_2(void *dst, u16 pattern, size_t size)
+{
+#ifdef __APPLE__
+	cell cell_pattern = (pattern | (pattern << 16));
+	memset_pattern4(dst,&cell_pattern,size);
+#else
+	if(pattern == 0)
+		memset(dst,0,size);
+	else
+	{
+		u16 *start = (u16 *)dst;
+		u16 *end = (u16 *)((cell)dst + size);
+		while(start < end)
+		{
+			*start = pattern;
+			start++;
+		}
+	}
+#endif
+}
+
 inline static void memset_cell(void *dst, cell pattern, size_t size)
 {
 #ifdef __APPLE__
diff --git a/vm/vm.hpp b/vm/vm.hpp
index d9bd17fa51..3b6fb2311f 100755
--- a/vm/vm.hpp
+++ b/vm/vm.hpp
@@ -381,10 +381,6 @@ struct factor_vm
 	cell std_vector_to_array(std::vector<cell> &elements);
 
 	// strings
-	cell string_nth(const string *str, cell index);
-	void set_string_nth_fast(string *str, cell index, cell ch);
-	void set_string_nth_slow(string *str_, cell index, cell ch);
-	void set_string_nth(string *str, cell index, cell ch);
 	string *allot_string_internal(cell capacity);
 	void fill_string(string *str_, cell start, cell capacity, cell fill);
 	string *allot_string(cell capacity, cell fill);
@@ -392,9 +388,7 @@ struct factor_vm
 	bool reallot_string_in_place_p(string *str, cell capacity);
 	string* reallot_string(string *str_, cell capacity);
 	void primitive_resize_string();
-	void primitive_string_nth();
 	void primitive_set_string_nth_fast();
-	void primitive_set_string_nth_slow();
 
 	// booleans
 	cell tag_boolean(cell untagged)

From 51b13ce37326937eaf0c26a8752b0cb5bbb3a590 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 Apr 2010 00:53:00 -0400
Subject: [PATCH 128/158] compiler.cfg.linear-scan: don't insert a _reload if
 the register is going to be overwritten anyway

---
 .../linear-scan/allocation/allocation.factor  |  5 +-
 .../allocation/spilling/spilling.factor       | 11 ++--
 .../allocation/splitting/splitting.factor     |  4 +-
 .../linear-scan/assignment/assignment.factor  | 14 +++-
 .../cfg/linear-scan/linear-scan-tests.factor  | 66 +++++++++----------
 .../live-intervals/live-intervals.factor      | 54 ++++++++-------
 6 files changed, 84 insertions(+), 70 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 8951d7a1f1..ae6c375016 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs heaps kernel namespaces sequences fry math
 math.order combinators arrays sorting compiler.utilities locals
@@ -38,7 +38,8 @@ IN: compiler.cfg.linear-scan.allocation
     ! If the live interval has a usage at 'n', don't spill it,
     ! since this means its being defined by the sync point
     ! instruction. Output t if this is the case.
-    2dup [ uses>> ] dip swap member? [ 2drop t ] [ spill f ] if ;
+    2dup [ uses>> ] dip '[ n>> _ = ] any?
+    [ 2drop t ] [ spill f ] if ;
 
 : handle-sync-point ( n -- )
     [ active-intervals get values ] dip
diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
index 845cb14d5c..a914aab4bf 100644
--- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators fry hints kernel locals
 math sequences sets sorting splitting namespaces linked-assocs
@@ -17,13 +17,13 @@ ERROR: bad-live-ranges interval ;
     ] [ drop ] if ;
 
 : trim-before-ranges ( live-interval -- )
-    [ ranges>> ] [ uses>> last 1 + ] bi
+    [ ranges>> ] [ uses>> last n>> 1 + ] bi
     [ '[ from>> _ <= ] filter! drop ]
     [ swap last (>>to) ]
     2bi ;
 
 : trim-after-ranges ( live-interval -- )
-    [ ranges>> ] [ uses>> first ] bi
+    [ ranges>> ] [ uses>> first n>> ] bi
     [ '[ to>> _ >= ] filter! drop ]
     [ swap first (>>from) ]
     2bi ;
@@ -66,7 +66,8 @@ ERROR: bad-live-ranges interval ;
     split-interval [ spill-before ] [ spill-after ] bi* ;
 
 : find-use-position ( live-interval new -- n )
-    [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
+    [ uses>> ] [ start>> '[ n>> _ >= ] ] bi* find nip
+    [ n>> ] [ 1/0. ] if* ;
 
 : find-use-positions ( live-intervals new assoc -- )
     '[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
@@ -88,7 +89,7 @@ ERROR: bad-live-ranges interval ;
     >alist alist-max ;
 
 : spill-new? ( new pair -- ? )
-    [ uses>> first ] [ second ] bi* > ;
+    [ uses>> first n>> ] [ second ] bi* > ;
 
 : spill-new ( new pair -- )
     drop spill-after add-unhandled ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
index 1a2b0f2f2b..b3cba3d90d 100644
--- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators fry hints kernel locals
 math sequences sets sorting splitting namespaces
@@ -25,7 +25,7 @@ IN: compiler.cfg.linear-scan.allocation.splitting
     ] bi ;
 
 : split-uses ( uses n -- before after )
-    '[ _ <= ] partition ;
+    '[ n>> _ <= ] partition ;
 
 ERROR: splitting-too-early ;
 
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index c79aa36af1..535f4515eb 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets locals arrays
+fry make combinators combinators.short-circuit sets locals arrays
 cpu.architecture layouts
 compiler.cfg
 compiler.cfg.def-use
@@ -91,8 +91,16 @@ SYMBOL: register-live-outs
 : insert-reload ( live-interval -- )
     [ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ;
 
+: insert-reload? ( live-interval -- ? )
+    ! Don't insert a reload if the register will be written to
+    ! before being read again.
+    {
+        [ reload-from>> ]
+        [ uses>> first type>> +use+ eq? ]
+    } 1&& ;
+
 : handle-reload ( live-interval -- )
-    dup reload-from>> [ insert-reload ] [ drop ] if ;
+    dup insert-reload? [ insert-reload ] [ drop ] if ;
 
 : activate-interval ( live-interval -- )
     [ add-pending ] [ handle-reload ] bi ;
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index b3fca6bab7..570c7f9aa7 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -91,7 +91,7 @@ H{
        { vreg 1 }
        { start 0 }
        { end 2 }
-       { uses V{ 0 1 } }
+       { uses V{ T{ vreg-use f 0 } T{ vreg-use f 1 } } }
        { ranges V{ T{ live-range f 0 2 } } }
        { spill-to T{ spill-slot f 0 } }
     }
@@ -99,7 +99,7 @@ H{
        { vreg 1 }
        { start 5 }
        { end 5 }
-       { uses V{ 5 } }
+       { uses V{ T{ vreg-use f 5 } } }
        { ranges V{ T{ live-range f 5 5 } } }
        { reload-from T{ spill-slot f 0 } }
     }
@@ -108,7 +108,7 @@ H{
        { vreg 1 }
        { start 0 }
        { end 5 }
-       { uses V{ 0 1 5 } }
+       { uses V{ T{ vreg-use f 0 } T{ vreg-use f 1 } T{ vreg-use f 5 } } }
        { ranges V{ T{ live-range f 0 5 } } }
     } 2 split-for-spill
 ] unit-test
@@ -118,7 +118,7 @@ H{
        { vreg 2 }
        { start 0 }
        { end 1 }
-       { uses V{ 0 } }
+       { uses V{ T{ vreg-use f 0 } } }
        { ranges V{ T{ live-range f 0 1 } } }
        { spill-to T{ spill-slot f 4 } }
     }
@@ -126,7 +126,7 @@ H{
        { vreg 2 }
        { start 1 }
        { end 5 }
-       { uses V{ 1 5 } }
+       { uses V{ T{ vreg-use f 1 } T{ vreg-use f 5 } } }
        { ranges V{ T{ live-range f 1 5 } } }
        { reload-from T{ spill-slot f 4 } }
     }
@@ -135,7 +135,7 @@ H{
        { vreg 2 }
        { start 0 }
        { end 5 }
-       { uses V{ 0 1 5 } }
+       { uses V{ T{ vreg-use f 0 } T{ vreg-use f 1 } T{ vreg-use f 5 } } }
        { ranges V{ T{ live-range f 0 5 } } }
     } 0 split-for-spill
 ] unit-test
@@ -145,7 +145,7 @@ H{
        { vreg 3 }
        { start 0 }
        { end 1 }
-       { uses V{ 0 } }
+       { uses V{ T{ vreg-use f 0 } } }
        { ranges V{ T{ live-range f 0 1 } } }
        { spill-to T{ spill-slot f 8 } }
     }
@@ -153,7 +153,7 @@ H{
        { vreg 3 }
        { start 20 }
        { end 30 }
-       { uses V{ 20 30 } }
+       { uses V{ T{ vreg-use f 20 } T{ vreg-use f 30 } } }
        { ranges V{ T{ live-range f 20 30 } } }
        { reload-from T{ spill-slot f 8 } }
     }
@@ -162,7 +162,7 @@ H{
        { vreg 3 }
        { start 0 }
        { end 30 }
-       { uses V{ 0 20 30 } }
+       { uses V{ T{ vreg-use f 0 } T{ vreg-use f 20 } T{ vreg-use f 30 } } }
        { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
     } 10 split-for-spill
 ] unit-test
@@ -187,21 +187,21 @@ H{
                  { reg 1 }
                  { start 1 }
                  { end 15 }
-                 { uses V{ 1 3 7 10 15 } }
+                 { uses V{ T{ vreg-use f 1 } T{ vreg-use f 3 } T{ vreg-use f 7 } T{ vreg-use f 10 } T{ vreg-use f 15 } } }
               }
               T{ live-interval
                  { vreg 2 }
                  { reg 2 }
                  { start 3 }
                  { end 8 }
-                 { uses V{ 3 4 8 } }
+                 { uses V{ T{ vreg-use f 3 } T{ vreg-use f 4 } T{ vreg-use f 8 } } }
               }
               T{ live-interval
                  { vreg 3 }
                  { reg 3 }
                  { start 3 }
                  { end 10 }
-                 { uses V{ 3 10 } }
+                 { uses V{ T{ vreg-use f 3 } T{ vreg-use f 10 } } }
               }
           }
         }
@@ -211,7 +211,7 @@ H{
         { vreg 1 }
         { start 5 }
         { end 5 }
-        { uses V{ 5 } }
+        { uses V{ T{ vreg-use f 5 } } }
     }
     spill-status
 ] unit-test
@@ -230,14 +230,14 @@ H{
                  { reg 1 }
                  { start 1 }
                  { end 15 }
-                 { uses V{ 1 } }
+                 { uses V{ T{ vreg-use f 1 } } }
               }
               T{ live-interval
                  { vreg 2 }
                  { reg 2 }
                  { start 3 }
                  { end 8 }
-                 { uses V{ 3 8 } }
+                 { uses V{ T{ vreg-use f 3 } T{ vreg-use f 8 } } }
               }
           }
         }
@@ -247,7 +247,7 @@ H{
         { vreg 3 }
         { start 5 }
         { end 5 }
-        { uses V{ 5 } }
+        { uses V{ T{ vreg-use f 5 } } }
     }
     spill-status
 ] unit-test
@@ -260,7 +260,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { vreg 1 }
            { start 0 }
            { end 100 }
-           { uses V{ 0 100 } }
+           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
            { ranges V{ T{ live-range f 0 100 } } }
         }
     }
@@ -274,14 +274,14 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { vreg 1 }
            { start 0 }
            { end 10 }
-           { uses V{ 0 10 } }
+           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 10 } } }
            { ranges V{ T{ live-range f 0 10 } } }
         }
         T{ live-interval
            { vreg 2 }
            { start 11 }
            { end 20 }
-           { uses V{ 11 20 } }
+           { uses V{ T{ vreg-use f 11 } T{ vreg-use f 20 } } }
            { ranges V{ T{ live-range f 11 20 } } }
         }
     }
@@ -295,14 +295,14 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { vreg 1 }
            { start 0 }
            { end 100 }
-           { uses V{ 0 100 } }
+           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
            { ranges V{ T{ live-range f 0 100 } } }
         }
         T{ live-interval
            { vreg 2 }
            { start 30 }
            { end 60 }
-           { uses V{ 30 60 } }
+           { uses V{ T{ vreg-use f 30 } T{ vreg-use f 60 } } }
            { ranges V{ T{ live-range f 30 60 } } }
         }
     }
@@ -316,14 +316,14 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { vreg 1 }
            { start 0 }
            { end 100 }
-           { uses V{ 0 100 } }
+           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
            { ranges V{ T{ live-range f 0 100 } } }
         }
         T{ live-interval
            { vreg 2 }
            { start 30 }
            { end 200 }
-           { uses V{ 30 200 } }
+           { uses V{ T{ vreg-use f 30 } T{ vreg-use f 200 } } }
            { ranges V{ T{ live-range f 30 200 } } }
         }
     }
@@ -337,14 +337,14 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { vreg 1 }
            { start 0 }
            { end 100 }
-           { uses V{ 0 100 } }
+           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
            { ranges V{ T{ live-range f 0 100 } } }
         }
         T{ live-interval
            { vreg 2 }
            { start 30 }
            { end 100 }
-           { uses V{ 30 100 } }
+           { uses V{ T{ vreg-use f 30 } T{ vreg-use f 100 } } }
            { ranges V{ T{ live-range f 30 100 } } }
         }
     }
@@ -367,28 +367,28 @@ H{
            { vreg 1 }
            { start 0 }
            { end 20 }
-           { uses V{ 0 10 20 } }
+           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 10 } T{ vreg-use f 20 } } }
            { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
         }
         T{ live-interval
            { vreg 2 }
            { start 0 }
            { end 20 }
-           { uses V{ 0 10 20 } }
+           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 10 } T{ vreg-use f 20 } } }
            { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
         }
         T{ live-interval
            { vreg 3 }
            { start 4 }
            { end 8 }
-           { uses V{ 6 } }
+           { uses V{ T{ vreg-use f 6 } } }
            { ranges V{ T{ live-range f 4 8 } } }
         }
         T{ live-interval
            { vreg 4 }
            { start 4 }
            { end 8 }
-           { uses V{ 8 } }
+           { uses V{ T{ vreg-use f 8 } } }
            { ranges V{ T{ live-range f 4 8 } } }
         }
 
@@ -397,7 +397,7 @@ H{
            { vreg 5 }
            { start 4 }
            { end 8 }
-           { uses V{ 8 } }
+           { uses V{ T{ vreg-use f 8 } } }
            { ranges V{ T{ live-range f 4 8 } } }
         }
     }
@@ -413,7 +413,7 @@ H{
            { vreg 1 }
            { start 0 }
            { end 10 }
-           { uses V{ 0 6 10 } }
+           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 6 } T{ vreg-use f 10 } } }
            { ranges V{ T{ live-range f 0 10 } } }
         }
 
@@ -422,7 +422,7 @@ H{
            { vreg 5 }
            { start 2 }
            { end 8 }
-           { uses V{ 8 } }
+           { uses V{ T{ vreg-use f 8 } } }
            { ranges V{ T{ live-range f 2 8 } } }
         }
     }
@@ -558,7 +558,7 @@ H{
         { start 8 }
         { end 10 }
         { ranges V{ T{ live-range f 8 10 } } }
-        { uses V{ 8 10 } }
+        { uses V{ T{ vreg-use f 8 } T{ vreg-use f 10 } } }
     }
     register-status
 ] unit-test
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index 00d6f73517..221832e41a 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel assocs accessors sequences math math.order fry
 combinators binary-search compiler.cfg.instructions compiler.cfg.registers
@@ -10,6 +10,12 @@ TUPLE: live-range from to ;
 
 C: <live-range> live-range
 
+SYMBOLS: +def+ +use+ +memory+ ;
+
+TUPLE: vreg-use n type ;
+
+C: <vreg-use> vreg-use
+
 TUPLE: live-interval
 vreg
 reg spill-to reload-from
@@ -50,18 +56,11 @@ M: live-interval covers? ( insn# live-interval -- ? )
     2dup extend-range?
     [ extend-range ] [ add-new-range ] if ;
 
-GENERIC: operands-in-registers? ( insn -- ? )
-
-M: vreg-insn operands-in-registers? drop t ;
-
-M: partial-sync-insn operands-in-registers? drop f ;
-
-: add-def ( insn live-interval -- )
-    [ insn#>> ] [ uses>> ] bi* push ;
-
-: add-use ( insn live-interval -- )
-    ! Every use is a potential def, no SSA here baby!
-    over operands-in-registers? [ add-def ] [ 2drop ] if ;
+: add-use ( insn live-interval type -- )
+    dup +memory+ eq? [ 3drop ] [
+        swap [ [ insn#>> ] dip <vreg-use> ] dip
+        uses>> push
+    ] if ;
 
 : <live-interval> ( vreg -- live-interval )
     \ live-interval new
@@ -73,9 +72,6 @@ M: partial-sync-insn operands-in-registers? drop f ;
 
 : block-to ( bb -- n ) instructions>> last insn#>> ;
 
-M: live-interval hashcode*
-    nip [ start>> ] [ end>> 1000 * ] bi + ;
-
 ! Mapping from vreg to live-interval
 SYMBOL: live-intervals
 
@@ -86,21 +82,29 @@ GENERIC: compute-live-intervals* ( insn -- )
 
 M: insn compute-live-intervals* drop ;
 
-: handle-output ( insn vreg -- )
-    live-interval
-    [ [ insn#>> ] dip shorten-range ] [ add-def ] 2bi ;
+: handle-output ( insn vreg type -- )
+    [ live-interval ] dip
+    [ drop [ insn#>> ] dip shorten-range ] [ add-use ] 3bi ;
 
-: handle-input ( insn vreg -- )
-    live-interval
-    [ [ [ basic-block get block-from ] dip insn#>> ] dip add-range ] [ add-use ] 2bi ;
+: handle-input ( insn vreg type -- )
+    [ live-interval ] dip
+    [ drop [ [ basic-block get block-from ] dip insn#>> ] dip add-range ]
+    [ add-use ]
+    3bi ;
 
 : handle-temp ( insn vreg -- )
     live-interval
-    [ [ insn#>> dup ] dip add-range ] [ add-use ] 2bi ;
+    [ [ insn#>> dup ] dip add-range ] [ +def+ add-use ] 2bi ;
 
 M: vreg-insn compute-live-intervals*
-    [ dup defs-vreg [ handle-output ] with when* ]
-    [ dup uses-vregs [ handle-input ] with each ]
+    [ dup defs-vreg [ +def+ handle-output ] with when* ]
+    [ dup uses-vregs [ +use+ handle-input ] with each ]
+    [ dup temp-vregs [ handle-temp ] with each ]
+    tri ;
+
+M: partial-sync-insn compute-live-intervals*
+    [ dup defs-vreg [ +use+ handle-output ] with when* ]
+    [ dup uses-vregs [ +memory+ handle-input ] with each ]
     [ dup temp-vregs [ handle-temp ] with each ]
     tri ;
 

From db7403d697fdf89488c28517393bceb0cacd1375 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 Apr 2010 05:37:48 -0400
Subject: [PATCH 129/158] compiler.cfg.linear-scan.resolve: fix incorrect
 behavior when one physical register is used with several representations in
 the same register class

---
 .../linear-scan/resolve/resolve-tests.factor  | 74 +++++++++++++++++--
 .../cfg/linear-scan/resolve/resolve.factor    | 35 ++++++---
 2 files changed, 92 insertions(+), 17 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index e7f291d613..893a60b267 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -7,7 +7,10 @@ IN: compiler.cfg.linear-scan.resolve.tests
 
 [
     {
-        { { T{ spill-slot f 0 } int-rep } { 1 int-rep } }
+        {
+            T{ location f T{ spill-slot f 0 } int-rep int-regs }
+            T{ location f 1 int-rep int-regs }
+        }
     }
 ] [
     [
@@ -21,7 +24,9 @@ IN: compiler.cfg.linear-scan.resolve.tests
     }
 ] [
     [
-        { T{ spill-slot f 0 } int-rep } { 1 int-rep } >insn
+        T{ location f T{ spill-slot f 0 } int-rep int-regs }
+        T{ location f 1 int-rep int-regs }
+        >insn
     ] { } make
 ] unit-test
 
@@ -31,7 +36,9 @@ IN: compiler.cfg.linear-scan.resolve.tests
     }
 ] [
     [
-        { 1 int-rep } { T{ spill-slot f 0 } int-rep } >insn
+        T{ location f 1 int-rep int-regs }
+        T{ location f T{ spill-slot f 0 } int-rep int-regs }
+        >insn
     ] { } make
 ] unit-test
 
@@ -41,17 +48,68 @@ IN: compiler.cfg.linear-scan.resolve.tests
     }
 ] [
     [
-        { 1 int-rep } { 2 int-rep } >insn
+        T{ location f 1 int-rep int-regs }
+        T{ location f 2 int-rep int-regs }
+        >insn
     ] { } make
 ] unit-test
 
+[
+    {
+        T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
+    }
+] [
+    { { T{ location f 1 int-rep int-regs } T{ location f 2 int-rep int-regs } } }
+    mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 0 } } }
+        T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 1 } } }
+    }
+] [
+    {
+        { T{ location f T{ spill-slot f 1 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+        { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 0 } int-rep int-regs } }
+    }
+    mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
+        T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+    }
+] [
+    {
+        { T{ location f T{ spill-slot f 0 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+        { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 1 } int-rep int-regs } }
+    }
+    mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
+        T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+    }
+] [
+    {
+        { T{ location f 0 int-rep int-regs } T{ location f T{ spill-slot f 1 } int-rep int-regs } }
+        { T{ location f T{ spill-slot f 0 } tagged-rep int-regs } T{ location f 0 tagged-rep int-regs } }
+    }
+    mapping-instructions
+] unit-test
+
 cfg new 8 >>spill-area-size cfg set
 H{ } clone spill-temps set
 
-[
-    t
-] [
-    { { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } }
+[ t ] [
+    {
+        { T{ location f 0 int-rep int-regs } T{ location f 1 int-rep int-regs } }
+        { T{ location f 1 int-rep int-regs } T{ location f 0 int-rep int-regs } }
+    }
     mapping-instructions {
         {
             T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index 20c9ee4e99..f64c0fc890 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -1,8 +1,9 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators
 combinators.short-circuit fry kernel locals namespaces
 make math sequences hashtables
+cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.liveness
@@ -15,13 +16,29 @@ compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.allocation.state ;
 IN: compiler.cfg.linear-scan.resolve
 
+TUPLE: location
+{ reg read-only }
+{ rep read-only }
+{ reg-class read-only } ;
+
+: <location> ( reg rep -- location )
+    dup reg-class-of location boa ;
+
+M: location equal?
+    over location? [
+        { [ [ reg>> ] bi@ = ] [ [ reg-class>> ] bi@ = ] } 2&&
+    ] [ 2drop f ] if ;
+
+M: location hashcode*
+    reg>> hashcode* ;
+
 SYMBOL: spill-temps
 
 : spill-temp ( rep -- n )
     spill-temps get [ next-spill-slot ] cache ;
 
 : add-mapping ( from to rep -- )
-    '[ _ 2array ] bi@ 2array , ;
+    '[ _ <location> ] bi@ 2array , ;
 
 :: resolve-value-data-flow ( bb to vreg -- )
     vreg bb vreg-at-end
@@ -34,19 +51,19 @@ SYMBOL: spill-temps
     ] if ;
 
 : memory->register ( from to -- )
-    swap [ first2 ] [ first ] bi* _reload ;
+    swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* _reload ;
 
 : register->memory ( from to -- )
-    [ first2 ] [ first ] bi* _spill ;
+    [ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* _spill ;
 
 : temp->register ( from to -- )
-    nip [ first ] [ second ] [ second spill-temp ] tri _reload ;
+    nip [ reg>> ] [ rep>> ] [ rep>> spill-temp ] tri _reload ;
 
 : register->temp ( from to -- )
-    drop [ first2 ] [ second spill-temp ] bi _spill ;
+    drop [ [ reg>> ] [ rep>> ] bi ] [ rep>> spill-temp ] bi _spill ;
 
 : register->register ( from to -- )
-    swap [ first ] [ first2 ] bi* ##copy ;
+    swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy ;
 
 SYMBOL: temp
 
@@ -54,8 +71,8 @@ SYMBOL: temp
     {
         { [ over temp eq? ] [ temp->register ] }
         { [ dup temp eq? ] [ register->temp ] }
-        { [ over first spill-slot? ] [ memory->register ] }
-        { [ dup first spill-slot? ] [ register->memory ] }
+        { [ over reg>> spill-slot? ] [ memory->register ] }
+        { [ dup reg>> spill-slot? ] [ register->memory ] }
         [ register->register ]
     } cond ;
 

From 9c44dddf97e016364b25b4c37a7dc373cd65cae9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 Apr 2010 05:37:57 -0400
Subject: [PATCH 130/158] compiler.codegen: cleanup

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

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 63571e7874..bae2fdcf6c 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -202,6 +202,7 @@ CODEGEN: ##compare-float-unordered %compare-float-unordered
 CODEGEN: ##save-context %save-context
 CODEGEN: ##vm-field %vm-field
 CODEGEN: ##set-vm-field %set-vm-field
+CODEGEN: ##alien-global %alien-global
 
 CODEGEN: _fixnum-add %fixnum-add
 CODEGEN: _fixnum-sub %fixnum-sub
@@ -216,6 +217,7 @@ CODEGEN: _test-vector-branch %test-vector-branch
 CODEGEN: _dispatch %dispatch
 CODEGEN: _spill %spill
 CODEGEN: _reload %reload
+CODEGEN: _loop-entry %loop-entry
 
 ! ##gc
 : wipe-locs ( locs temp -- )
@@ -263,12 +265,6 @@ M: ##gc generate-insn
     } cleave
     "no-gc" resolve-label ;
 
-M: _loop-entry generate-insn drop %loop-entry ;
-
-M: ##alien-global generate-insn
-    [ dst>> ] [ symbol>> ] [ library>> ] tri
-    %alien-global ;
-
 ! ##alien-invoke
 GENERIC: next-fastcall-param ( rep -- )
 

From 4d749c9dfe8b21c89484a7035034d55265cfe2ad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 Apr 2010 05:38:14 -0400
Subject: [PATCH 131/158] compiler.tree.propagation: fix tests

---
 basis/compiler/tree/propagation/propagation-tests.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index d1a1dd18a6..17701e94c1 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -8,7 +8,8 @@ layouts compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker slots.private words
 hashtables classes assocs locals specialized-arrays system
 sorting math.libm math.floats.private math.integers.private
-math.intervals quotations effects alien alien.data sets ;
+math.intervals quotations effects alien alien.data sets
+strings.private ;
 FROM: math => float ;
 SPECIALIZED-ARRAY: double
 SPECIALIZED-ARRAY: void*

From 655497b7b47438a530e6d23d59885ad3e588d88d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 26 Apr 2010 16:38:02 -0400
Subject: [PATCH 132/158] cpu.x86.assembler: small cleanups

---
 .../cpu/x86/assembler/assembler-tests.factor  |  22 +--
 basis/cpu/x86/assembler/assembler.factor      | 147 +++++++++---------
 2 files changed, 84 insertions(+), 85 deletions(-)

diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor
index 83186a7f24..7312a16f83 100644
--- a/basis/cpu/x86/assembler/assembler-tests.factor
+++ b/basis/cpu/x86/assembler/assembler-tests.factor
@@ -2,6 +2,13 @@ USING: cpu.x86.assembler cpu.x86.assembler.operands
 kernel tools.test namespaces make layouts ;
 IN: cpu.x86.assembler.tests
 
+! immediate operands
+[ { HEX: b9 HEX: 01 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 1 MOV ] { } make ] unit-test
+[ { HEX: 83 HEX: c1 HEX: 01 } ] [ [ ECX 1 ADD ] { } make ] unit-test
+[ { HEX: 81 HEX: c1 HEX: 96 HEX: 00 HEX: 00 HEX: 00 } ] [ [ ECX 150 ADD ] { } make ] unit-test
+[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
+
+! 64-bit registers
 [ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test
 
 [ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
@@ -100,13 +107,6 @@ IN: cpu.x86.assembler.tests
 [ { HEX: f2 HEX: 48 HEX: 0f HEX: 2a HEX: c0 } ] [ [ XMM0 RAX CVTSI2SD ] { } make ] unit-test
 [ { HEX: f2 HEX: 49 HEX: 0f HEX: 2a HEX: c4 } ] [ [ XMM0 R12 CVTSI2SD ] { } make ] unit-test
 
-! [ { HEX: f2 HEX: 49 HEX: 0f HEX: 2c HEX: c1 } ] [ [ XMM9 RAX CVTSI2SD ] { } make ] unit-test
-
-! [ { HEX: f2 HEX: 0f HEX: 10 HEX: 00 } ] [ [ XMM0 RAX [] MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 10 HEX: 04 HEX: 24 } ] [ [ XMM0 R12 [] MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 0f HEX: 11 HEX: 00 } ] [ [ RAX [] XMM0 MOVSD ] { } make ] unit-test
-! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 11 HEX: 04 HEX: 24 } ] [ [ R12 [] XMM0 MOVSD ] { } make ] unit-test
-
 ! 3-operand r-rm-imm sse instructions
 [ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ]
 [ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test
@@ -167,14 +167,18 @@ IN: cpu.x86.assembler.tests
 [ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: c1 } ] [ [ EAX ECX CRC32 ] { } make ] unit-test
 [ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: 01 } ] [ [ EAX ECX [] CRC32 ] { } make ] unit-test
 
-! various oddities
+! shifts
 [ { HEX: 48 HEX: d3 HEX: e0 } ] [ [ RAX CL SHL ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
 [ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
 
-[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
+[ { HEX: c1 HEX: e0 HEX: 05 } ] [ [ EAX 5 SHL ] { } make ] unit-test
+[ { HEX: c1 HEX: e1 HEX: 05 } ] [ [ ECX 5 SHL ] { } make ] unit-test
+[ { HEX: c1 HEX: e8 HEX: 05 } ] [ [ EAX 5 SHR ] { } make ] unit-test
+[ { HEX: c1 HEX: e9 HEX: 05 } ] [ [ ECX 5 SHR ] { } make ] unit-test
 
+! multiplication
 [ { HEX: 4d HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 R8 3 IMUL3 ] { } make ] unit-test
 [ { HEX: 49 HEX: 6b HEX: c0 HEX: 03 } ] [ [ RAX R8 3 IMUL3 ] { } make ] unit-test
 [ { HEX: 4c HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 RAX 3 IMUL3 ] { } make ] unit-test
diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor
index b91083dad1..059be328f2 100644
--- a/basis/cpu/x86/assembler/assembler.factor
+++ b/basis/cpu/x86/assembler/assembler.factor
@@ -4,7 +4,6 @@ USING: arrays io.binary kernel combinators
 combinators.short-circuit math math.bitwise locals namespaces
 make sequences words system layouts math.order accessors
 cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
-QUALIFIED: sequences
 IN: cpu.x86.assembler
 
 ! A postfix assembler for x86-32 and x86-64.
@@ -71,10 +70,10 @@ M: byte n, [ value>> ] dip n, ;
 : 2, ( n -- ) 2 n, ; inline
 : cell, ( n -- ) bootstrap-cell n, ; inline
 
-: mod-r/m, ( reg# indirect -- )
+: mod-r/m, ( reg operand -- )
     [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
 
-: sib, ( indirect -- )
+: sib, ( operand -- )
     dup sib-present? [
         [ indirect-base* ]
         [ indirect-index* 3 shift ]
@@ -93,14 +92,14 @@ M: indirect displacement,
 
 M: register displacement, drop ;
 
-: addressing ( reg# indirect -- )
+: addressing ( reg operand -- )
     [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
 
 : rex.w? ( rex.w reg r/m -- ? )
     {
-        { [ dup register-128? ] [ drop operand-64? ] }
-        { [ dup not ] [ drop operand-64? ] }
-        [ nip operand-64? ]
+        { [ over register-128? ] [ nip operand-64? ] }
+        { [ over not ] [ nip operand-64? ] }
+        [ drop operand-64? ]
     } cond and ;
 
 : rex.r ( m op -- n )
@@ -119,16 +118,15 @@ M: register displacement, drop ;
 :: rex-prefix ( reg r/m rex.w -- )
     #! Compile an AMD64 REX prefix.
     rex.w reg r/m rex.w? BIN: 01001000 BIN: 01000000 ?
-    r/m rex.r
-    reg rex.b
+    reg rex.r
+    r/m rex.b
     dup reg r/m no-prefix? [ drop ] [ , ] if ;
 
-: 16-prefix ( reg r/m -- )
-    [ register-16? ] either? [ HEX: 66 , ] when ;
+: 16-prefix ( reg -- )
+    register-16? [ HEX: 66 , ] when ;
 
-: prefix ( reg r/m rex.w -- ) [ drop 16-prefix ] [ rex-prefix ] 3bi ;
-
-: prefix-1 ( reg rex.w -- ) f swap prefix ;
+: prefix-1 ( reg rex.w -- )
+    [ drop 16-prefix ] [ [ f ] 2dip rex-prefix ] 2bi ;
 
 : short-operand ( reg rex.w n -- )
     #! Some instructions encode their single operand as part of
@@ -138,57 +136,57 @@ M: register displacement, drop ;
 : opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
 
 : extended-opcode ( opcode -- opcode' )
-    dup array? [ OCT: 17 sequences:prefix ] [ OCT: 17 swap 2array ] if ;
+    dup array? [ OCT: 17 prefix ] [ OCT: 17 swap 2array ] if ;
 
 : extended-opcode, ( opcode -- ) extended-opcode opcode, ;
 
 : opcode-or ( opcode mask -- opcode' )
-    swap dup array?
-    [ unclip-last rot bitor suffix ] [ bitor ] if ;
+    over array?
+    [ [ unclip-last ] dip bitor suffix ] [ bitor ] if ;
 
-: 1-operand ( op reg,rex.w,opcode -- )
+: 1-operand ( operand reg,rex.w,opcode -- )
     #! The 'reg' is not really a register, but a value for the
     #! 'reg' field of the mod-r/m byte.
     first3 [ [ over ] dip prefix-1 ] dip opcode, swap addressing ;
 
-: immediate-operand-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
-    pick integer? [ first3 BIN: 1 opcode-or 3array ] when ;
+: immediate-operand-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+    over integer? [ first3 BIN: 1 opcode-or 3array ] when ;
 
-: immediate-1 ( imm dst reg,rex.w,opcode -- )
-    immediate-operand-size-bit 1-operand 1, ;
+: immediate-1 ( dst imm reg,rex.w,opcode -- )
+    immediate-operand-size-bit swap [ 1-operand ] dip 1, ;
 
-: immediate-4 ( imm dst reg,rex.w,opcode -- )
-    immediate-operand-size-bit 1-operand 4, ;
+: immediate-4 ( dst imm reg,rex.w,opcode -- )
+    immediate-operand-size-bit swap [ 1-operand ] dip 4, ;
 
-: immediate-fits-in-size-bit ( imm dst reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
-    pick integer? [ first3 BIN: 10 opcode-or 3array ] when ;
+: immediate-fits-in-size-bit ( dst imm reg,rex.w,opcode -- imm dst reg,rex.w,opcode )
+    over integer? [ first3 BIN: 10 opcode-or 3array ] when ;
 
-: immediate-1/4 ( imm dst reg,rex.w,opcode -- )
+: immediate-1/4 ( dst imm reg,rex.w,opcode -- )
     #! If imm is a byte, compile the opcode and the byte.
     #! Otherwise, set the 8-bit operand flag in the opcode, and
     #! compile the cell. The 'reg' is not really a register, but
     #! a value for the 'reg' field of the mod-r/m byte.
-    pick fits-in-byte? [
+    over fits-in-byte? [
         immediate-fits-in-size-bit immediate-1
     ] [
         immediate-4
     ] if ;
 
-: (2-operand) ( dst src op -- )
+: (2-operand) ( reg operand op -- )
     [ 2dup t rex-prefix ] dip opcode,
-    reg-code swap addressing ;
+    [ reg-code ] dip addressing ;
 
-: direction-bit ( dst src op -- dst' src' op' )
+: direction-bit ( dst src op -- reg operand op' )
     pick register? pick register? not and
-    [ BIN: 10 opcode-or swapd ] when ;
+    [ BIN: 10 opcode-or ] [ swapd ] if ;
 
-: operand-size-bit ( dst src op -- dst' src' op' )
-    over register-8? [ BIN: 1 opcode-or ] unless ;
+: operand-size-bit ( reg operand op -- reg operand op' )
+    pick register-8? [ BIN: 1 opcode-or ] unless ;
 
 : 2-operand ( dst src op -- )
-    #! Sets the opcode's direction bit. It is set if the
-    #! destination is a direct register operand.
-    [ drop 16-prefix ] [ direction-bit operand-size-bit (2-operand) ] 3bi ;
+    direction-bit operand-size-bit
+    pick 16-prefix
+    (2-operand) ;
 
 PRIVATE>
 
@@ -212,16 +210,16 @@ M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
 ! MOV where the src is immediate.
 <PRIVATE
 
-GENERIC: (MOV-I) ( src dst -- )
-M: register (MOV-I) t HEX: b8 short-operand cell, ;
+GENERIC# (MOV-I) 1 ( dst src -- )
+M: register (MOV-I) [ t HEX: b8 short-operand ] [ cell, ] bi* ;
 M: operand (MOV-I)
     { BIN: 000 t HEX: c6 }
-    pick byte? [ immediate-1 ] [ immediate-4 ] if ;
+    over byte? [ immediate-1 ] [ immediate-4 ] if ;
 
 PRIVATE>
 
 GENERIC: MOV ( dst src -- )
-M: immediate MOV swap (MOV-I) ;
+M: immediate MOV (MOV-I) ;
 M: operand MOV HEX: 88 2-operand ;
 
 : LEA ( dst src -- ) swap HEX: 8d 2-operand ;
@@ -267,44 +265,44 @@ PRIVATE>
 ! Arithmetic
 
 GENERIC: ADD ( dst src -- )
-M: immediate ADD swap { BIN: 000 t HEX: 80 } immediate-1/4 ;
+M: immediate ADD { BIN: 000 t HEX: 80 } immediate-1/4 ;
 M: operand ADD OCT: 000 2-operand ;
 
 GENERIC: OR ( dst src -- )
-M: immediate OR swap { BIN: 001 t HEX: 80 } immediate-1/4 ;
+M: immediate OR { BIN: 001 t HEX: 80 } immediate-1/4 ;
 M: operand OR OCT: 010 2-operand ;
 
 GENERIC: ADC ( dst src -- )
-M: immediate ADC swap { BIN: 010 t HEX: 80 } immediate-1/4 ;
+M: immediate ADC { BIN: 010 t HEX: 80 } immediate-1/4 ;
 M: operand ADC OCT: 020 2-operand ;
 
 GENERIC: SBB ( dst src -- )
-M: immediate SBB swap { BIN: 011 t HEX: 80 } immediate-1/4 ;
+M: immediate SBB { BIN: 011 t HEX: 80 } immediate-1/4 ;
 M: operand SBB OCT: 030 2-operand ;
 
 GENERIC: AND ( dst src -- )
-M: immediate AND swap { BIN: 100 t HEX: 80 } immediate-1/4 ;
+M: immediate AND { BIN: 100 t HEX: 80 } immediate-1/4 ;
 M: operand AND OCT: 040 2-operand ;
 
 GENERIC: SUB ( dst src -- )
-M: immediate SUB swap { BIN: 101 t HEX: 80 } immediate-1/4 ;
+M: immediate SUB { BIN: 101 t HEX: 80 } immediate-1/4 ;
 M: operand SUB OCT: 050 2-operand ;
 
 GENERIC: XOR ( dst src -- )
-M: immediate XOR swap { BIN: 110 t HEX: 80 } immediate-1/4 ;
+M: immediate XOR { BIN: 110 t HEX: 80 } immediate-1/4 ;
 M: operand XOR OCT: 060 2-operand ;
 
 GENERIC: CMP ( dst src -- )
-M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
+M: immediate CMP { BIN: 111 t HEX: 80 } immediate-1/4 ;
 M: operand CMP OCT: 070 2-operand ;
 
 GENERIC: TEST ( dst src -- )
-M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ;
+M: immediate TEST { BIN: 0 t HEX: f7 } immediate-4 ;
 M: operand TEST OCT: 204 2-operand ;
 
 : XCHG ( dst src -- ) OCT: 207 2-operand ;
 
-: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
+: BSR ( dst src -- ) { HEX: 0f HEX: bd } (2-operand) ;
 
 : NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
 : NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
@@ -318,11 +316,11 @@ M: operand TEST OCT: 204 2-operand ;
 
 <PRIVATE
 
-: (SHIFT) ( dst src op -- )
-    over CL eq? [
-        nip t HEX: d3 3array 1-operand
+:: (SHIFT) ( dst src op -- )
+    src CL eq? [
+        dst { op t HEX: d3 } 1-operand
     ] [
-        swapd t HEX: c0 3array immediate-1
+        dst src { op t HEX: c0 } immediate-1
     ] if ; inline
 
 PRIVATE>
@@ -336,7 +334,7 @@ PRIVATE>
 : SAR ( dst n -- ) BIN: 111 (SHIFT) ;
 
 : IMUL2 ( dst src -- )
-    OCT: 257 extended-opcode (2-operand) ;
+    swap OCT: 257 extended-opcode (2-operand) ;
 
 : IMUL3 ( dst src imm -- )
     dup fits-in-byte? [
@@ -346,19 +344,17 @@ PRIVATE>
     ] if ;
 
 : MOVSX ( dst src -- )
-    swap
-    over register-32? OCT: 143 OCT: 276 extended-opcode ?
-    pick register-16? [ BIN: 1 opcode-or ] when
+    dup register-32? OCT: 143 OCT: 276 extended-opcode ?
+    over register-16? [ BIN: 1 opcode-or ] when
     (2-operand) ;
 
 : MOVZX ( dst src -- )
-    swap
     OCT: 266 extended-opcode
-    pick register-16? [ BIN: 1 opcode-or ] when
+    over register-16? [ BIN: 1 opcode-or ] when
     (2-operand) ;
 
 ! Conditional move
-: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
+: MOVcc ( dst src cc -- ) extended-opcode (2-operand) ;
 
 : CMOVO  ( dst src -- ) HEX: 40 MOVcc ;
 : CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
@@ -409,34 +405,34 @@ PRIVATE>
 <PRIVATE
 
 : direction-bit-sse ( dst src op1 -- dst' src' op1' )
-    pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
+    pick register-128? [ swapd BIN: 1 bitor ] unless ;
 
 : 2-operand-sse ( dst src op1 op2 -- )
     [ , ] when* direction-bit-sse extended-opcode (2-operand) ;
 
 : direction-op-sse ( dst src op1s -- dst' src' op1' )
-    pick register-128? [ swapd first ] [ second ] if ;
+    pick register-128? [ first ] [ swapd second ] if ;
 
 : 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- )
     [ , ] when* direction-op-sse extended-opcode (2-operand) ;
 
 : 2-operand-rm-sse ( dst src op1 op2 -- )
-    [ , ] when* swapd extended-opcode (2-operand) ;
-
-: 2-operand-mr-sse ( dst src op1 op2 -- )
     [ , ] when* extended-opcode (2-operand) ;
 
+: 2-operand-mr-sse ( dst src op1 op2 -- )
+    [ , ] when* extended-opcode swapd (2-operand) ;
+
 : 2-operand-int/sse ( dst src op1 op2 -- )
-    [ , ] when* swapd extended-opcode (2-operand) ;
+    [ , ] when* extended-opcode (2-operand) ;
 
-: 3-operand-rm-sse ( dst src imm op1 op2 -- )
-    rot [ 2-operand-rm-sse ] dip , ;
+:: 3-operand-rm-sse ( dst src imm op1 op2 -- )
+    dst src op1 op2 2-operand-rm-sse imm , ;
 
-: 3-operand-mr-sse ( dst src imm op1 op2 -- )
-    rot [ 2-operand-mr-sse ] dip , ;
+:: 3-operand-mr-sse ( dst src imm op1 op2 -- )
+    dst src op1 op2 2-operand-mr-sse imm , ;
 
-: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- )
-    rot [ 2-operand-rm-mr-sse ] dip , ;
+:: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- )
+    dst src op1 op2 2-operand-rm-mr-sse imm , ;
 
 : 2-operand-sse-cmp ( dst src cmp op1 op2 -- )
     3-operand-rm-sse ; inline
@@ -739,7 +735,7 @@ PRIVATE>
 : CMPNLESS   ( dest src -- ) 6 HEX: c2 HEX: f3 2-operand-sse-cmp ;
 : CMPORDSS   ( dest src -- ) 7 HEX: c2 HEX: f3 2-operand-sse-cmp ;
 
-: MOVNTI     ( dest src -- ) { HEX: 0f HEX: c3 } (2-operand) ;
+: MOVNTI     ( dest src -- ) swap { HEX: 0f HEX: c3 } (2-operand) ;
 
 : PINSRW     ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-rm-sse ;
 : SHUFPS     ( dest src imm -- ) 4shuffler HEX: c6 f       3-operand-rm-sse ;
@@ -793,4 +789,3 @@ PRIVATE>
 
 : HWNT ( -- ) HEX: 2e , ; ! Hint branch Weakly Not Taken
 : HST  ( -- ) HEX: 3e , ; ! Hint branch Strongly Taken
-

From 95ff5ffe512d86e43c3a9918fd3aad43af6388e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 27 Apr 2010 10:51:00 -0400
Subject: [PATCH 133/158] New GC checks work in progress

---
 .../build-stack-frame.factor                  |   9 +-
 basis/compiler/cfg/cfg.factor                 |   5 +-
 basis/compiler/cfg/checker/checker.factor     |  10 +-
 .../cfg/comparisons/comparisons.factor        |   6 +-
 basis/compiler/cfg/def-use/def-use.factor     |   8 +-
 .../cfg/gc-checks/gc-checks-tests.factor      | 159 +++++++++++++++++-
 basis/compiler/cfg/gc-checks/gc-checks.factor |  91 ++++++++--
 .../cfg/instructions/instructions.factor      |  81 ++++-----
 .../cfg/intrinsics/fixnum/fixnum.factor       |   3 +-
 .../linear-scan/allocation/allocation.factor  |  21 +--
 .../linear-scan/assignment/assignment.factor  |  34 +---
 .../cfg/linear-scan/linear-scan-tests.factor  |  46 -----
 .../live-intervals/live-intervals.factor      |   4 +-
 .../linear-scan/resolve/resolve-tests.factor  |   6 +
 .../cfg/linear-scan/resolve/resolve.factor    |   4 +-
 .../cfg/linearization/linearization.factor    |  85 +++-------
 .../cfg/linearization/order/order.factor      |   9 +-
 basis/compiler/cfg/liveness/ssa/ssa.factor    |   6 +-
 basis/compiler/cfg/mr/mr.factor               |   5 +-
 basis/compiler/cfg/optimizer/optimizer.factor |   6 +-
 .../cfg/save-contexts/save-contexts.factor    |   1 +
 .../cfg/ssa/destruction/destruction.factor    |  29 ++--
 .../interference/interference-tests.factor    |   2 +-
 .../cfg/stack-frame/stack-frame.factor        |  16 +-
 .../cfg/stacks/finalize/finalize.factor       |   4 +-
 basis/compiler/cfg/utilities/utilities.factor |  32 ++--
 basis/compiler/codegen/codegen.factor         |  88 ++++------
 basis/cpu/architecture/architecture.factor    |  12 +-
 basis/cpu/x86/32/32.factor                    |   9 +-
 basis/cpu/x86/64/64.factor                    |  11 +-
 basis/cpu/x86/assembler/assembler.factor      |   2 +-
 basis/cpu/x86/bootstrap.factor                |   2 +-
 basis/cpu/x86/x86.factor                      |  49 +++---
 vm/gc.cpp                                     |  30 +++-
 vm/gc.hpp                                     |   2 +-
 vm/vm.hpp                                     |   2 +-
 36 files changed, 478 insertions(+), 411 deletions(-)

diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
index 670e34e5f9..cb5e9aaf3d 100644
--- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
+++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
@@ -25,12 +25,10 @@ M: stack-frame-insn compute-stack-frame*
 
 M: ##call compute-stack-frame* drop frame-required? on ;
 
-M: ##gc compute-stack-frame*
+M: ##call-gc compute-stack-frame*
+    drop
     frame-required? on
-    stack-frame new
-        swap tagged-values>> length cells >>gc-root-size
-        t >>calls-vm?
-    request-stack-frame ;
+    stack-frame new t >>calls-vm? request-stack-frame ;
 
 M: _spill-area-size compute-stack-frame*
     n>> stack-frame get (>>spill-area-size) ;
@@ -40,6 +38,7 @@ M: insn compute-stack-frame*
         frame-required? on
     ] when ;
 
+! PowerPC backend sets frame-required? for ##integer>float!
 \ _spill t frame-required? set-word-prop
 \ ##unary-float-function t frame-required? set-word-prop
 \ ##binary-float-function t frame-required? set-word-prop
diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 79f3b0d1fb..9568217e9c 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math vectors arrays accessors namespaces ;
 IN: compiler.cfg
@@ -8,7 +8,8 @@ TUPLE: basic-block < identity-tuple
 number
 { instructions vector }
 { successors vector }
-{ predecessors vector } ;
+{ predecessors vector }
+{ unlikely? boolean } ;
 
 : <basic-block> ( -- bb )
     basic-block new
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index 1a0265b42a..cb840a299d 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -25,15 +25,7 @@ ERROR: last-insn-not-a-jump bb ;
     dup instructions>> last {
         [ ##branch? ]
         [ ##dispatch? ]
-        [ ##compare-branch? ]
-        [ ##compare-imm-branch? ]
-        [ ##compare-integer-branch? ]
-        [ ##compare-integer-imm-branch? ]
-        [ ##compare-float-ordered-branch? ]
-        [ ##compare-float-unordered-branch? ]
-        [ ##fixnum-add? ]
-        [ ##fixnum-sub? ]
-        [ ##fixnum-mul? ]
+        [ conditional-branch-insn? ]
         [ ##no-tco? ]
     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
 
diff --git a/basis/compiler/cfg/comparisons/comparisons.factor b/basis/compiler/cfg/comparisons/comparisons.factor
index 35f25c2d40..019bfd7a74 100644
--- a/basis/compiler/cfg/comparisons/comparisons.factor
+++ b/basis/compiler/cfg/comparisons/comparisons.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs math.order sequences ;
 IN: compiler.cfg.comparisons
@@ -12,6 +12,8 @@ SYMBOLS:
 SYMBOLS:
     vcc-all vcc-notall vcc-any vcc-none ;
 
+SYMBOLS: cc-o cc/o ;
+
 : negate-cc ( cc -- cc' )
     H{
         { cc<    cc/<   }
@@ -28,6 +30,8 @@ SYMBOLS:
         { cc/=   cc=    } 
         { cc/<>  cc<>   } 
         { cc/<>= cc<>=  }
+        { cc-o   cc/o   }
+        { cc/o   cc-o   }
     } at ;
 
 : negate-vcc ( cc -- cc' )
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 87758fafcd..a576a54884 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs arrays classes combinators
 compiler.units fry generalizations generic kernel locals
@@ -19,6 +19,10 @@ M: insn uses-vregs drop { } ;
 
 M: ##phi uses-vregs inputs>> values ;
 
+M: _conditional-branch defs-vreg insn>> defs-vreg ;
+
+M: _conditional-branch uses-vregs insn>> uses-vregs ;
+
 <PRIVATE
 
 : slot-array-quot ( slots -- quot )
@@ -55,7 +59,7 @@ PRIVATE>
 [
     insn-classes get
     [ [ define-defs-vreg-method ] each ]
-    [ { ##phi } diff [ define-uses-vregs-method ] each ]
+    [ { ##phi _conditional-branch } diff [ define-uses-vregs-method ] each ]
     [ [ define-temp-vregs-method ] each ]
     tri
 ] with-compilation-unit
diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor
index 27d37b115f..7a148bc201 100644
--- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor
+++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor
@@ -1,14 +1,14 @@
-USING: compiler.cfg.gc-checks compiler.cfg.debugger
+USING: arrays compiler.cfg.gc-checks
+compiler.cfg.gc-checks.private compiler.cfg.debugger
 compiler.cfg.registers compiler.cfg.instructions compiler.cfg
-compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
-namespaces accessors sequences ;
+compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
+tools.test kernel vectors namespaces accessors sequences alien
+memory classes make combinators.short-circuit byte-arrays ;
 IN: compiler.cfg.gc-checks.tests
 
 : test-gc-checks ( -- )
     H{ } clone representations set
-    cfg new 0 get >>entry
-    insert-gc-checks
-    drop ;
+    cfg new 0 get >>entry cfg set ;
 
 V{
     T{ ##inc-d f 3 }
@@ -23,4 +23,149 @@ V{
 
 [ ] [ test-gc-checks ] unit-test
 
-[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
+[ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
+
+[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
+
+2 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##load-tagged f 3 0 }
+        T{ ##replace f 3 D 0 }
+        T{ ##replace f 3 R 3 }
+    }
+] [ [ { D 0 R 3 } wipe-locs ] V{ } make ] unit-test
+
+: gc-check? ( bb -- ? )
+    instructions>>
+    {
+        [ length 1 = ]
+        [ first ##check-nursery-branch? ]
+    } 1&& ;
+
+[ t ] [ 100 <gc-check> gc-check? ] unit-test
+
+2 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##save-context f 3 4 }
+        T{ ##load-tagged f 5 0 }
+        T{ ##replace f 5 D 0 }
+        T{ ##replace f 5 R 3 }
+        T{ ##call-gc f { 0 1 2 } }
+        T{ ##branch }
+    }
+]
+[
+    { D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
+] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##branch }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get needs-predecessors drop ] unit-test
+
+[ ] [ 31337 { D 1 R 2 } { 10 20 } 3 get (insert-gc-check) ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 2 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 2 D 0 }
+    T{ ##inc-d f 3 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##allot f 1 64 byte-array }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f 2 D 1 }
+    T{ ##branch }
+} 4 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 5 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 5 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+H{
+    { 2 tagged-rep }
+} representations set
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[ 2 ] [ 2 get predecessors>> length ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ 64 ] [ 1 get successors>> first instructions>> first size>> ] unit-test
+
+[ t ] [ 2 get predecessors>> first gc-check? ] unit-test
+
+[
+    V{
+        T{ ##save-context f 33 34 }
+        T{ ##load-tagged f 35 0 }
+        T{ ##replace f 35 D 0 }
+        T{ ##replace f 35 D 1 }
+        T{ ##replace f 35 D 2 }
+        T{ ##call-gc f { 2 } }
+        T{ ##branch }
+    }
+] [ 2 get predecessors>> second instructions>> ] unit-test
+
+! Don't forget to invalidate RPO after inserting basic blocks!
+[ 8 ] [ cfg get reverse-post-order length ] unit-test
diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor
index d151c725e2..737e956933 100644
--- a/basis/compiler/cfg/gc-checks/gc-checks.factor
+++ b/basis/compiler/cfg/gc-checks/gc-checks.factor
@@ -1,15 +1,25 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs fry math
-cpu.architecture layouts namespaces
+USING: accessors assocs combinators fry kernel layouts locals
+math make namespaces sequences cpu.architecture
+compiler.cfg
 compiler.cfg.rpo
+compiler.cfg.hats
 compiler.cfg.registers
+compiler.cfg.utilities
+compiler.cfg.comparisons
 compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.liveness
+compiler.cfg.liveness.ssa
 compiler.cfg.stacks.uninitialized ;
 IN: compiler.cfg.gc-checks
 
-! Garbage collection check insertion. This pass runs after representation
-! selection, so it must keep track of representations.
+<PRIVATE
+
+! Garbage collection check insertion. This pass runs after
+! representation selection, since it needs to know which vregs
+! can contain tagged pointers.
 
 : insert-gc-check? ( bb -- ? )
     instructions>> [ ##allocation? ] any? ;
@@ -17,6 +27,48 @@ IN: compiler.cfg.gc-checks
 : blocks-with-gc ( cfg -- bbs )
     post-order [ insert-gc-check? ] filter ;
 
+! A GC check for bb consists of two new basic blocks, gc-check
+! and gc-call:
+!
+!    gc-check
+!   /      \
+!  |     gc-call
+!   \      /
+!      bb
+
+: <gc-check> ( size -- bb )
+    [ <basic-block> ] dip
+    [
+        cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+        ##check-nursery-branch
+    ] V{ } make >>instructions ;
+
+: wipe-locs ( uninitialized-locs -- )
+    '[
+        int-rep next-vreg-rep
+        [ 0 ##load-tagged ]
+        [ '[ [ _ ] dip ##replace ] each ] bi
+    ] unless-empty ;
+
+: <gc-call> ( uninitialized-locs gc-roots -- bb )
+    [ <basic-block> ] 2dip
+    [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
+    >>instructions t >>unlikely? ;
+
+:: insert-guard ( check body bb -- )
+    bb predecessors>> check (>>predecessors)
+    V{ bb body }      check (>>successors)
+
+    V{ check }        body (>>predecessors)
+    V{ bb }           body (>>successors)
+
+    V{ check body }   bb (>>predecessors)
+
+    check predecessors>> [ bb check update-successors ] each ;
+
+: (insert-gc-check) ( size uninitialized-locs gc-roots bb -- )
+    [ [ <gc-check> ] 2dip <gc-call> ] dip insert-guard ;
+
 GENERIC: allocation-size* ( insn -- n )
 
 M: ##allot allocation-size* size>> ;
@@ -30,20 +82,27 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
     [ ##allocation? ] filter
     [ allocation-size* data-alignment get align ] map-sum ;
 
+: live-tagged ( bb -- vregs )
+    live-in keys [ rep-of tagged-rep? ] filter ;
+
 : insert-gc-check ( bb -- )
-    dup dup '[
-        tagged-rep next-vreg-rep
-        tagged-rep next-vreg-rep
-        _ allocation-size
-        f
-        f
-        _ uninitialized-locs
-        \ ##gc new-insn
-        prefix
-    ] change-instructions drop ;
+    {
+        [ allocation-size ]
+        [ uninitialized-locs ]
+        [ live-tagged ]
+        [ ]
+    } cleave
+    (insert-gc-check) ;
+
+PRIVATE>
 
 : insert-gc-checks ( cfg -- cfg' )
     dup blocks-with-gc [
-        over compute-uninitialized-sets
+        [
+            needs-predecessors
+            dup compute-ssa-live-sets
+            dup compute-uninitialized-sets
+        ] dip
         [ insert-gc-check ] each
+        cfg-changed
     ] unless-empty ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 8ee21154fa..db1496f147 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -682,23 +682,30 @@ temp: temp/int-rep ;
 ! Overflowing arithmetic
 INSN: ##fixnum-add
 def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
 
 INSN: ##fixnum-sub
 def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
 
 INSN: ##fixnum-mul
 def: dst/tagged-rep
-use: src1/tagged-rep src2/int-rep ;
-
-INSN: ##gc
-temp: temp1/int-rep temp2/int-rep
-literal: size data-values tagged-values uninitialized-locs ;
+use: src1/tagged-rep src2/int-rep
+literal: cc ;
 
 INSN: ##save-context
 temp: temp1/int-rep temp2/int-rep ;
 
+! GC checks
+INSN: ##check-nursery-branch
+literal: size cc
+temp: temp1/int-rep temp2/int-rep ;
+
+INSN: ##call-gc
+literal: gc-roots ;
+
 ! Instructions used by machine IR only.
 INSN: _prologue
 literal: stack-frame ;
@@ -714,48 +721,11 @@ literal: label ;
 
 INSN: _loop-entry ;
 
-INSN: _dispatch
-use: src
-temp: temp ;
-
 INSN: _dispatch-label
 literal: label ;
 
-INSN: _compare-branch
-literal: label
-use: src1 src2
-literal: cc ;
-
-INSN: _compare-imm-branch
-literal: label
-use: src1
-literal: src2 cc ;
-
-INSN: _compare-float-unordered-branch
-literal: label
-use: src1 src2
-literal: cc ;
-
-INSN: _compare-float-ordered-branch
-literal: label
-use: src1 src2
-literal: cc ;
-
-! Overflowing arithmetic
-INSN: _fixnum-add
-literal: label
-def: dst
-use: src1 src2 ;
-
-INSN: _fixnum-sub
-literal: label
-def: dst
-use: src1 src2 ;
-
-INSN: _fixnum-mul
-literal: label
-def: dst
-use: src1 src2 ;
+INSN: _conditional-branch
+literal: label insn ;
 
 TUPLE: spill-slot { n integer } ;
 C: <spill-slot> spill-slot
@@ -771,18 +741,31 @@ literal: rep src ;
 INSN: _spill-area-size
 literal: n ;
 
-! For GC check insertion
 UNION: ##allocation
 ##allot
 ##box-alien
 ##box-displaced-alien ;
 
+UNION: conditional-branch-insn
+##compare-branch
+##compare-imm-branch
+##compare-integer-branch
+##compare-integer-imm-branch
+##compare-float-ordered-branch
+##compare-float-unordered-branch
+##test-vector-branch
+##check-nursery-branch
+##fixnum-add
+##fixnum-sub
+##fixnum-mul ;
+
 ! For alias analysis
 UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
 UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
 
-! Instructions that kill all live vregs but cannot trigger GC
-UNION: partial-sync-insn
+! Instructions that clobber registers
+UNION: clobber-insn
+##call-gc
 ##unary-float-function
 ##binary-float-function ;
 
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index dcecb1fac4..b9cfac3b92 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -4,6 +4,7 @@ USING: sequences accessors layouts kernel math math.intervals
 namespaces combinators fry arrays
 cpu.architecture
 compiler.tree.propagation.info
+compiler.cfg
 compiler.cfg.hats
 compiler.cfg.stacks
 compiler.cfg.instructions
@@ -55,7 +56,7 @@ IN: compiler.cfg.intrinsics.fixnum
 : emit-fixnum-overflow-op ( quot word -- )
     ! Inputs to the final instruction need to be copied because
     ! of loc>vreg sync
-    [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
+    [ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip
     [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
     emit-conditional ; inline
 
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index ae6c375016..764e37786f 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -63,18 +63,19 @@ M: sync-point handle ( sync-point -- )
 
 : smallest-heap ( heap1 heap2 -- heap )
     ! If heap1 and heap2 have the same key, favors heap1.
-    [ [ heap-peek nip ] bi@ <= ] most ;
+    {
+        { [ dup heap-empty? ] [ drop ] }
+        { [ over heap-empty? ] [ nip ] }
+        [ [ [ heap-peek nip ] bi@ <= ] most ]
+    } cond ;
 
 : (allocate-registers) ( -- )
-    {
-        { [ unhandled-intervals get heap-empty? ] [ unhandled-sync-points get ] }
-        { [ unhandled-sync-points get heap-empty? ] [ unhandled-intervals get ] }
-        ! If a live interval begins at the same location as a sync point,
-        ! process the sync point before the live interval. This ensures that the
-        ! return value of C function calls doesn't get spilled and reloaded
-        ! unnecessarily.
-        [ unhandled-sync-points get unhandled-intervals get smallest-heap ]
-    } cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
+    ! If a live interval begins at the same location as a sync point,
+    ! process the sync point before the live interval. This ensures that the
+    ! return value of C function calls doesn't get spilled and reloaded
+    ! unnecessarily.
+    unhandled-sync-points get unhandled-intervals get smallest-heap
+    dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
 
 : finish-allocation ( -- )
     active-intervals inactive-intervals
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 535f4515eb..6cceea3303 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -126,39 +126,9 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 M: vreg-insn assign-registers-in-insn
     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 
-: trace-on-gc ( assoc -- assoc' )
-    ! When a GC occurs, virtual registers which contain tagged data
-    ! are traced by the GC. Outputs a sequence physical registers.
-    [ drop rep-of tagged-rep eq? ] { } assoc-filter-as values ;
-
-: spill-on-gc? ( vreg reg -- ? )
-    [ rep-of tagged-rep? not ] [ spill-slot? not ] bi* and ;
-
-: spill-on-gc ( assoc -- assoc' )
-    ! When a GC occurs, virtual registers which contain untagged data,
-    ! and are stored in physical registers, are saved to their spill
-    ! slots. Outputs sequence of triples:
-    ! - physical register
-    ! - spill slot
-    ! - representation
-    [
-        [
-            2dup spill-on-gc?
-            [ swap [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if
-        ] assoc-each
-    ] { } make ;
-
-: gc-root-offsets ( registers -- alist )
-    ! Outputs a sequence of { offset register/spill-slot } pairs
-    [ length iota [ cell * ] map ] keep zip ;
-
-M: ##gc assign-registers-in-insn
-    ! Since ##gc is always the first instruction in a block, the set of
-    ! values live at the ##gc is just live-in.
+M: ##call-gc assign-registers-in-insn
     dup call-next-method
-    basic-block get register-live-ins get at
-    [ trace-on-gc gc-root-offsets >>tagged-values ] [ spill-on-gc >>data-values ] bi
-    drop ;
+    [ [ vreg>reg ] map ] change-gc-roots drop ;
 
 M: insn assign-registers-in-insn drop ;
 
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 570c7f9aa7..3bf7dd827c 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -1444,49 +1444,3 @@ test-diamond
 [ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
 
 [ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
-
-V{
-    T{ ##peek f 0 D 0 }
-    T{ ##peek f 1 D 1 }
-    T{ ##replace f 1 D 1 }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##gc f 2 3 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##replace f 0 D 0 }
-    T{ ##return }
-} 2 test-bb
-
-0 1 edge
-1 2 edge
-
-[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-
-[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test
-
-V{
-    T{ ##peek f 0 D 0 }
-    T{ ##peek f 1 D 1 }
-    T{ ##compare-imm-branch f 1 5 cc= }
-} 0 test-bb
-
-V{
-    T{ ##gc f 2 3 }
-    T{ ##replace f 0 D 0 }
-    T{ ##return }
-} 1 test-bb
-
-V{
-    T{ ##return }
-} 2 test-bb
-
-0 { 1 2 } edges
-
-[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-
-[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index 221832e41a..da079da0e4 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -102,7 +102,7 @@ M: vreg-insn compute-live-intervals*
     [ dup temp-vregs [ handle-temp ] with each ]
     tri ;
 
-M: partial-sync-insn compute-live-intervals*
+M: clobber-insn compute-live-intervals*
     [ dup defs-vreg [ +use+ handle-output ] with when* ]
     [ dup uses-vregs [ +memory+ handle-input ] with each ]
     [ dup temp-vregs [ handle-temp ] with each ]
@@ -122,7 +122,7 @@ SYMBOL: sync-points
 
 GENERIC: compute-sync-points* ( insn -- )
 
-M: partial-sync-insn compute-sync-points*
+M: clobber-insn compute-sync-points*
     insn#>> <sync-point> sync-points get push ;
 
 M: insn compute-sync-points* drop ;
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index 893a60b267..f16c608293 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -57,6 +57,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
 [
     {
         T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
+        T{ ##branch }
     }
 ] [
     { { T{ location f 1 int-rep int-regs } T{ location f 2 int-rep int-regs } } }
@@ -67,6 +68,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
     {
         T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 0 } } }
         T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 1 } } }
+        T{ ##branch }
     }
 ] [
     {
@@ -80,6 +82,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
     {
         T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
         T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+        T{ ##branch }
     }
 ] [
     {
@@ -93,6 +96,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
     {
         T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
         T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+        T{ ##branch }
     }
 ] [
     {
@@ -115,11 +119,13 @@ H{ } clone spill-temps set
             T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
             T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
             T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
+            T{ ##branch }
         }
         {
             T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
             T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
             T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
+            T{ ##branch }
         }
     } member?
 ] unit-test
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index f64c0fc890..b450145bd4 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -78,11 +78,11 @@ SYMBOL: temp
 
 : mapping-instructions ( alist -- insns )
     [ swap ] H{ } assoc-map-as
-    [ temp [ swap >insn ] parallel-mapping ] { } make ;
+    [ temp [ swap >insn ] parallel-mapping ##branch ] { } make ;
 
 : perform-mappings ( bb to mappings -- )
     dup empty? [ 3drop ] [
-        mapping-instructions insert-simple-basic-block
+        mapping-instructions insert-basic-block
         cfg get cfg-changed drop
     ] if ;
 
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index b53eebfc20..9c3a0068bc 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math accessors sequences namespaces make
 combinators assocs arrays locals layouts hashtables
@@ -19,14 +19,8 @@ SYMBOL: numbers
 
 : number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
 
-! Convert CFG IR to machine IR.
 GENERIC: linearize-insn ( basic-block insn -- )
 
-: linearize-basic-block ( bb -- )
-    [ block-number _label ]
-    [ dup instructions>> [ linearize-insn ] with each ]
-    bi ;
-
 M: insn linearize-insn , drop ;
 
 : useless-branch? ( basic-block successor -- ? )
@@ -40,68 +34,29 @@ M: insn linearize-insn , drop ;
 M: ##branch linearize-insn
     drop dup successors>> first emit-branch ;
 
-: successors ( bb -- first second ) successors>> first2 ; inline
+GENERIC: negate-insn-cc ( insn -- )
 
-:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label etc... )
-    bb insn
-    conditional-quot
-    [ drop dup successors>> second useless-branch? ] 2bi
-    [ [ swap block-number ] n ndip ]
-    [ [ block-number ] n ndip negate-cc-quot call ] if ; inline
+M: conditional-branch-insn negate-insn-cc
+    [ negate-cc ] change-cc drop ;
 
-: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
-    [ dup successors ]
-    [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
+M: ##test-vector-branch negate-insn-cc
+    [ negate-vcc ] change-vcc drop ;
 
-: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
-    3 [ (binary-conditional) ] [ negate-cc ] conditional ;
-
-: (test-vector-conditional) ( bb insn -- bb successor1 successor2 src1 temp rep vcc )
-    [ dup successors ]
-    [ { [ src1>> ] [ temp>> ] [ rep>> ] [ vcc>> ] } cleave ] bi* ; inline
-
-: test-vector-conditional ( bb insn -- bb successor label src1 temp rep vcc )
-    4 [ (test-vector-conditional) ] [ negate-vcc ] conditional ;
-
-M: ##compare-branch linearize-insn
-    binary-conditional _compare-branch emit-branch ;
-
-M: ##compare-imm-branch linearize-insn
-    binary-conditional _compare-imm-branch emit-branch ;
-
-M: ##compare-integer-branch linearize-insn
-    binary-conditional _compare-branch emit-branch ;
-
-M: ##compare-integer-imm-branch linearize-insn
-    binary-conditional _compare-imm-branch emit-branch ;
-
-M: ##compare-float-ordered-branch linearize-insn
-    binary-conditional _compare-float-ordered-branch emit-branch ;
-
-M: ##compare-float-unordered-branch linearize-insn
-    binary-conditional _compare-float-unordered-branch emit-branch ;
-
-M: ##test-vector-branch linearize-insn
-    test-vector-conditional _test-vector-branch emit-branch ;
-
-: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
-    [ dup successors block-number ]
-    [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
-
-M: ##fixnum-add linearize-insn
-    overflow-conditional _fixnum-add emit-branch ;
-
-M: ##fixnum-sub linearize-insn
-    overflow-conditional _fixnum-sub emit-branch ;
-
-M: ##fixnum-mul linearize-insn
-    overflow-conditional _fixnum-mul emit-branch ;
+M:: conditional-branch-insn linearize-insn ( bb insn -- )
+    bb successors>> first2 :> ( first second )
+    bb second useless-branch?
+    [ bb second first ]
+    [ bb first second insn negate-insn-cc ] if
+    block-number insn _conditional-branch
+    emit-branch ;
 
 M: ##dispatch linearize-insn
-    swap
-    [ [ src>> ] [ temp>> ] bi _dispatch ]
-    [ successors>> [ block-number _dispatch-label ] each ]
-    bi* ;
+    , successors>> [ block-number _dispatch-label ] each ;
+
+: linearize-basic-block ( bb -- )
+    [ block-number _label ]
+    [ dup instructions>> [ linearize-insn ] with each ]
+    bi ;
 
 : linearize-basic-blocks ( cfg -- insns )
     [
@@ -113,7 +68,7 @@ M: ##dispatch linearize-insn
     ] { } make ;
 
 PRIVATE>
-        
+
 : flatten-cfg ( cfg -- mr )
     [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
     <mr> ;
diff --git a/basis/compiler/cfg/linearization/order/order.factor b/basis/compiler/cfg/linearization/order/order.factor
index 166a0f0d50..a68a90a8e8 100644
--- a/basis/compiler/cfg/linearization/order/order.factor
+++ b/basis/compiler/cfg/linearization/order/order.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs deques dlists kernel make sorting
 namespaces sequences combinators combinators.short-circuit
@@ -8,7 +8,8 @@ sets hash-sets ;
 FROM: namespaces => set ;
 IN: compiler.cfg.linearization.order
 
-! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
 
 <PRIVATE
 
@@ -68,7 +69,9 @@ SYMBOLS: work-list loop-heads visited ;
 : (linearization-order) ( cfg -- bbs )
     init-linearization-order
 
-    [ work-list get [ process-block ] slurp-deque ] { } make ;
+    [ work-list get [ process-block ] slurp-deque ] { } make
+    ! [ unlikely?>> not ] partition append
+    ;
 
 PRIVATE>
 
diff --git a/basis/compiler/cfg/liveness/ssa/ssa.factor b/basis/compiler/cfg/liveness/ssa/ssa.factor
index 5215c9c487..3e54333265 100644
--- a/basis/compiler/cfg/liveness/ssa/ssa.factor
+++ b/basis/compiler/cfg/liveness/ssa/ssa.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces deques accessors sets sequences assocs fry
 hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
@@ -48,14 +48,14 @@ SYMBOL: work-list
         [ predecessors>> add-to-work-list ] [ drop ] if
     ] [ drop ] if ;
 
-: compute-ssa-live-sets ( cfg -- cfg' )
+: compute-ssa-live-sets ( cfg -- )
     needs-predecessors
 
     <hashed-dlist> work-list set
     H{ } clone live-ins set
     H{ } clone phi-live-ins set
     H{ } clone live-outs set
-    dup post-order add-to-work-list
+    post-order add-to-work-list
     work-list get [ liveness-step ] slurp-deque ;
 
 : live-in? ( vreg bb -- ? ) live-in key? ;
diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor
index a46e6c15cb..140fba8d4e 100644
--- a/basis/compiler/cfg/mr/mr.factor
+++ b/basis/compiler/cfg/mr/mr.factor
@@ -1,14 +1,11 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces accessors compiler.cfg
-compiler.cfg.linearization compiler.cfg.gc-checks
-compiler.cfg.save-contexts compiler.cfg.linear-scan
+compiler.cfg.linearization compiler.cfg.linear-scan
 compiler.cfg.build-stack-frame ;
 IN: compiler.cfg.mr
 
 : build-mr ( cfg -- mr )
-    insert-gc-checks
-    insert-save-contexts
     linear-scan
     flatten-cfg
     build-stack-frame ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 84726a9b99..e6cd65f4b5 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors combinators namespaces
 compiler.cfg.tco
@@ -12,6 +12,8 @@ compiler.cfg.copy-prop
 compiler.cfg.dce
 compiler.cfg.write-barrier
 compiler.cfg.representations
+compiler.cfg.gc-checks
+compiler.cfg.save-contexts
 compiler.cfg.ssa.destruction
 compiler.cfg.empty-blocks
 compiler.cfg.checker ;
@@ -36,6 +38,8 @@ SYMBOL: check-optimizer?
     eliminate-dead-code
     eliminate-write-barriers
     select-representations
+    insert-gc-checks
+    insert-save-contexts
     destruct-ssa
     delete-empty-blocks
     ?check ;
diff --git a/basis/compiler/cfg/save-contexts/save-contexts.factor b/basis/compiler/cfg/save-contexts/save-contexts.factor
index e2ccf943ad..e5edd7cdff 100644
--- a/basis/compiler/cfg/save-contexts/save-contexts.factor
+++ b/basis/compiler/cfg/save-contexts/save-contexts.factor
@@ -10,6 +10,7 @@ IN: compiler.cfg.save-contexts
 : needs-save-context? ( insns -- ? )
     [
         {
+            [ ##call-gc? ]
             [ ##unary-float-function? ]
             [ ##binary-float-function? ]
             [ ##alien-invoke? ]
diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor
index a55e5baa2c..83413067b7 100644
--- a/basis/compiler/cfg/ssa/destruction/destruction.factor
+++ b/basis/compiler/cfg/ssa/destruction/destruction.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs fry kernel namespaces
 sequences sequences.deep
@@ -93,25 +93,32 @@ M: ##phi prepare-insn
         [ 2drop ] [ eliminate-copy ] if
     ] assoc-each ;
 
-: useless-copy? ( ##copy -- ? )
-    dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
+GENERIC: rename-insn ( insn -- keep? )
+
+M: vreg-insn rename-insn
+    [ rename-insn-defs ] [ rename-insn-uses ] bi t ;
+
+M: ##copy rename-insn
+    [ call-next-method drop ]
+    [ [ dst>> ] [ src>> ] bi eq? not ] bi ;
+
+M: ##phi rename-insn drop f ;
+
+M: ##call-gc rename-insn
+    [ renamings get '[ _ at ] map members ] change-gc-roots drop t ;
+
+M: insn rename-insn drop t ;
 
 : perform-renaming ( cfg -- )
     leader-map get keys [ dup leader ] H{ } map>assoc renamings set
-    [
-        instructions>> [
-            [ rename-insn-defs ]
-            [ rename-insn-uses ]
-            [ [ useless-copy? ] [ ##phi? ] bi or not ] tri
-        ] filter! drop
-    ] each-basic-block ;
+    [ instructions>> [ rename-insn ] filter! drop ] each-basic-block ;
 
 : destruct-ssa ( cfg -- cfg' )
     needs-dominance
 
     dup construct-cssa
     dup compute-defs
-    compute-ssa-live-sets
+    dup compute-ssa-live-sets
     dup compute-live-ranges
     dup prepare-coalescing
     process-copies
diff --git a/basis/compiler/cfg/ssa/interference/interference-tests.factor b/basis/compiler/cfg/ssa/interference/interference-tests.factor
index 2f13331024..c48ae4ad58 100644
--- a/basis/compiler/cfg/ssa/interference/interference-tests.factor
+++ b/basis/compiler/cfg/ssa/interference/interference-tests.factor
@@ -9,7 +9,7 @@ IN: compiler.cfg.ssa.interference.tests
 
 : test-interference ( -- )
     cfg new 0 get >>entry
-    compute-ssa-live-sets
+    dup compute-ssa-live-sets
     dup compute-defs
     compute-live-ranges ;
 
diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index 3cfade23e1..5861ca67bd 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math math.order namespaces accessors kernel layouts combinators
 combinators.smart assocs sequences cpu.architecture ;
@@ -8,7 +8,6 @@ TUPLE: stack-frame
 { params integer }
 { return integer }
 { total-size integer }
-{ gc-root-size integer }
 { spill-area-size integer }
 { calls-vm? boolean } ;
 
@@ -19,19 +18,9 @@ TUPLE: stack-frame
 : spill-offset ( n -- offset )
     param-base + ;
 
-: gc-root-base ( -- n )
-    stack-frame get spill-area-size>> param-base + ;
-
-: gc-root-offset ( n -- n' ) gc-root-base + ;
-
 : (stack-frame-size) ( stack-frame -- n )
     [
-        {
-            [ params>> ]
-            [ return>> ]
-            [ gc-root-size>> ]
-            [ spill-area-size>> ]
-        } cleave
+        [ params>> ] [ return>> ] [ spill-area-size>> ] tri
     ] sum-outputs ;
 
 : max-stack-frame ( frame1 frame2 -- frame3 )
@@ -39,6 +28,5 @@ TUPLE: stack-frame
     {
         [ [ params>> ] bi@ max >>params ]
         [ [ return>> ] bi@ max >>return ]
-        [ [ gc-root-size>> ] bi@ max >>gc-root-size ]
         [ [ calls-vm?>> ] bi@ or >>calls-vm? ]
     } 2cleave ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor
index ad3453704b..41512f206f 100644
--- a/basis/compiler/cfg/stacks/finalize/finalize.factor
+++ b/basis/compiler/cfg/stacks/finalize/finalize.factor
@@ -44,8 +44,8 @@ ERROR: bad-peek dst loc ;
     ! If both blocks are subroutine calls, don't bother
     ! computing anything.
     2dup [ kill-block? ] both? [ 2drop ] [
-        2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
-        [ 2drop ] [ insert-simple-basic-block ] if-empty
+        2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make
+        [ 2drop ] [ insert-basic-block ] if-empty
     ] if ;
 
 : visit-block ( bb -- )
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index de2d238f1e..ae860c52ce 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -37,11 +37,24 @@ SYMBOL: visited
 : skip-empty-blocks ( bb -- bb' )
     H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
 
-:: insert-basic-block ( froms to bb -- )
-    bb froms V{ } like >>predecessors drop
-    bb to 1vector >>successors drop
-    to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop
-    froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ;
+:: update-predecessors ( from to bb -- )
+    ! Update 'to' predecessors for insertion of 'bb' between
+    ! 'from' and 'to'.
+    to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
+
+:: update-successors ( from to bb -- )
+    ! Update 'from' successors for insertion of 'bb' between
+    ! 'from' and 'to'.
+    from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
+
+:: insert-basic-block ( from to insns -- )
+    ! Insert basic block on the edge between 'from' and 'to'.
+    <basic-block> :> bb
+    insns V{ } like bb (>>instructions)
+    V{ from } bb (>>predecessors)
+    V{ to } bb (>>successors)
+    from to bb update-predecessors
+    from to bb update-successors ;
 
 : add-instructions ( bb quot -- )
     [ instructions>> building ] dip '[
@@ -50,15 +63,6 @@ SYMBOL: visited
         ,
     ] with-variable ; inline
 
-: <simple-block> ( insns -- bb )
-    <basic-block>
-    swap >vector
-    \ ##branch new-insn over push
-    >>instructions ;
-
-: insert-simple-basic-block ( from to insns -- )
-    [ 1vector ] 2dip <simple-block> insert-basic-block ;
-
 : has-phis? ( bb -- ? )
     instructions>> first ##phi? ;
 
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index bae2fdcf6c..3a101092b2 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -30,6 +30,9 @@ GENERIC: generate-insn ( insn -- )
 ! Mapping _label IDs to label instances
 SYMBOL: labels
 
+: lookup-label ( id -- label )
+    labels get [ drop <label> ] cache ;
+
 : generate ( mr -- code )
     dup label>> [
         H{ } clone labels set
@@ -40,17 +43,9 @@ SYMBOL: labels
         ] each
     ] with-fixup ;
 
-: lookup-label ( id -- label )
-    labels get [ drop <label> ] cache ;
-
 ! Special cases
 M: ##no-tco generate-insn drop ;
 
-M: _dispatch-label generate-insn
-    label>> lookup-label
-    cell 0 <repetition> %
-    rc-absolute-cell label-fixup ;
-
 M: _prologue generate-insn
     stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
 
@@ -76,6 +71,7 @@ M: _spill-area-size generate-insn drop ;
 SYNTAX: CODEGEN:
     scan-word [ \ generate-insn create-method-in ] keep scan-word
     codegen-method-body define ;
+
 >>
 
 CODEGEN: ##load-integer %load-immediate
@@ -203,67 +199,45 @@ CODEGEN: ##save-context %save-context
 CODEGEN: ##vm-field %vm-field
 CODEGEN: ##set-vm-field %set-vm-field
 CODEGEN: ##alien-global %alien-global
+CODEGEN: ##call-gc %call-gc
+
+CODEGEN: ##dispatch %dispatch
+
+: %dispatch-label ( label -- )
+    cell 0 <repetition> %
+    rc-absolute-cell label-fixup ;
 
-CODEGEN: _fixnum-add %fixnum-add
-CODEGEN: _fixnum-sub %fixnum-sub
-CODEGEN: _fixnum-mul %fixnum-mul
 CODEGEN: _label resolve-label
+CODEGEN: _dispatch-label %dispatch-label
 CODEGEN: _branch %jump-label
-CODEGEN: _compare-branch %compare-branch
-CODEGEN: _compare-imm-branch %compare-imm-branch
-CODEGEN: _compare-float-ordered-branch %compare-float-ordered-branch
-CODEGEN: _compare-float-unordered-branch %compare-float-unordered-branch
-CODEGEN: _test-vector-branch %test-vector-branch
-CODEGEN: _dispatch %dispatch
 CODEGEN: _spill %spill
 CODEGEN: _reload %reload
 CODEGEN: _loop-entry %loop-entry
 
-! ##gc
-: wipe-locs ( locs temp -- )
-    '[
-        _
-        [ 0 %load-immediate ]
-        [ swap [ %replace ] with each ] bi
-    ] unless-empty ;
+GENERIC: generate-conditional-insn ( label insn -- )
 
-GENERIC# save-gc-root 1 ( gc-root operand temp -- )
+<<
 
-M:: spill-slot save-gc-root ( gc-root operand temp -- )
-    temp int-rep operand %reload
-    gc-root temp %save-gc-root ;
+SYNTAX: CONDITIONAL:
+    scan-word [ \ generate-conditional-insn create-method-in ] keep scan-word
+    codegen-method-body define ;
 
-M: object save-gc-root drop %save-gc-root ;
+>>
 
-: save-gc-roots ( gc-roots temp -- ) '[ _ save-gc-root ] assoc-each ;
+CONDITIONAL: ##compare-branch %compare-branch
+CONDITIONAL: ##compare-imm-branch %compare-imm-branch
+CONDITIONAL: ##compare-integer-branch %compare-branch
+CONDITIONAL: ##compare-integer-imm-branch %compare-imm-branch
+CONDITIONAL: ##compare-float-ordered-branch %compare-float-ordered-branch
+CONDITIONAL: ##compare-float-unordered-branch %compare-float-unordered-branch
+CONDITIONAL: ##test-vector-branch %test-vector-branch
+CONDITIONAL: ##check-nursery-branch %check-nursery-branch
+CONDITIONAL: ##fixnum-add %fixnum-add
+CONDITIONAL: ##fixnum-sub %fixnum-sub
+CONDITIONAL: ##fixnum-mul %fixnum-mul
 
-: save-data-regs ( data-regs -- ) [ first3 %spill ] each ;
-
-GENERIC# load-gc-root 1 ( gc-root operand temp -- )
-
-M:: spill-slot load-gc-root ( gc-root operand temp -- )
-    gc-root temp %load-gc-root
-    temp int-rep operand %spill ;
-
-M: object load-gc-root drop %load-gc-root ;
-
-: load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ;
-
-: load-data-regs ( data-regs -- ) [ first3 %reload ] each ;
-
-M: ##gc generate-insn
-    "no-gc" define-label
-    {
-        [ [ "no-gc" get ] dip [ size>> ] [ temp1>> ] [ temp2>> ] tri %check-nursery ]
-        [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
-        [ data-values>> save-data-regs ]
-        [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
-        [ [ temp1>> ] [ temp2>> ] bi %save-context ]
-        [ [ tagged-values>> length ] [ temp1>> ] bi %call-gc ]
-        [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
-        [ data-values>> load-data-regs ]
-    } cleave
-    "no-gc" resolve-label ;
+M: _conditional-branch generate-insn
+    [ label>> lookup-label ] [ insn>> ] bi generate-conditional-insn ;
 
 ! ##alien-invoke
 GENERIC: next-fastcall-param ( rep -- )
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index d7e77d6267..09745dea6b 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -272,9 +272,9 @@ HOOK: %copy cpu ( dst src rep -- )
 
 : %tagged>integer ( dst src -- ) int-rep %copy ;
 
-HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
-HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
-HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
+HOOK: %fixnum-add cpu ( label dst src1 src2 cc -- )
+HOOK: %fixnum-sub cpu ( label dst src1 src2 cc -- )
+HOOK: %fixnum-mul cpu ( label dst src1 src2 cc -- )
 
 HOOK: %add-float cpu ( dst src1 src2 -- )
 HOOK: %sub-float cpu ( dst src1 src2 -- )
@@ -463,10 +463,8 @@ HOOK: %write-barrier cpu ( src slot scale tag temp1 temp2 -- )
 HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- )
 
 ! GC checks
-HOOK: %check-nursery cpu ( label size temp1 temp2 -- )
-HOOK: %save-gc-root cpu ( gc-root register -- )
-HOOK: %load-gc-root cpu ( gc-root register -- )
-HOOK: %call-gc cpu ( gc-root-count temp1 -- )
+HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
+HOOK: %call-gc cpu ( gc-roots -- )
 
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index c567c1e1f0..225e62dc0e 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -344,11 +344,10 @@ M: x86.32 stack-cleanup ( params -- n )
 M: x86.32 %cleanup ( params -- )
     stack-cleanup [ ESP swap SUB ] unless-zero ;
 
-M:: x86.32 %call-gc ( gc-root-count temp -- )
-    temp gc-root-base special@ LEA
-    8 save-vm-ptr
-    4 stack@ gc-root-count MOV
-    0 stack@ temp MOV
+M:: x86.32 %call-gc ( gc-roots -- )
+    4 save-vm-ptr
+    EAX gc-roots gc-root-offsets %load-reference
+    0 stack@ EAX MOV
     "inline_gc" f %alien-invoke ;
 
 M: x86.32 dummy-stack-params? f ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index d1c71f3cd4..01f3c4677b 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -267,14 +267,9 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
     func "libm" load-library %alien-invoke
     dst float-function-return ;
 
-M:: x86.64 %call-gc ( gc-root-count temp -- )
-    ! Pass pointer to start of GC roots as first parameter
-    param-reg-0 gc-root-base param@ LEA
-    ! Pass number of roots as second parameter
-    param-reg-1 gc-root-count MOV
-    ! Pass VM ptr as third parameter
-    param-reg-2 %mov-vm-ptr
-    ! Call GC
+M:: x86.64 %call-gc ( gc-roots -- )
+    param-reg-0 gc-roots gc-root-offsets %load-reference
+    param-reg-1 %mov-vm-ptr
     "inline_gc" f %alien-invoke ;
 
 M: x86.64 struct-return-pointer-type void* ;
diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor
index 059be328f2..76157bd7cc 100644
--- a/basis/cpu/x86/assembler/assembler.factor
+++ b/basis/cpu/x86/assembler/assembler.factor
@@ -334,7 +334,7 @@ PRIVATE>
 : SAR ( dst n -- ) BIN: 111 (SHIFT) ;
 
 : IMUL2 ( dst src -- )
-    swap OCT: 257 extended-opcode (2-operand) ;
+    OCT: 257 extended-opcode (2-operand) ;
 
 : IMUL3 ( dst src imm -- )
     dup fits-in-byte? [
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 5bb55bead0..7669b17f20 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -465,7 +465,7 @@ big-endian off
     ! multiply
     temp0 temp1 IMUL2
     ! push result
-    ds-reg [] temp1 MOV
+    ds-reg [] temp0 MOV
 ] \ fixnum*fast define-sub-primitive
 
 [ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index d0afb7fa81..891995e6b3 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -33,17 +33,19 @@ HOOK: extra-stack-space cpu ( stack-frame -- n )
 
 : stack@ ( n -- op ) stack-reg swap [+] ;
 
-: special@ ( n -- op )
+: special-offset ( m -- n )
     stack-frame get extra-stack-space +
-    reserved-stack-space +
-    stack@ ;
+    reserved-stack-space + ;
+
+: special@ ( n -- op ) special-offset stack@ ;
 
 : spill@ ( n -- op ) spill-offset special@ ;
 
-: gc-root@ ( n -- op ) gc-root-offset special@ ;
-
 : param@ ( n -- op ) reserved-stack-space + stack@ ;
 
+: gc-root-offsets ( seq -- seq' )
+    [ n>> special-offset ] map f like ;
+
 : decr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
 
@@ -133,7 +135,7 @@ M: x86 %add     2over eq? [ nip ADD ] [ [+] LEA ] if ;
 M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ;
 M: x86 %sub     int-rep two-operand SUB ;
 M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ;
-M: x86 %mul     int-rep two-operand swap IMUL2 ;
+M: x86 %mul     int-rep two-operand IMUL2 ;
 M: x86 %mul-imm IMUL3 ;
 M: x86 %and     int-rep two-operand AND ;
 M: x86 %and-imm int-rep two-operand AND ;
@@ -175,14 +177,21 @@ M: x86 %copy ( dst src rep -- )
         2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
     ] if ;
 
-M: x86 %fixnum-add ( label dst src1 src2 -- )
-    int-rep two-operand ADD JO ;
+: fixnum-overflow ( label dst src1 src2 cc quot -- )
+    swap [ [ int-rep two-operand ] dip call ] dip
+    {
+        { cc-o [ JO ] }
+        { cc/o [ JNO ] }
+    } case ; inline
 
-M: x86 %fixnum-sub ( label dst src1 src2 -- )
-    int-rep two-operand SUB JO ;
+M: x86 %fixnum-add ( label dst src1 src2 cc -- )
+    [ ADD ] fixnum-overflow ;
 
-M: x86 %fixnum-mul ( label dst src1 src2 -- )
-    int-rep two-operand swap IMUL2 JO ;
+M: x86 %fixnum-sub ( label dst src1 src2 cc -- )
+    [ SUB ] fixnum-overflow ;
+
+M: x86 %fixnum-mul ( label dst src1 src2 cc -- )
+    [ IMUL2 ] fixnum-overflow ;
 
 M: x86 %unbox-alien ( dst src -- )
     alien-offset [+] MOV ;
@@ -453,19 +462,15 @@ M:: x86 %write-barrier-imm ( src slot tag temp1 temp2 -- )
     temp1 src slot tag (%slot-imm) LEA
     temp1 temp2 (%write-barrier) ;
 
-M:: x86 %check-nursery ( label size temp1 temp2 -- )
+M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- )
     temp1 load-zone-offset
-    ! Load 'here' into temp2
     temp2 temp1 [] MOV
     temp2 size ADD
-    ! Load 'end' into temp1
-    temp1 temp1 2 cells [+] MOV
-    temp2 temp1 CMP
-    label JLE ;
-
-M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
-
-M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
+    temp2 temp1 2 cells [+] CMP
+    cc {
+        { cc<= [ label JLE ] }
+        { cc/<= [ label JG ] }
+    } case ;
 
 M: x86 %alien-global ( dst symbol library -- )
     [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;    
diff --git a/vm/gc.cpp b/vm/gc.cpp
index e01a05aa5b..257a2a556c 100755
--- a/vm/gc.cpp
+++ b/vm/gc.cpp
@@ -215,16 +215,34 @@ void factor_vm::primitive_compact_gc()
 		true /* trace contexts? */);
 }
 
-void factor_vm::inline_gc(cell *data_roots_base, cell data_roots_size)
+void factor_vm::inline_gc(cell gc_roots_)
 {
-	data_roots.push_back(data_root_range(data_roots_base,data_roots_size));
-	primitive_minor_gc();
-	data_roots.pop_back();
+	cell stack_pointer = (cell)ctx->callstack_top + sizeof(cell);
+
+	if(to_boolean(gc_roots_))
+	{
+		tagged<array> gc_roots(gc_roots_);
+
+		cell capacity = array_capacity(gc_roots.untagged());
+		for(cell i = 0; i < capacity; i++)
+		{
+			cell spill_slot = untag_fixnum(array_nth(gc_roots.untagged(),i));
+			cell *address = (cell *)(spill_slot + stack_pointer);
+			data_roots.push_back(data_root_range(address,1));
+		}
+
+		primitive_minor_gc();
+
+		for(cell i = 0; i < capacity; i++)
+			data_roots.pop_back();
+	}
+	else
+		primitive_minor_gc();
 }
 
-VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent)
+VM_C_API void inline_gc(cell gc_roots, factor_vm *parent)
 {
-	parent->inline_gc(data_roots_base,data_roots_size);
+	parent->inline_gc(gc_roots);
 }
 
 /*
diff --git a/vm/gc.hpp b/vm/gc.hpp
index 5129ced909..39a69e34f4 100755
--- a/vm/gc.hpp
+++ b/vm/gc.hpp
@@ -52,6 +52,6 @@ struct gc_state {
 	void start_again(gc_op op_, factor_vm *parent);
 };
 
-VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent);
+VM_C_API void inline_gc(cell gc_roots, factor_vm *parent);
 
 }
diff --git a/vm/vm.hpp b/vm/vm.hpp
index 3b6fb2311f..bfe105e67d 100755
--- a/vm/vm.hpp
+++ b/vm/vm.hpp
@@ -320,7 +320,7 @@ struct factor_vm
 	void primitive_minor_gc();
 	void primitive_full_gc();
 	void primitive_compact_gc();
-	void inline_gc(cell *data_roots_base, cell data_roots_size);
+	void inline_gc(cell gc_roots);
 	void primitive_enable_gc_events();
 	void primitive_disable_gc_events();
 	object *allot_object(cell type, cell size);

From c55a6bb385f829cf2b7a7baa6ab507443be62317 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 28 Apr 2010 02:53:01 -0400
Subject: [PATCH 134/158] compiler.cfg.gc-checks: move phi instructions into GC
 check block, to ensure correct behavior

---
 .../cfg/gc-checks/gc-checks-tests.factor      | 56 ++++++++++++++++---
 basis/compiler/cfg/gc-checks/gc-checks.factor | 32 ++++++++---
 2 files changed, 70 insertions(+), 18 deletions(-)

diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor
index 7a148bc201..de5e35aaa4 100644
--- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor
+++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor
@@ -44,13 +44,12 @@ V{
         [ first ##check-nursery-branch? ]
     } 1&& ;
 
-[ t ] [ 100 <gc-check> gc-check? ] unit-test
+[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
 
-2 \ vreg-counter set-global
+4 \ vreg-counter set-global
 
 [
     V{
-        T{ ##save-context f 3 4 }
         T{ ##load-tagged f 5 0 }
         T{ ##replace f 5 D 0 }
         T{ ##replace f 5 R 3 }
@@ -93,7 +92,7 @@ V{
 
 [ ] [ cfg get needs-predecessors drop ] unit-test
 
-[ ] [ 31337 { D 1 R 2 } { 10 20 } 3 get (insert-gc-check) ] unit-test
+[ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test
 
 [ t ] [ 1 get successors>> first gc-check? ] unit-test
 
@@ -157,11 +156,10 @@ H{
 
 [
     V{
-        T{ ##save-context f 33 34 }
-        T{ ##load-tagged f 35 0 }
-        T{ ##replace f 35 D 0 }
-        T{ ##replace f 35 D 1 }
-        T{ ##replace f 35 D 2 }
+        T{ ##load-tagged f 31 0 }
+        T{ ##replace f 31 D 0 }
+        T{ ##replace f 31 D 1 }
+        T{ ##replace f 31 D 2 }
         T{ ##call-gc f { 2 } }
         T{ ##branch }
     }
@@ -169,3 +167,43 @@ H{
 
 ! Don't forget to invalidate RPO after inserting basic blocks!
 [ 8 ] [ cfg get reverse-post-order length ] unit-test
+
+! Do the right thing with ##phi instructions
+V{
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##load-reference f 1 "hi" }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-reference f 2 "bye" }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##phi f 3 }
+    T{ ##allot f 1 64 byte-array }
+    T{ ##branch }
+} 3 test-bb
+
+1 get 1 2array
+2 get 2 2array 2array 3 get instructions>> first (>>inputs)
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+H{
+    { 1 tagged-rep }
+    { 2 tagged-rep }
+    { 3 tagged-rep }
+} representations set
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
+[ 2 ] [ 3 get instructions>> length ] unit-test
diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor
index 737e956933..4d71bbe556 100644
--- a/basis/compiler/cfg/gc-checks/gc-checks.factor
+++ b/basis/compiler/cfg/gc-checks/gc-checks.factor
@@ -36,11 +36,17 @@ IN: compiler.cfg.gc-checks
 !   \      /
 !      bb
 
-: <gc-check> ( size -- bb )
-    [ <basic-block> ] dip
+! Any ##phi instructions at the start of bb are transplanted
+! into the gc-check block.
+
+: <gc-check> ( phis size -- bb )
+    [ <basic-block> ] 2dip
     [
-        cc<= int-rep next-vreg-rep int-rep next-vreg-rep
-        ##check-nursery-branch
+        [ % ]
+        [
+            cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+            ##check-nursery-branch
+        ] bi*
     ] V{ } make >>instructions ;
 
 : wipe-locs ( uninitialized-locs -- )
@@ -55,7 +61,7 @@ IN: compiler.cfg.gc-checks
     [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
     >>instructions t >>unlikely? ;
 
-:: insert-guard ( check body bb -- )
+:: insert-guard ( body check bb -- )
     bb predecessors>> check (>>predecessors)
     V{ bb body }      check (>>successors)
 
@@ -66,8 +72,8 @@ IN: compiler.cfg.gc-checks
 
     check predecessors>> [ bb check update-successors ] each ;
 
-: (insert-gc-check) ( size uninitialized-locs gc-roots bb -- )
-    [ [ <gc-check> ] 2dip <gc-call> ] dip insert-guard ;
+: (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
+    [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
 
 GENERIC: allocation-size* ( insn -- n )
 
@@ -82,14 +88,22 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
     [ ##allocation? ] filter
     [ allocation-size* data-alignment get align ] map-sum ;
 
+: gc-live-in ( bb -- vregs )
+    [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
+    append ;
+
 : live-tagged ( bb -- vregs )
-    live-in keys [ rep-of tagged-rep? ] filter ;
+    gc-live-in [ rep-of tagged-rep? ] filter ;
+
+: remove-phis ( bb -- phis )
+    [ [ ##phi? ] partition ] change-instructions drop ;
 
 : insert-gc-check ( bb -- )
     {
-        [ allocation-size ]
         [ uninitialized-locs ]
         [ live-tagged ]
+        [ remove-phis ]
+        [ allocation-size ]
         [ ]
     } cleave
     (insert-gc-check) ;

From d23bb19b55e4ae90428c363c1d58c93ad288e561 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 28 Apr 2010 02:53:08 -0400
Subject: [PATCH 135/158] Code cleanups

---
 .../compiler/cfg/representations/peephole/peephole.factor | 8 +++++---
 vm/layouts.hpp                                            | 2 --
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/basis/compiler/cfg/representations/peephole/peephole.factor b/basis/compiler/cfg/representations/peephole/peephole.factor
index 6c6347f11c..23e2e9c50c 100644
--- a/basis/compiler/cfg/representations/peephole/peephole.factor
+++ b/basis/compiler/cfg/representations/peephole/peephole.factor
@@ -94,9 +94,6 @@ M: ##load-reference optimize-insn
 ! Into either
 ! ##shl-imm by X - tag-bits, or
 ! ##sar-imm by tag-bits - X.
-: combine-shl-imm-input? ( insn -- ? )
-     ;
-
 : combine-shl-imm-input ( insn -- )
     [ dst>> ] [ src1>> ] [ src2>> ] tri tag-bits get {
         { [ 2dup < ] [ swap - ##sar-imm here ] }
@@ -232,6 +229,9 @@ M: ##compare-integer-branch optimize-insn
         [ call-next-method ]
     } cond ;
 
+! Identities:
+! tag(neg(untag(x))) = x
+! tag(neg(x)) = x * -2^tag-bits
 : inert-tag/untag-unary? ( insn -- ? )
     [ dst>> ] [ src>> ] bi [ rep-of tagged-rep? ] both? ;
 
@@ -252,6 +252,8 @@ M: ##neg optimize-insn
         [ call-next-method ]
     } cond ;
 
+! Identity:
+! tag(not(untag(x))) = not(x) xor tag-mask
 :: emit-tagged-not ( insn -- )
     tagged-rep next-vreg-rep :> temp
     temp insn src>> ##not
diff --git a/vm/layouts.hpp b/vm/layouts.hpp
index 0cf8607a05..5275c79612 100644
--- a/vm/layouts.hpp
+++ b/vm/layouts.hpp
@@ -91,8 +91,6 @@ inline static cell tag_fixnum(fixnum untagged)
 	return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
 }
 
-struct object;
-
 #define NO_TYPE_CHECK static const cell type_number = TYPE_COUNT
 
 struct object {

From 43fc230c69493023e297a55746141f18edbd4372 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 28 Apr 2010 03:35:46 -0400
Subject: [PATCH 136/158] compiler.cfg.linear-scan: cleanups

---
 .../build-stack-frame.factor                  |  2 +-
 .../cfg/instructions/instructions.factor      | 29 +++----
 .../linear-scan/allocation/allocation.factor  |  4 +-
 .../allocation/spilling/spilling.factor       | 14 ++--
 .../linear-scan/allocation/state/state.factor | 20 ++---
 .../linear-scan/assignment/assignment.factor  | 10 ++-
 .../cfg/linear-scan/linear-scan-tests.factor  | 82 ++++++++++++++-----
 .../live-intervals/live-intervals.factor      | 10 ++-
 .../linear-scan/resolve/resolve-tests.factor  | 24 +++---
 .../cfg/linear-scan/resolve/resolve.factor    |  8 +-
 basis/compiler/codegen/codegen.factor         |  5 +-
 11 files changed, 128 insertions(+), 80 deletions(-)

diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
index cb5e9aaf3d..49dfb95164 100644
--- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
+++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
@@ -39,7 +39,7 @@ M: insn compute-stack-frame*
     ] when ;
 
 ! PowerPC backend sets frame-required? for ##integer>float!
-\ _spill t frame-required? set-word-prop
+\ ##spill t frame-required? set-word-prop
 \ ##unary-float-function t frame-required? set-word-prop
 \ ##binary-float-function t frame-required? set-word-prop
 
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index db1496f147..5286fd861b 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -706,7 +706,22 @@ temp: temp1/int-rep temp2/int-rep ;
 INSN: ##call-gc
 literal: gc-roots ;
 
+! Spills and reloads, inserted by register allocator
+TUPLE: spill-slot { n integer } ;
+C: <spill-slot> spill-slot
+
+INSN: ##spill
+use: src
+literal: rep dst ;
+
+INSN: ##reload
+def: dst
+literal: rep src ;
+
 ! Instructions used by machine IR only.
+INSN: _spill-area-size
+literal: n ;
+
 INSN: _prologue
 literal: stack-frame ;
 
@@ -727,20 +742,6 @@ literal: label ;
 INSN: _conditional-branch
 literal: label insn ;
 
-TUPLE: spill-slot { n integer } ;
-C: <spill-slot> spill-slot
-
-INSN: _spill
-use: src
-literal: rep dst ;
-
-INSN: _reload
-def: dst
-literal: rep src ;
-
-INSN: _spill-area-size
-literal: n ;
-
 UNION: ##allocation
 ##allot
 ##box-alien
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 764e37786f..ed7690bd77 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -9,11 +9,11 @@ compiler.cfg.linear-scan.allocation.state ;
 IN: compiler.cfg.linear-scan.allocation
 
 : active-positions ( new assoc -- )
-    [ vreg>> active-intervals-for ] dip
+    [ active-intervals-for ] dip
     '[ [ 0 ] dip reg>> _ add-use-position ] each ;
 
 : inactive-positions ( new assoc -- )
-    [ [ vreg>> inactive-intervals-for ] keep ] dip
+    [ [ inactive-intervals-for ] keep ] dip
     '[
         [ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi
         _ add-use-position
diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
index a914aab4bf..fdba952d4a 100644
--- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
@@ -17,13 +17,13 @@ ERROR: bad-live-ranges interval ;
     ] [ drop ] if ;
 
 : trim-before-ranges ( live-interval -- )
-    [ ranges>> ] [ uses>> last n>> 1 + ] bi
+    [ ranges>> ] [ last-use n>> 1 + ] bi
     [ '[ from>> _ <= ] filter! drop ]
     [ swap last (>>to) ]
     2bi ;
 
 : trim-after-ranges ( live-interval -- )
-    [ ranges>> ] [ uses>> first n>> ] bi
+    [ ranges>> ] [ first-use n>> ] bi
     [ '[ to>> _ >= ] filter! drop ]
     [ swap first (>>from) ]
     2bi ;
@@ -73,12 +73,12 @@ ERROR: bad-live-ranges interval ;
     '[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
 
 : active-positions ( new assoc -- )
-    [ [ vreg>> active-intervals-for ] keep ] dip
+    [ [ active-intervals-for ] keep ] dip
     find-use-positions ;
 
 : inactive-positions ( new assoc -- )
     [
-        [ vreg>> inactive-intervals-for ] keep
+        [ inactive-intervals-for ] keep
         [ '[ _ intervals-intersect? ] filter ] keep
     ] dip
     find-use-positions ;
@@ -89,7 +89,7 @@ ERROR: bad-live-ranges interval ;
     >alist alist-max ;
 
 : spill-new? ( new pair -- ? )
-    [ uses>> first n>> ] [ second ] bi* > ;
+    [ first-use n>> ] [ second ] bi* > ;
 
 : spill-new ( new pair -- )
     drop spill-after add-unhandled ;
@@ -103,13 +103,13 @@ ERROR: bad-live-ranges interval ;
     ! If there is an active interval using 'reg' (there should be at
     ! most one) are split and spilled and removed from the inactive
     ! set.
-    new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
+    new active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
     '[ _ remove-nth! drop  new start>> spill ] [ 2drop ] if ;
 
 :: spill-intersecting-inactive ( new reg -- )
     ! Any inactive intervals using 'reg' are split and spilled
     ! and removed from the inactive set.
-    new vreg>> inactive-intervals-for [
+    new inactive-intervals-for [
         dup reg>> reg = [
             dup new intervals-intersect? [
                 new start>> spill f
diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
index 4c825c9d7c..06365b0ed2 100644
--- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
@@ -26,14 +26,14 @@ SYMBOL: registers
 ! Vector of active live intervals
 SYMBOL: active-intervals
 
-: active-intervals-for ( vreg -- seq )
-    rep-of reg-class-of active-intervals get at ;
+: active-intervals-for ( live-interval -- seq )
+    reg-class>> active-intervals get at ;
 
 : add-active ( live-interval -- )
-    dup vreg>> active-intervals-for push ;
+    dup active-intervals-for push ;
 
 : delete-active ( live-interval -- )
-    dup vreg>> active-intervals-for remove-eq! drop ;
+    dup active-intervals-for remove-eq! drop ;
 
 : assign-free-register ( new registers -- )
     pop >>reg add-active ;
@@ -41,14 +41,14 @@ SYMBOL: active-intervals
 ! Vector of inactive live intervals
 SYMBOL: inactive-intervals
 
-: inactive-intervals-for ( vreg -- seq )
-    rep-of reg-class-of inactive-intervals get at ;
+: inactive-intervals-for ( live-interval -- seq )
+    reg-class>> inactive-intervals get at ;
 
 : add-inactive ( live-interval -- )
-    dup vreg>> inactive-intervals-for push ;
+    dup inactive-intervals-for push ;
 
 : delete-inactive ( live-interval -- )
-    dup vreg>> inactive-intervals-for remove-eq! drop ;
+    dup inactive-intervals-for remove-eq! drop ;
 
 ! Vector of handled live intervals
 SYMBOL: handled-intervals
@@ -67,7 +67,7 @@ ERROR: register-already-used live-interval ;
 
 : check-activate ( live-interval -- )
     check-allocation? get [
-        dup [ reg>> ] [ vreg>> active-intervals-for [ reg>> ] map ] bi member?
+        dup [ reg>> ] [ active-intervals-for [ reg>> ] map ] bi member?
         [ register-already-used ] [ drop ] if
     ] [ drop ] if ;
 
@@ -148,7 +148,7 @@ SYMBOL: spill-slots
 
 ! A utility used by register-status and spill-status words
 : free-positions ( new -- assoc )
-    vreg>> rep-of reg-class-of registers get at
+    reg-class>> registers get at
     [ 1/0. ] H{ } <linked-assoc> map>assoc ;
 
 : add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 6cceea3303..7c0f38a44e 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -68,8 +68,10 @@ SYMBOL: register-live-outs
     H{ } clone register-live-outs set
     init-unhandled ;
 
+: spill-rep ( live-interval -- rep ) vreg>> rep-of ;
+
 : insert-spill ( live-interval -- )
-    [ reg>> ] [ vreg>> rep-of ] [ spill-to>> ] tri _spill ;
+    [ reg>> ] [ spill-rep ] [ spill-to>> ] tri ##spill ;
 
 : handle-spill ( live-interval -- )
     dup spill-to>> [ insert-spill ] [ drop ] if ;
@@ -88,15 +90,17 @@ SYMBOL: register-live-outs
 : expire-old-intervals ( n -- )
     pending-interval-heap get (expire-old-intervals) ;
 
+: reload-rep ( live-interval -- rep ) vreg>> rep-of ;
+
 : insert-reload ( live-interval -- )
-    [ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ;
+    [ reg>> ] [ reload-rep ] [ reload-from>> ] tri ##reload ;
 
 : insert-reload? ( live-interval -- ? )
     ! Don't insert a reload if the register will be written to
     ! before being read again.
     {
         [ reload-from>> ]
-        [ uses>> first type>> +use+ eq? ]
+        [ first-use type>> +use+ eq? ]
     } 1&& ;
 
 : handle-reload ( live-interval -- )
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 3bf7dd827c..a0f6b9f5c5 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -89,6 +89,7 @@ H{
 [
     T{ live-interval
        { vreg 1 }
+       { reg-class float-regs }
        { start 0 }
        { end 2 }
        { uses V{ T{ vreg-use f 0 } T{ vreg-use f 1 } } }
@@ -97,6 +98,7 @@ H{
     }
     T{ live-interval
        { vreg 1 }
+       { reg-class float-regs }
        { start 5 }
        { end 5 }
        { uses V{ T{ vreg-use f 5 } } }
@@ -106,6 +108,7 @@ H{
 ] [
     T{ live-interval
        { vreg 1 }
+       { reg-class float-regs }
        { start 0 }
        { end 5 }
        { uses V{ T{ vreg-use f 0 } T{ vreg-use f 1 } T{ vreg-use f 5 } } }
@@ -116,6 +119,7 @@ H{
 [
     T{ live-interval
        { vreg 2 }
+       { reg-class float-regs }
        { start 0 }
        { end 1 }
        { uses V{ T{ vreg-use f 0 } } }
@@ -124,6 +128,7 @@ H{
     }
     T{ live-interval
        { vreg 2 }
+       { reg-class float-regs }
        { start 1 }
        { end 5 }
        { uses V{ T{ vreg-use f 1 } T{ vreg-use f 5 } } }
@@ -133,6 +138,7 @@ H{
 ] [
     T{ live-interval
        { vreg 2 }
+       { reg-class float-regs }
        { start 0 }
        { end 5 }
        { uses V{ T{ vreg-use f 0 } T{ vreg-use f 1 } T{ vreg-use f 5 } } }
@@ -143,6 +149,7 @@ H{
 [
     T{ live-interval
        { vreg 3 }
+       { reg-class float-regs }
        { start 0 }
        { end 1 }
        { uses V{ T{ vreg-use f 0 } } }
@@ -151,6 +158,7 @@ H{
     }
     T{ live-interval
        { vreg 3 }
+       { reg-class float-regs }
        { start 20 }
        { end 30 }
        { uses V{ T{ vreg-use f 20 } T{ vreg-use f 30 } } }
@@ -160,6 +168,7 @@ H{
 ] [
     T{ live-interval
        { vreg 3 }
+       { reg-class float-regs }
        { start 0 }
        { end 30 }
        { uses V{ T{ vreg-use f 0 } T{ vreg-use f 20 } T{ vreg-use f 30 } } }
@@ -184,6 +193,7 @@ H{
           V{
               T{ live-interval
                  { vreg 1 }
+                 { reg-class int-regs }
                  { reg 1 }
                  { start 1 }
                  { end 15 }
@@ -191,6 +201,7 @@ H{
               }
               T{ live-interval
                  { vreg 2 }
+                 { reg-class int-regs }
                  { reg 2 }
                  { start 3 }
                  { end 8 }
@@ -198,6 +209,7 @@ H{
               }
               T{ live-interval
                  { vreg 3 }
+                 { reg-class int-regs }
                  { reg 3 }
                  { start 3 }
                  { end 10 }
@@ -209,6 +221,7 @@ H{
     H{ } inactive-intervals set
     T{ live-interval
         { vreg 1 }
+        { reg-class int-regs }
         { start 5 }
         { end 5 }
         { uses V{ T{ vreg-use f 5 } } }
@@ -227,6 +240,7 @@ H{
           V{
               T{ live-interval
                  { vreg 1 }
+                 { reg-class int-regs }
                  { reg 1 }
                  { start 1 }
                  { end 15 }
@@ -234,6 +248,7 @@ H{
               }
               T{ live-interval
                  { vreg 2 }
+                 { reg-class int-regs }
                  { reg 2 }
                  { start 3 }
                  { end 8 }
@@ -245,6 +260,7 @@ H{
     H{ } inactive-intervals set
     T{ live-interval
         { vreg 3 }
+        { reg-class int-regs }
         { start 5 }
         { end 5 }
         { uses V{ T{ vreg-use f 5 } } }
@@ -258,6 +274,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
     {
         T{ live-interval
            { vreg 1 }
+           { reg-class int-regs }
            { start 0 }
            { end 100 }
            { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
@@ -272,6 +289,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
     {
         T{ live-interval
            { vreg 1 }
+           { reg-class int-regs }
            { start 0 }
            { end 10 }
            { uses V{ T{ vreg-use f 0 } T{ vreg-use f 10 } } }
@@ -279,6 +297,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
         }
         T{ live-interval
            { vreg 2 }
+           { reg-class int-regs }
            { start 11 }
            { end 20 }
            { uses V{ T{ vreg-use f 11 } T{ vreg-use f 20 } } }
@@ -293,6 +312,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
     {
         T{ live-interval
            { vreg 1 }
+           { reg-class int-regs }
            { start 0 }
            { end 100 }
            { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
@@ -300,6 +320,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
         }
         T{ live-interval
            { vreg 2 }
+           { reg-class int-regs }
            { start 30 }
            { end 60 }
            { uses V{ T{ vreg-use f 30 } T{ vreg-use f 60 } } }
@@ -314,6 +335,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
     {
         T{ live-interval
            { vreg 1 }
+           { reg-class int-regs }
            { start 0 }
            { end 100 }
            { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
@@ -321,6 +343,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
         }
         T{ live-interval
            { vreg 2 }
+           { reg-class int-regs }
            { start 30 }
            { end 200 }
            { uses V{ T{ vreg-use f 30 } T{ vreg-use f 200 } } }
@@ -335,6 +358,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
     {
         T{ live-interval
            { vreg 1 }
+           { reg-class int-regs }
            { start 0 }
            { end 100 }
            { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
@@ -342,6 +366,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
         }
         T{ live-interval
            { vreg 2 }
+           { reg-class int-regs }
            { start 30 }
            { end 100 }
            { uses V{ T{ vreg-use f 30 } T{ vreg-use f 100 } } }
@@ -365,6 +390,7 @@ H{
     {
         T{ live-interval
            { vreg 1 }
+           { reg-class int-regs }
            { start 0 }
            { end 20 }
            { uses V{ T{ vreg-use f 0 } T{ vreg-use f 10 } T{ vreg-use f 20 } } }
@@ -372,6 +398,7 @@ H{
         }
         T{ live-interval
            { vreg 2 }
+           { reg-class int-regs }
            { start 0 }
            { end 20 }
            { uses V{ T{ vreg-use f 0 } T{ vreg-use f 10 } T{ vreg-use f 20 } } }
@@ -379,6 +406,7 @@ H{
         }
         T{ live-interval
            { vreg 3 }
+           { reg-class int-regs }
            { start 4 }
            { end 8 }
            { uses V{ T{ vreg-use f 6 } } }
@@ -386,6 +414,7 @@ H{
         }
         T{ live-interval
            { vreg 4 }
+           { reg-class int-regs }
            { start 4 }
            { end 8 }
            { uses V{ T{ vreg-use f 8 } } }
@@ -395,6 +424,7 @@ H{
         ! This guy will invoke the 'spill partially available' code path
         T{ live-interval
            { vreg 5 }
+           { reg-class int-regs }
            { start 4 }
            { end 8 }
            { uses V{ T{ vreg-use f 8 } } }
@@ -411,6 +441,7 @@ H{
     {
         T{ live-interval
            { vreg 1 }
+           { reg-class int-regs }
            { start 0 }
            { end 10 }
            { uses V{ T{ vreg-use f 0 } T{ vreg-use f 6 } T{ vreg-use f 10 } } }
@@ -420,6 +451,7 @@ H{
         ! This guy will invoke the 'spill new' code path
         T{ live-interval
            { vreg 5 }
+           { reg-class int-regs }
            { start 2 }
            { end 8 }
            { uses V{ T{ vreg-use f 8 } } }
@@ -491,12 +523,14 @@ H{
 [ 5 ] [
     T{ live-interval
        { start 0 }
+       { reg-class int-regs }
        { end 10 }
        { uses { 0 10 } }
        { ranges V{ T{ live-range f 0 10 } } }
     }
     T{ live-interval
        { start 5 }
+       { reg-class int-regs }
        { end 10 }
        { uses { 5 10 } }
        { ranges V{ T{ live-range f 5 10 } } }
@@ -520,6 +554,7 @@ H{
           {
               T{ live-interval
                  { vreg 1 }
+                 { reg-class int-regs }
                  { start 0 }
                  { end 20 }
                  { reg 0 }
@@ -529,6 +564,7 @@ H{
 
               T{ live-interval
                  { vreg 2 }
+                 { reg-class int-regs }
                  { start 4 }
                  { end 40 }
                  { reg 0 }
@@ -543,6 +579,7 @@ H{
           {
               T{ live-interval
                  { vreg 3 }
+                 { reg-class int-regs }
                  { start 0 }
                  { end 40 }
                  { reg 1 }
@@ -554,7 +591,8 @@ H{
     } active-intervals set
 
     T{ live-interval
-       { vreg 4 }
+        { vreg 4 }
+        { reg-class int-regs }
         { start 8 }
         { end 10 }
         { ranges V{ T{ live-range f 8 10 } } }
@@ -924,13 +962,13 @@ test-diamond
 
 [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
 
-[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test
+[ ##spill ] [ 2 get successors>> first instructions>> first class ] unit-test
 
-[ _spill ] [ 3 get instructions>> second class ] unit-test
+[ ##spill ] [ 3 get instructions>> second class ] unit-test
 
-[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test
+[ f ] [ 3 get instructions>> [ ##reload? ] any? ] unit-test
 
-[ _reload ] [ 4 get instructions>> first class ] unit-test
+[ ##reload ] [ 4 get instructions>> first class ] unit-test
 
 ! Resolve pass
 V{
@@ -978,11 +1016,11 @@ V{
 
 [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
 
-[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
+[ t ] [ 2 get instructions>> [ ##spill? ] any? ] unit-test
 
-[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test
+[ t ] [ 3 get predecessors>> first instructions>> [ ##spill? ] any? ] unit-test
 
-[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
+[ t ] [ 5 get instructions>> [ ##reload? ] any? ] unit-test
 
 ! A more complicated failure case with resolve that came up after the above
 ! got fixed
@@ -1041,13 +1079,13 @@ V{
 
 [ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
 
-[ _spill ] [ 1 get instructions>> second class ] unit-test
-[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
-[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ dst>> n>> cell / ] map ] unit-test
-[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ src>> n>> cell / ] map ] unit-test
+[ ##spill ] [ 1 get instructions>> second class ] unit-test
+[ ##reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
+[ V{ 3 2 1 } ] [ 8 get instructions>> [ ##spill? ] filter [ dst>> n>> cell / ] map ] unit-test
+[ V{ 3 2 1 } ] [ 9 get instructions>> [ ##reload? ] filter [ src>> n>> cell / ] map ] unit-test
 
 ! Resolve pass should insert this
-[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
+[ ##reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
 
 ! Some random bug
 V{
@@ -1397,13 +1435,13 @@ test-diamond
 
 [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
 
-[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
+[ 0 ] [ 1 get instructions>> [ ##spill? ] count ] unit-test
 
-[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
+[ 1 ] [ 2 get instructions>> [ ##spill? ] count ] unit-test
 
-[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test
+[ 1 ] [ 3 get predecessors>> first instructions>> [ ##spill? ] count ] unit-test
 
-[ 1 ] [ 4 get instructions>> [ _reload? ] 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
@@ -1435,12 +1473,12 @@ test-diamond
 
 [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
 
-[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
+[ 0 ] [ 1 get instructions>> [ ##spill? ] count ] unit-test
 
-[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
+[ 1 ] [ 2 get instructions>> [ ##spill? ] count ] unit-test
 
-[ 1 ] [ 2 get instructions>> [ _reload? ] count ] unit-test
+[ 1 ] [ 2 get instructions>> [ ##reload? ] count ] unit-test
 
-[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
+[ 0 ] [ 3 get instructions>> [ ##spill? ] count ] unit-test
 
-[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
+[ 0 ] [ 4 get instructions>> [ ##reload? ] count ] unit-test
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index da079da0e4..62b23ddde9 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -3,7 +3,7 @@
 USING: namespaces kernel assocs accessors sequences math math.order fry
 combinators binary-search compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.linearization.order
-compiler.cfg ;
+compiler.cfg cpu.architecture ;
 IN: compiler.cfg.linear-scan.live-intervals
 
 TUPLE: live-range from to ;
@@ -19,7 +19,12 @@ C: <vreg-use> vreg-use
 TUPLE: live-interval
 vreg
 reg spill-to reload-from
-start end ranges uses ;
+start end ranges uses
+reg-class ;
+
+: first-use ( live-interval -- use ) uses>> first ; inline
+
+: last-use ( live-interval -- use ) uses>> last ; inline
 
 GENERIC: covers? ( insn# obj -- ? )
 
@@ -66,6 +71,7 @@ M: live-interval covers? ( insn# live-interval -- ? )
     \ live-interval new
         V{ } clone >>uses
         V{ } clone >>ranges
+        over rep-of reg-class-of >>reg-class
         swap >>vreg ;
 
 : block-from ( bb -- n ) instructions>> first insn#>> 1 - ;
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index f16c608293..7aff066e0b 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -20,7 +20,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
 
 [
     {
-        T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
+        T{ ##reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
     }
 ] [
     [
@@ -32,7 +32,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
 
 [
     {
-        T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
+        T{ ##spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
     }
 ] [
     [
@@ -66,8 +66,8 @@ IN: compiler.cfg.linear-scan.resolve.tests
 
 [
     {
-        T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 0 } } }
-        T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 1 } } }
+        T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 0 } } }
+        T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 1 } } }
         T{ ##branch }
     }
 ] [
@@ -80,8 +80,8 @@ IN: compiler.cfg.linear-scan.resolve.tests
 
 [
     {
-        T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
-        T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+        T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
+        T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
         T{ ##branch }
     }
 ] [
@@ -94,8 +94,8 @@ IN: compiler.cfg.linear-scan.resolve.tests
 
 [
     {
-        T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
-        T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+        T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
+        T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
         T{ ##branch }
     }
 ] [
@@ -116,15 +116,15 @@ H{ } clone spill-temps set
     }
     mapping-instructions {
         {
-            T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
+            T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
             T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
-            T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
+            T{ ##reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
             T{ ##branch }
         }
         {
-            T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
+            T{ ##spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
             T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
-            T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
+            T{ ##reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
             T{ ##branch }
         }
     } member?
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index b450145bd4..02c08d5c39 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -51,16 +51,16 @@ SYMBOL: spill-temps
     ] if ;
 
 : memory->register ( from to -- )
-    swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* _reload ;
+    swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* ##reload ;
 
 : register->memory ( from to -- )
-    [ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* _spill ;
+    [ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* ##spill ;
 
 : temp->register ( from to -- )
-    nip [ reg>> ] [ rep>> ] [ rep>> spill-temp ] tri _reload ;
+    nip [ reg>> ] [ rep>> ] [ rep>> spill-temp ] tri ##reload ;
 
 : register->temp ( from to -- )
-    drop [ [ reg>> ] [ rep>> ] bi ] [ rep>> spill-temp ] bi _spill ;
+    drop [ [ reg>> ] [ rep>> ] bi ] [ rep>> spill-temp ] bi ##spill ;
 
 : register->register ( from to -- )
     swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 3a101092b2..2d0cfa8289 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -200,7 +200,8 @@ CODEGEN: ##vm-field %vm-field
 CODEGEN: ##set-vm-field %set-vm-field
 CODEGEN: ##alien-global %alien-global
 CODEGEN: ##call-gc %call-gc
-
+CODEGEN: ##spill %spill
+CODEGEN: ##reload %reload
 CODEGEN: ##dispatch %dispatch
 
 : %dispatch-label ( label -- )
@@ -210,8 +211,6 @@ CODEGEN: ##dispatch %dispatch
 CODEGEN: _label resolve-label
 CODEGEN: _dispatch-label %dispatch-label
 CODEGEN: _branch %jump-label
-CODEGEN: _spill %spill
-CODEGEN: _reload %reload
 CODEGEN: _loop-entry %loop-entry
 
 GENERIC: generate-conditional-insn ( label insn -- )

From 9b34a4a054991935921b1d52120fd44b8723f2f6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 28 Apr 2010 04:47:38 -0400
Subject: [PATCH 137/158] compiler.cfg: remove unused 'reps' slot from
 compiler.cfg, and re-organize things in preparation for SSA register
 allocation

---
 .../compiler/cfg/builder/builder-tests.factor |   3 +-
 basis/compiler/cfg/cfg.factor                 |   2 +-
 basis/compiler/cfg/checker/checker.factor     |   5 +-
 basis/compiler/cfg/debugger/debugger.factor   |   9 +-
 basis/compiler/cfg/finalization/authors.txt   |   1 +
 .../cfg/finalization/finalization.factor      |  14 +++
 .../allocation/spilling/spilling.factor       |   6 +-
 .../linear-scan/allocation/state/state.factor |  14 ++-
 .../linear-scan/assignment/assignment.factor  |  14 +--
 .../cfg/linear-scan/linear-scan-tests.factor  |  67 +++++------
 .../live-intervals/live-intervals.factor      | 109 ++++++++++--------
 basis/compiler/cfg/mr/mr.factor               |   7 +-
 basis/compiler/cfg/optimizer/optimizer.factor |  18 +--
 .../representations/representations.factor    |   5 +-
 .../cfg/ssa/destruction/destruction.factor    |  18 ++-
 basis/compiler/compiler.factor                |   3 +-
 basis/compiler/tests/low-level-ir.factor      |  10 +-
 17 files changed, 172 insertions(+), 133 deletions(-)
 create mode 100644 basis/compiler/cfg/finalization/authors.txt
 create mode 100644 basis/compiler/cfg/finalization/finalization.factor

diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index 792b5d0902..9ed7c592ce 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -5,7 +5,8 @@ compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
 compiler.cfg arrays locals byte-arrays kernel.private math
 slots.private vectors sbufs strings math.partial-dispatch
 hashtables assocs combinators.short-circuit
-strings.private accessors compiler.cfg.instructions ;
+strings.private accessors compiler.cfg.instructions
+compiler.cfg.representations ;
 FROM: alien.c-types => int ;
 IN: compiler.cfg.builder.tests
 
diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 9568217e9c..1391c37077 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -21,7 +21,7 @@ number
 M: basic-block hashcode* nip id>> ;
 
 TUPLE: cfg { entry basic-block } word label
-spill-area-size reps
+spill-area-size
 post-order linear-order
 predecessors-valid? dominance-valid? loops-valid? ;
 
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index cb840a299d..b84742b8b0 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -3,7 +3,8 @@
 USING: kernel combinators.short-circuit accessors math sequences
 sets assocs compiler.cfg.instructions compiler.cfg.rpo
 compiler.cfg.def-use compiler.cfg.linearization
-compiler.cfg.utilities compiler.cfg.mr compiler.utilities ;
+compiler.cfg.utilities compiler.cfg.finalization compiler.cfg.mr
+compiler.utilities ;
 IN: compiler.cfg.checker
 
 ! Check invariants
@@ -64,5 +65,5 @@ ERROR: undefined-values uses defs ;
 
 : check-cfg ( cfg -- )
     [ [ check-basic-block ] each-basic-block ]
-    [ build-mr check-mr ]
+    [ finalize-cfg build-mr check-mr ]
     bi ;
diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index d4e8c5401a..9aa81a1b0d 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -7,10 +7,10 @@ prettyprint.sections parser compiler.tree.builder
 compiler.tree.optimizer cpu.architecture compiler.cfg.builder
 compiler.cfg.linearization compiler.cfg.registers
 compiler.cfg.stack-frame compiler.cfg.linear-scan
-compiler.cfg.optimizer compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.def-use compiler.cfg.rpo
-compiler.cfg.mr compiler.cfg.representations.preferred
-compiler.cfg ;
+compiler.cfg.optimizer compiler.cfg.finalization
+compiler.cfg.instructions compiler.cfg.utilities
+compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
+compiler.cfg.representations.preferred compiler.cfg ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -27,6 +27,7 @@ M: word test-cfg
     test-cfg [
         [
             optimize-cfg
+            finalize-cfg
             build-mr
         ] with-cfg
     ] map ;
diff --git a/basis/compiler/cfg/finalization/authors.txt b/basis/compiler/cfg/finalization/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/finalization/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor
new file mode 100644
index 0000000000..93a9a07e3d
--- /dev/null
+++ b/basis/compiler/cfg/finalization/finalization.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg.empty-blocks compiler.cfg.gc-checks
+compiler.cfg.linear-scan compiler.cfg.representations
+compiler.cfg.save-contexts compiler.cfg.ssa.destruction ;
+IN: compiler.cfg.finalization
+
+: finalize-cfg ( cfg -- cfg' )
+    select-representations
+    insert-gc-checks
+    insert-save-contexts
+    destruct-ssa
+    delete-empty-blocks
+    linear-scan ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
index fdba952d4a..19b0f6c5b9 100644
--- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
@@ -29,7 +29,8 @@ ERROR: bad-live-ranges interval ;
     2bi ;
 
 : assign-spill ( live-interval -- )
-    dup vreg>> vreg-spill-slot >>spill-to drop ;
+    dup [ vreg>> ] [ last-use rep>> ] bi
+    assign-spill-slot >>spill-to drop ;
 
 : spill-before ( before -- before/f )
     ! If the interval does not have any usages before the spill location,
@@ -46,7 +47,8 @@ ERROR: bad-live-ranges interval ;
     ] if ;
 
 : assign-reload ( live-interval -- )
-    dup vreg>> vreg-spill-slot >>reload-from drop ;
+    dup [ vreg>> ] [ first-use rep>> ] bi
+    assign-spill-slot >>reload-from drop ;
 
 : spill-after ( after -- after/f )
     ! If the interval has no more usages after the spill location,
diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
index 06365b0ed2..7626ac9554 100644
--- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
@@ -1,9 +1,10 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators cpu.architecture fry heaps
-kernel math math.order namespaces sequences vectors
+USING: arrays accessors assocs combinators cpu.architecture fry
+heaps kernel math math.order namespaces sequences vectors
 linked-assocs compiler.cfg compiler.cfg.registers
-compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ;
+compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals ;
 IN: compiler.cfg.linear-scan.allocation.state
 
 ! Start index of current live interval. We ensure that all
@@ -127,8 +128,11 @@ SYMBOL: unhandled-sync-points
 ! Mapping from vregs to spill slots
 SYMBOL: spill-slots
 
-: vreg-spill-slot ( vreg -- spill-slot )
-    spill-slots get [ rep-of next-spill-slot ] cache ;
+: assign-spill-slot ( coalesced-vreg rep -- spill-slot )
+    spill-slots get [ nip next-spill-slot ] 2cache ;
+
+: lookup-spill-slot ( coalesced-vreg rep -- spill-slot )
+    2array spill-slots get ?at [ ] [ bad-vreg ] 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 7c0f38a44e..5f1a50f178 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -31,10 +31,12 @@ SYMBOL: pending-interval-assoc
 
 ERROR: bad-vreg vreg ;
 
-: (vreg>reg) ( vreg pending -- reg )
+:: (vreg>reg) ( vreg pending -- reg )
     ! If a live vreg is not in the pending set, then it must
     ! have been spilled.
-    ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ;
+    vreg pending at* [
+        drop vreg vreg rep-of lookup-spill-slot
+    ] unless ;
 
 : vreg>reg ( vreg -- reg )
     pending-interval-assoc get (vreg>reg) ;
@@ -68,10 +70,8 @@ SYMBOL: register-live-outs
     H{ } clone register-live-outs set
     init-unhandled ;
 
-: spill-rep ( live-interval -- rep ) vreg>> rep-of ;
-
 : insert-spill ( live-interval -- )
-    [ reg>> ] [ spill-rep ] [ spill-to>> ] tri ##spill ;
+    [ reg>> ] [ first-use rep>> ] [ spill-to>> ] tri ##spill ;
 
 : handle-spill ( live-interval -- )
     dup spill-to>> [ insert-spill ] [ drop ] if ;
@@ -90,10 +90,8 @@ SYMBOL: register-live-outs
 : expire-old-intervals ( n -- )
     pending-interval-heap get (expire-old-intervals) ;
 
-: reload-rep ( live-interval -- rep ) vreg>> rep-of ;
-
 : insert-reload ( live-interval -- )
-    [ reg>> ] [ reload-rep ] [ reload-from>> ] tri ##reload ;
+    [ reg>> ] [ first-use rep>> ] [ reload-from>> ] tri ##reload ;
 
 : insert-reload? ( live-interval -- ? )
     ! Don't insert a reload if the register will be written to
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index a0f6b9f5c5..6d479c9daa 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -92,7 +92,7 @@ H{
        { reg-class float-regs }
        { start 0 }
        { end 2 }
-       { uses V{ T{ vreg-use f 0 } T{ vreg-use f 1 } } }
+       { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } } }
        { ranges V{ T{ live-range f 0 2 } } }
        { spill-to T{ spill-slot f 0 } }
     }
@@ -101,7 +101,7 @@ H{
        { reg-class float-regs }
        { start 5 }
        { end 5 }
-       { uses V{ T{ vreg-use f 5 } } }
+       { uses V{ T{ vreg-use f float-rep 5 } } }
        { ranges V{ T{ live-range f 5 5 } } }
        { reload-from T{ spill-slot f 0 } }
     }
@@ -111,7 +111,7 @@ H{
        { reg-class float-regs }
        { start 0 }
        { end 5 }
-       { uses V{ T{ vreg-use f 0 } T{ vreg-use f 1 } T{ vreg-use f 5 } } }
+       { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
        { ranges V{ T{ live-range f 0 5 } } }
     } 2 split-for-spill
 ] unit-test
@@ -122,7 +122,7 @@ H{
        { reg-class float-regs }
        { start 0 }
        { end 1 }
-       { uses V{ T{ vreg-use f 0 } } }
+       { uses V{ T{ vreg-use f float-rep 0 } } }
        { ranges V{ T{ live-range f 0 1 } } }
        { spill-to T{ spill-slot f 4 } }
     }
@@ -131,7 +131,7 @@ H{
        { reg-class float-regs }
        { start 1 }
        { end 5 }
-       { uses V{ T{ vreg-use f 1 } T{ vreg-use f 5 } } }
+       { uses V{ T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
        { ranges V{ T{ live-range f 1 5 } } }
        { reload-from T{ spill-slot f 4 } }
     }
@@ -141,7 +141,7 @@ H{
        { reg-class float-regs }
        { start 0 }
        { end 5 }
-       { uses V{ T{ vreg-use f 0 } T{ vreg-use f 1 } T{ vreg-use f 5 } } }
+       { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 1 } T{ vreg-use f float-rep 5 } } }
        { ranges V{ T{ live-range f 0 5 } } }
     } 0 split-for-spill
 ] unit-test
@@ -152,7 +152,7 @@ H{
        { reg-class float-regs }
        { start 0 }
        { end 1 }
-       { uses V{ T{ vreg-use f 0 } } }
+       { uses V{ T{ vreg-use f float-rep 0 } } }
        { ranges V{ T{ live-range f 0 1 } } }
        { spill-to T{ spill-slot f 8 } }
     }
@@ -161,7 +161,7 @@ H{
        { reg-class float-regs }
        { start 20 }
        { end 30 }
-       { uses V{ T{ vreg-use f 20 } T{ vreg-use f 30 } } }
+       { uses V{ T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } }
        { ranges V{ T{ live-range f 20 30 } } }
        { reload-from T{ spill-slot f 8 } }
     }
@@ -171,7 +171,7 @@ H{
        { reg-class float-regs }
        { start 0 }
        { end 30 }
-       { uses V{ T{ vreg-use f 0 } T{ vreg-use f 20 } T{ vreg-use f 30 } } }
+       { uses V{ T{ vreg-use f float-rep 0 } T{ vreg-use f float-rep 20 } T{ vreg-use f float-rep 30 } } }
        { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
     } 10 split-for-spill
 ] unit-test
@@ -197,7 +197,7 @@ H{
                  { reg 1 }
                  { start 1 }
                  { end 15 }
-                 { uses V{ T{ vreg-use f 1 } T{ vreg-use f 3 } T{ vreg-use f 7 } T{ vreg-use f 10 } T{ vreg-use f 15 } } }
+                 { uses V{ T{ vreg-use f int-rep 1 } T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 7 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 15 } } }
               }
               T{ live-interval
                  { vreg 2 }
@@ -205,7 +205,7 @@ H{
                  { reg 2 }
                  { start 3 }
                  { end 8 }
-                 { uses V{ T{ vreg-use f 3 } T{ vreg-use f 4 } T{ vreg-use f 8 } } }
+                 { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 4 } T{ vreg-use f int-rep 8 } } }
               }
               T{ live-interval
                  { vreg 3 }
@@ -213,7 +213,7 @@ H{
                  { reg 3 }
                  { start 3 }
                  { end 10 }
-                 { uses V{ T{ vreg-use f 3 } T{ vreg-use f 10 } } }
+                 { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 10 } } }
               }
           }
         }
@@ -224,7 +224,7 @@ H{
         { reg-class int-regs }
         { start 5 }
         { end 5 }
-        { uses V{ T{ vreg-use f 5 } } }
+        { uses V{ T{ vreg-use f int-rep 5 } } }
     }
     spill-status
 ] unit-test
@@ -244,7 +244,7 @@ H{
                  { reg 1 }
                  { start 1 }
                  { end 15 }
-                 { uses V{ T{ vreg-use f 1 } } }
+                 { uses V{ T{ vreg-use f int-rep 1 } } }
               }
               T{ live-interval
                  { vreg 2 }
@@ -252,7 +252,7 @@ H{
                  { reg 2 }
                  { start 3 }
                  { end 8 }
-                 { uses V{ T{ vreg-use f 3 } T{ vreg-use f 8 } } }
+                 { uses V{ T{ vreg-use f int-rep 3 } T{ vreg-use f int-rep 8 } } }
               }
           }
         }
@@ -263,7 +263,7 @@ H{
         { reg-class int-regs }
         { start 5 }
         { end 5 }
-        { uses V{ T{ vreg-use f 5 } } }
+        { uses V{ T{ vreg-use f int-rep 5 } } }
     }
     spill-status
 ] unit-test
@@ -277,7 +277,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { reg-class int-regs }
            { start 0 }
            { end 100 }
-           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
+           { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
            { ranges V{ T{ live-range f 0 100 } } }
         }
     }
@@ -292,7 +292,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { reg-class int-regs }
            { start 0 }
            { end 10 }
-           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 10 } } }
+           { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } } }
            { ranges V{ T{ live-range f 0 10 } } }
         }
         T{ live-interval
@@ -300,7 +300,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { reg-class int-regs }
            { start 11 }
            { end 20 }
-           { uses V{ T{ vreg-use f 11 } T{ vreg-use f 20 } } }
+           { uses V{ T{ vreg-use f int-rep 11 } T{ vreg-use f int-rep 20 } } }
            { ranges V{ T{ live-range f 11 20 } } }
         }
     }
@@ -315,7 +315,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { reg-class int-regs }
            { start 0 }
            { end 100 }
-           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
+           { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
            { ranges V{ T{ live-range f 0 100 } } }
         }
         T{ live-interval
@@ -323,7 +323,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { reg-class int-regs }
            { start 30 }
            { end 60 }
-           { uses V{ T{ vreg-use f 30 } T{ vreg-use f 60 } } }
+           { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 60 } } }
            { ranges V{ T{ live-range f 30 60 } } }
         }
     }
@@ -338,7 +338,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { reg-class int-regs }
            { start 0 }
            { end 100 }
-           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
+           { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
            { ranges V{ T{ live-range f 0 100 } } }
         }
         T{ live-interval
@@ -346,7 +346,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { reg-class int-regs }
            { start 30 }
            { end 200 }
-           { uses V{ T{ vreg-use f 30 } T{ vreg-use f 200 } } }
+           { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 200 } } }
            { ranges V{ T{ live-range f 30 200 } } }
         }
     }
@@ -361,7 +361,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { reg-class int-regs }
            { start 0 }
            { end 100 }
-           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 100 } } }
+           { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 100 } } }
            { ranges V{ T{ live-range f 0 100 } } }
         }
         T{ live-interval
@@ -369,7 +369,7 @@ H{ { 1 int-rep } { 2 int-rep } } representations set
            { reg-class int-regs }
            { start 30 }
            { end 100 }
-           { uses V{ T{ vreg-use f 30 } T{ vreg-use f 100 } } }
+           { uses V{ T{ vreg-use f int-rep 30 } T{ vreg-use f int-rep 100 } } }
            { ranges V{ T{ live-range f 30 100 } } }
         }
     }
@@ -393,7 +393,7 @@ H{
            { reg-class int-regs }
            { start 0 }
            { end 20 }
-           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 10 } T{ vreg-use f 20 } } }
+           { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } }
            { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
         }
         T{ live-interval
@@ -401,7 +401,7 @@ H{
            { reg-class int-regs }
            { start 0 }
            { end 20 }
-           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 10 } T{ vreg-use f 20 } } }
+           { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 10 } T{ vreg-use f int-rep 20 } } }
            { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
         }
         T{ live-interval
@@ -409,7 +409,7 @@ H{
            { reg-class int-regs }
            { start 4 }
            { end 8 }
-           { uses V{ T{ vreg-use f 6 } } }
+           { uses V{ T{ vreg-use f int-rep 6 } } }
            { ranges V{ T{ live-range f 4 8 } } }
         }
         T{ live-interval
@@ -417,7 +417,7 @@ H{
            { reg-class int-regs }
            { start 4 }
            { end 8 }
-           { uses V{ T{ vreg-use f 8 } } }
+           { uses V{ T{ vreg-use f int-rep 8 } } }
            { ranges V{ T{ live-range f 4 8 } } }
         }
 
@@ -427,7 +427,7 @@ H{
            { reg-class int-regs }
            { start 4 }
            { end 8 }
-           { uses V{ T{ vreg-use f 8 } } }
+           { uses V{ T{ vreg-use f int-rep 8 } } }
            { ranges V{ T{ live-range f 4 8 } } }
         }
     }
@@ -444,7 +444,7 @@ H{
            { reg-class int-regs }
            { start 0 }
            { end 10 }
-           { uses V{ T{ vreg-use f 0 } T{ vreg-use f 6 } T{ vreg-use f 10 } } }
+           { uses V{ T{ vreg-use f int-rep 0 } T{ vreg-use f int-rep 6 } T{ vreg-use f int-rep 10 } } }
            { ranges V{ T{ live-range f 0 10 } } }
         }
 
@@ -454,7 +454,7 @@ H{
            { reg-class int-regs }
            { start 2 }
            { end 8 }
-           { uses V{ T{ vreg-use f 8 } } }
+           { uses V{ T{ vreg-use f int-rep 8 } } }
            { ranges V{ T{ live-range f 2 8 } } }
         }
     }
@@ -596,7 +596,7 @@ H{
         { start 8 }
         { end 10 }
         { ranges V{ T{ live-range f 8 10 } } }
-        { uses V{ T{ vreg-use f 8 } T{ vreg-use f 10 } } }
+        { uses V{ T{ vreg-use f int-rep 8 } T{ vreg-use f int-rep 10 } } }
     }
     register-status
 ] unit-test
@@ -783,6 +783,7 @@ V{
     T{ ##copy
        { dst 689607 }
        { src 689604 }
+       { rep int-rep }
     }
     T{ ##copy
        { dst 689608 }
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index 62b23ddde9..596ac610f0 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -1,9 +1,12 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs accessors sequences math math.order fry
-combinators binary-search compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.linearization.order
-compiler.cfg cpu.architecture ;
+USING: namespaces kernel assocs accessors locals sequences math
+math.order fry combinators binary-search
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.def-use compiler.cfg.liveness
+compiler.cfg.linearization.order
+compiler.cfg
+cpu.architecture ;
 IN: compiler.cfg.linear-scan.live-intervals
 
 TUPLE: live-range from to ;
@@ -12,7 +15,7 @@ C: <live-range> live-range
 
 SYMBOLS: +def+ +use+ +memory+ ;
 
-TUPLE: vreg-use n type ;
+TUPLE: vreg-use rep n type ;
 
 C: <vreg-use> vreg-use
 
@@ -61,62 +64,75 @@ M: live-interval covers? ( insn# live-interval -- ? )
     2dup extend-range?
     [ extend-range ] [ add-new-range ] if ;
 
-: add-use ( insn live-interval type -- )
-    dup +memory+ eq? [ 3drop ] [
-        swap [ [ insn#>> ] dip <vreg-use> ] dip
-        uses>> push
-    ] if ;
+:: add-use ( rep n type live-interval -- )
+    type +memory+ eq? [
+        rep n type <vreg-use>
+        live-interval uses>> push
+    ] unless ;
 
-: <live-interval> ( vreg -- live-interval )
+: <live-interval> ( vreg reg-class -- live-interval )
     \ live-interval new
         V{ } clone >>uses
         V{ } clone >>ranges
-        over rep-of reg-class-of >>reg-class
+        swap >>reg-class
         swap >>vreg ;
 
 : block-from ( bb -- n ) instructions>> first insn#>> 1 - ;
 
 : block-to ( bb -- n ) instructions>> last insn#>> ;
 
+SYMBOLS: from to ;
+
 ! Mapping from vreg to live-interval
 SYMBOL: live-intervals
 
 : live-interval ( vreg -- live-interval )
-    live-intervals get [ <live-interval> ] cache ;
+    live-intervals get [ dup rep-of reg-class-of <live-interval> ] cache ;
 
 GENERIC: compute-live-intervals* ( insn -- )
 
 M: insn compute-live-intervals* drop ;
 
-: handle-output ( insn vreg type -- )
-    [ live-interval ] dip
-    [ drop [ insn#>> ] dip shorten-range ] [ add-use ] 3bi ;
+:: handle-output ( vreg n type -- )
+    vreg rep-of :> rep
+    vreg live-interval :> live-interval
 
-: handle-input ( insn vreg type -- )
-    [ live-interval ] dip
-    [ drop [ [ basic-block get block-from ] dip insn#>> ] dip add-range ]
-    [ add-use ]
-    3bi ;
+    n live-interval shorten-range
+    rep n type live-interval add-use ;
 
-: handle-temp ( insn vreg -- )
-    live-interval
-    [ [ insn#>> dup ] dip add-range ] [ +def+ add-use ] 2bi ;
+:: handle-input ( vreg n type -- )
+    vreg rep-of :> rep
+    vreg live-interval :> live-interval
 
-M: vreg-insn compute-live-intervals*
-    [ dup defs-vreg [ +def+ handle-output ] with when* ]
-    [ dup uses-vregs [ +use+ handle-input ] with each ]
-    [ dup temp-vregs [ handle-temp ] with each ]
-    tri ;
+    from get n live-interval add-range
+    rep n type live-interval add-use ;
 
-M: clobber-insn compute-live-intervals*
-    [ dup defs-vreg [ +use+ handle-output ] with when* ]
-    [ dup uses-vregs [ +memory+ handle-input ] with each ]
-    [ dup temp-vregs [ handle-temp ] with each ]
-    tri ;
+:: handle-temp ( vreg n -- )
+    vreg rep-of :> rep
+    vreg live-interval :> live-interval
+
+    n n live-interval add-range
+    rep n +def+ live-interval add-use ;
+
+M:: vreg-insn compute-live-intervals* ( insn -- )
+    insn insn#>> :> n
+
+    insn defs-vreg [ n +def+ handle-output ] when*
+    insn uses-vregs [ n +use+ handle-input ] each
+    insn temp-vregs [ n handle-temp ] each ;
+
+M:: clobber-insn compute-live-intervals* ( insn -- )
+    insn insn#>> :> n
+
+    insn defs-vreg [ n +use+ handle-output ] when*
+    insn uses-vregs [ n +memory+ handle-input ] each
+    insn temp-vregs [ n handle-temp ] each ;
 
 : handle-live-out ( bb -- )
-    [ block-from ] [ block-to ] [ live-out keys ] tri
-    [ live-interval add-range ] with with each ;
+    live-out dup assoc-empty? [ drop ] [
+        [ from get to get ] dip keys
+        [ live-interval add-range ] with with each
+    ] if ;
 
 ! A location where all registers have to be spilled
 TUPLE: sync-point n ;
@@ -134,15 +150,18 @@ M: clobber-insn compute-sync-points*
 M: insn compute-sync-points* drop ;
 
 : compute-live-intervals-step ( bb -- )
-    [ basic-block set ]
-    [ handle-live-out ]
-    [
-        instructions>> <reversed> [
-            [ compute-live-intervals* ]
-            [ compute-sync-points* ]
-            bi
-        ] each
-    ] tri ;
+    {
+        [ block-from from set ]
+        [ block-to to set ]
+        [ handle-live-out ]
+        [
+            instructions>> <reversed> [
+                [ compute-live-intervals* ]
+                [ compute-sync-points* ]
+                bi
+            ] each
+        ]
+    } cleave ;
 
 : init-live-intervals ( -- )
     H{ } clone live-intervals set
diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor
index 140fba8d4e..5b9e9ee2c3 100644
--- a/basis/compiler/cfg/mr/mr.factor
+++ b/basis/compiler/cfg/mr/mr.factor
@@ -1,11 +1,8 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces accessors compiler.cfg
-compiler.cfg.linearization compiler.cfg.linear-scan
-compiler.cfg.build-stack-frame ;
+USING: compiler.cfg.linearization compiler.cfg.build-stack-frame ;
 IN: compiler.cfg.mr
 
 : build-mr ( cfg -- mr )
-    linear-scan
     flatten-cfg
     build-stack-frame ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index e6cd65f4b5..ca1886bcd6 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -1,7 +1,6 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors combinators namespaces
-compiler.cfg.tco
+USING: compiler.cfg.tco
 compiler.cfg.useless-conditionals
 compiler.cfg.branch-splitting
 compiler.cfg.block-joining
@@ -19,13 +18,6 @@ compiler.cfg.empty-blocks
 compiler.cfg.checker ;
 IN: compiler.cfg.optimizer
 
-SYMBOL: check-optimizer?
-
-: ?check ( cfg -- cfg' )
-    check-optimizer? get [
-        dup check-cfg
-    ] when ;
-
 : optimize-cfg ( cfg -- cfg' )
     optimize-tail-calls
     delete-useless-conditionals
@@ -36,10 +28,4 @@ SYMBOL: check-optimizer?
     value-numbering
     copy-propagation
     eliminate-dead-code
-    eliminate-write-barriers
-    select-representations
-    insert-gc-checks
-    insert-save-contexts
-    destruct-ssa
-    delete-empty-blocks
-    ?check ;
+    eliminate-write-barriers ;
diff --git a/basis/compiler/cfg/representations/representations.factor b/basis/compiler/cfg/representations/representations.factor
index 100da7a53f..2160ad26e6 100644
--- a/basis/compiler/cfg/representations/representations.factor
+++ b/basis/compiler/cfg/representations/representations.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009, 2010 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators namespaces
+USING: combinators
 compiler.cfg
 compiler.cfg.registers
 compiler.cfg.predecessors
@@ -26,5 +26,4 @@ IN: compiler.cfg.representations
         [ compute-representations ]
         [ insert-conversions ]
         [ ]
-    } cleave
-    representations get cfg get (>>reps) ;
+    } cleave ;
diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor
index 83413067b7..03252dce0d 100644
--- a/basis/compiler/cfg/ssa/destruction/destruction.factor
+++ b/basis/compiler/cfg/ssa/destruction/destruction.factor
@@ -23,6 +23,11 @@ SYMBOL: leader-map
 
 : leader ( vreg -- vreg' ) leader-map get compress-path ;
 
+! Maps basic blocks to ##phi instruction outputs
+SYMBOL: phi-sets
+
+: phi-set ( bb -- vregs ) phi-sets get at ;
+
 ! Maps leaders to equivalence class elements.
 SYMBOL: class-element-map
 
@@ -102,16 +107,25 @@ M: ##copy rename-insn
     [ call-next-method drop ]
     [ [ dst>> ] [ src>> ] bi eq? not ] bi ;
 
-M: ##phi rename-insn drop f ;
+SYMBOL: current-phi-set
+
+M: ##phi rename-insn dst>> current-phi-set get push f ;
 
 M: ##call-gc rename-insn
     [ renamings get '[ _ at ] map members ] change-gc-roots drop t ;
 
 M: insn rename-insn drop t ;
 
+: renaming-in-block ( bb -- )
+    V{ } clone current-phi-set set
+    [ [ current-phi-set ] dip phi-sets get set-at ]
+    [ instructions>> [ rename-insn ] filter! drop ]
+    bi ;
+
 : perform-renaming ( cfg -- )
+    H{ } clone phi-sets set
     leader-map get keys [ dup leader ] H{ } map>assoc renamings set
-    [ instructions>> [ rename-insn ] filter! drop ] each-basic-block ;
+    [ renaming-in-block ] each-basic-block ;
 
 : destruct-ssa ( cfg -- cfg' )
     needs-dominance
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index 71fdd6cbaf..9bc473e330 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -16,6 +16,7 @@ compiler.tree.optimizer
 compiler.cfg
 compiler.cfg.builder
 compiler.cfg.optimizer
+compiler.cfg.finalization
 compiler.cfg.mr
 
 compiler.codegen ;
@@ -125,7 +126,7 @@ M: word combinator? inline? ;
 
 : backend ( tree word -- )
     build-cfg [
-        [ optimize-cfg build-mr ] with-cfg
+        [ optimize-cfg finalize-cfg build-mr ] with-cfg
         [ generate ] [ label>> ] bi compiled get set-at
     ] each ;
 
diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index 57612e730e..5cba592163 100644
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -1,20 +1,20 @@
 USING: accessors assocs compiler compiler.cfg
 compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr
-compiler.cfg.registers compiler.codegen compiler.units
-cpu.architecture hashtables kernel namespaces sequences
-tools.test vectors words layouts literals math arrays
+compiler.cfg.registers compiler.cfg.linear-scan compiler.codegen
+compiler.units cpu.architecture hashtables kernel namespaces
+sequences tools.test vectors words layouts literals math arrays
 alien.c-types alien.syntax math.private ;
 IN: compiler.tests.low-level-ir
 
 : compile-cfg ( cfg -- word )
     gensym
-    [ build-mr generate ] dip
+    [ linear-scan build-mr generate ] dip
     [ associate >alist t t modify-code-heap ] keep ;
 
 : compile-test-cfg ( -- word )
     cfg new 0 get >>entry
     dup cfg set
-    dup fake-representations representations get >>reps
+    dup fake-representations
     compile-cfg ;
 
 : compile-test-bb ( insns -- result )

From 43f269e4eb505154b05978fe3b9831c7c9bf343f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 28 Apr 2010 05:03:12 -0400
Subject: [PATCH 138/158] Register allocation now uses SSA properties to
 coalesce values with different representations

---
 .../cfg/finalization/finalization.factor      |  1 -
 .../linear-scan/allocation/state/state.factor |  2 +
 .../linear-scan/assignment/assignment.factor  | 74 +++++++++-------
 .../cfg/linear-scan/linear-scan.factor        |  6 +-
 .../live-intervals/live-intervals.factor      | 30 ++++---
 .../cfg/linear-scan/resolve/resolve.factor    | 21 +++--
 .../cfg/liveness/ssa/ssa-tests.factor         | 65 ++++++++++++++
 basis/compiler/cfg/liveness/ssa/ssa.factor    | 12 +--
 .../cfg/ssa/destruction/destruction.factor    | 86 ++++++++++---------
 basis/cpu/x86/32/32.factor                    |  3 +-
 10 files changed, 199 insertions(+), 101 deletions(-)
 create mode 100644 basis/compiler/cfg/liveness/ssa/ssa-tests.factor

diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor
index 93a9a07e3d..24097d63a4 100644
--- a/basis/compiler/cfg/finalization/finalization.factor
+++ b/basis/compiler/cfg/finalization/finalization.factor
@@ -10,5 +10,4 @@ IN: compiler.cfg.finalization
     insert-gc-checks
     insert-save-contexts
     destruct-ssa
-    delete-empty-blocks
     linear-scan ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
index 7626ac9554..8bdd6231b5 100644
--- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
@@ -129,9 +129,11 @@ SYMBOL: unhandled-sync-points
 SYMBOL: spill-slots
 
 : assign-spill-slot ( coalesced-vreg rep -- spill-slot )
+    dup tagged-rep? [ drop int-rep ] when
     spill-slots get [ nip next-spill-slot ] 2cache ;
 
 : lookup-spill-slot ( coalesced-vreg rep -- spill-slot )
+    dup tagged-rep? [ drop int-rep ] when
     2array spill-slots get ?at [ ] [ bad-vreg ] if ;
 
 : init-allocator ( registers -- )
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 5f1a50f178..f457713380 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -6,8 +6,10 @@ cpu.architecture layouts
 compiler.cfg
 compiler.cfg.def-use
 compiler.cfg.liveness
+compiler.cfg.liveness.ssa
 compiler.cfg.registers
 compiler.cfg.instructions
+compiler.cfg.ssa.destruction
 compiler.cfg.renaming.functor
 compiler.cfg.linearization.order
 compiler.cfg.linear-scan.allocation
@@ -29,23 +31,16 @@ SYMBOL: pending-interval-assoc
 : remove-pending ( live-interval -- )
     vreg>> pending-interval-assoc get delete-at ;
 
-ERROR: bad-vreg vreg ;
-
-:: (vreg>reg) ( vreg pending -- reg )
+:: vreg>reg ( vreg -- reg )
     ! If a live vreg is not in the pending set, then it must
     ! have been spilled.
-    vreg pending at* [
-        drop vreg vreg rep-of lookup-spill-slot
+    vreg leader :> leader
+    leader pending-interval-assoc get at* [
+        drop leader vreg rep-of lookup-spill-slot
     ] unless ;
 
-: vreg>reg ( vreg -- reg )
-    pending-interval-assoc get (vreg>reg) ;
-
 : vregs>regs ( vregs -- assoc )
-    dup assoc-empty? [
-        pending-interval-assoc get
-        '[ _ (vreg>reg) ] assoc-map
-    ] unless ;
+    [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ;
 
 ! Minheap of live intervals which still need a register allocation
 SYMBOL: unhandled-intervals
@@ -56,18 +51,45 @@ SYMBOL: unhandled-intervals
 : init-unhandled ( live-intervals -- )
     [ add-unhandled ] each ;
 
+! Liveness info is used by resolve pass
+
 ! Mapping from basic blocks to values which are live at the start
-SYMBOL: register-live-ins
+! on all incoming CFG edges
+SYMBOL: machine-live-ins
+
+: machine-live-in ( bb -- assoc )
+    machine-live-ins get at ;
+
+: compute-live-in ( bb -- )
+    [ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
+
+! Mapping from basic blocks to predecessors to values which are
+! live on a particular incoming edge
+SYMBOL: machine-edge-live-ins
+
+: machine-edge-live-in ( predecessor bb -- assoc )
+    machine-edge-live-ins get at at ;
+
+: compute-edge-live-in ( bb -- )
+    [ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
+    machine-edge-live-ins get set-at ;
 
 ! Mapping from basic blocks to values which are live at the end
-SYMBOL: register-live-outs
+SYMBOL: machine-live-outs
+
+: machine-live-out ( bb -- assoc )
+    machine-live-outs get at ;
+
+: compute-live-out ( bb -- )
+    [ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
 
 : init-assignment ( live-intervals -- )
     <min-heap> pending-interval-heap set
     H{ } clone pending-interval-assoc set
     <min-heap> unhandled-intervals set
-    H{ } clone register-live-ins set
-    H{ } clone register-live-outs set
+    H{ } clone machine-live-ins set
+    H{ } clone machine-edge-live-ins set
+    H{ } clone machine-live-outs set
     init-unhandled ;
 
 : insert-spill ( live-interval -- )
@@ -135,18 +157,12 @@ M: ##call-gc assign-registers-in-insn
 M: insn assign-registers-in-insn drop ;
 
 : begin-block ( bb -- )
-    dup basic-block set
-    dup block-from activate-new-intervals
-    [ live-in vregs>regs ] keep register-live-ins get set-at ;
-
-: end-block ( bb -- )
-    [ live-out vregs>regs ] keep register-live-outs get set-at ;
-
-: vreg-at-start ( vreg bb -- state )
-    register-live-ins get at ?at [ bad-vreg ] unless ;
-
-: vreg-at-end ( vreg bb -- state )
-    register-live-outs get at ?at [ bad-vreg ] unless ;
+    {
+        [ basic-block set ]
+        [ block-from activate-new-intervals ]
+        [ compute-edge-live-in ]
+        [ compute-live-in ]
+    } cleave ;
 
 :: assign-registers-in-block ( bb -- )
     bb [
@@ -160,7 +176,7 @@ M: insn assign-registers-in-insn drop ;
                     [ , ]
                 } cleave
             ] each
-            bb end-block
+            bb compute-live-out
         ] V{ } make
     ] change-instructions drop ;
 
diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index 5e723f098a..7657937d33 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -1,10 +1,9 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces make locals
 cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
-compiler.cfg.liveness
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.linear-scan.numbering
@@ -29,8 +28,9 @@ IN: compiler.cfg.linear-scan
 ! by Omri Traub, Glenn Holloway, Michael D. Smith
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
 
+! SSA liveness must have been computed already
+
 :: (linear-scan) ( cfg machine-registers -- )
-    cfg compute-live-sets
     cfg number-instructions
     cfg compute-live-intervals machine-registers allocate-registers
     cfg assign-registers
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index 596ac610f0..9766bb62d1 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -2,9 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel assocs accessors locals sequences math
 math.order fry combinators binary-search
-compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.def-use compiler.cfg.liveness
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.def-use
+compiler.cfg.liveness
 compiler.cfg.linearization.order
+compiler.cfg.ssa.destruction
 compiler.cfg
 cpu.architecture ;
 IN: compiler.cfg.linear-scan.live-intervals
@@ -43,7 +46,7 @@ M: live-interval covers? ( insn# live-interval -- ? )
         [ drop ] [ [ from>> <=> ] with search nip ] 2bi
         covers?
     ] if ;
-        
+
 : add-new-range ( from to live-interval -- )
     [ <live-range> ] dip ranges>> push ;
 
@@ -87,27 +90,28 @@ SYMBOLS: from to ;
 SYMBOL: live-intervals
 
 : live-interval ( vreg -- live-interval )
-    live-intervals get [ dup rep-of reg-class-of <live-interval> ] cache ;
+    leader live-intervals get
+    [ dup rep-of reg-class-of <live-interval> ] cache ;
 
 GENERIC: compute-live-intervals* ( insn -- )
 
 M: insn compute-live-intervals* drop ;
 
-:: handle-output ( vreg n type -- )
+:: record-def ( vreg n type -- )
     vreg rep-of :> rep
     vreg live-interval :> live-interval
 
     n live-interval shorten-range
     rep n type live-interval add-use ;
 
-:: handle-input ( vreg n type -- )
+:: record-use ( vreg n type -- )
     vreg rep-of :> rep
     vreg live-interval :> live-interval
 
     from get n live-interval add-range
     rep n type live-interval add-use ;
 
-:: handle-temp ( vreg n -- )
+:: record-temp ( vreg n -- )
     vreg rep-of :> rep
     vreg live-interval :> live-interval
 
@@ -117,16 +121,16 @@ M: insn compute-live-intervals* drop ;
 M:: vreg-insn compute-live-intervals* ( insn -- )
     insn insn#>> :> n
 
-    insn defs-vreg [ n +def+ handle-output ] when*
-    insn uses-vregs [ n +use+ handle-input ] each
-    insn temp-vregs [ n handle-temp ] each ;
+    insn defs-vreg [ n +def+ record-def ] when*
+    insn uses-vregs [ n +use+ record-use ] each
+    insn temp-vregs [ n record-temp ] each ;
 
 M:: clobber-insn compute-live-intervals* ( insn -- )
     insn insn#>> :> n
 
-    insn defs-vreg [ n +use+ handle-output ] when*
-    insn uses-vregs [ n +memory+ handle-input ] each
-    insn temp-vregs [ n handle-temp ] each ;
+    insn defs-vreg [ n +use+ record-def ] when*
+    insn uses-vregs [ n +memory+ record-use ] each
+    insn temp-vregs [ n record-temp ] each ;
 
 : handle-live-out ( bb -- )
     live-out dup assoc-empty? [ drop ] [
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index 02c08d5c39..9964389ce6 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -12,6 +12,7 @@ compiler.cfg.utilities
 compiler.cfg.instructions
 compiler.cfg.predecessors
 compiler.cfg.parallel-copy
+compiler.cfg.ssa.destruction
 compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.allocation.state ;
 IN: compiler.cfg.linear-scan.resolve
@@ -40,14 +41,22 @@ SYMBOL: spill-temps
 : add-mapping ( from to rep -- )
     '[ _ <location> ] bi@ 2array , ;
 
-:: resolve-value-data-flow ( bb to vreg -- )
-    vreg bb vreg-at-end
-    vreg to vreg-at-start
+:: resolve-value-data-flow ( vreg live-out live-in edge-live-in -- )
+    vreg live-out ?at [ bad-vreg ] unless
+    vreg live-in ?at [ edge-live-in ?at [ bad-vreg ] unless ] unless
     2dup = [ 2drop ] [ vreg rep-of add-mapping ] if ;
 
-: compute-mappings ( bb to -- mappings )
-    dup live-in dup assoc-empty? [ 3drop f ] [
-        [ keys [ resolve-value-data-flow ] with with each ] { } make
+:: compute-mappings ( bb to -- mappings )
+    bb machine-live-out :> live-out
+    to machine-live-in :> live-in
+    bb to machine-edge-live-in :> edge-live-in
+    live-out assoc-empty? [ f ] [
+        [
+            live-in keys edge-live-in keys append [
+                live-out live-in edge-live-in
+                resolve-value-data-flow
+            ] each
+        ] { } make
     ] if ;
 
 : memory->register ( from to -- )
diff --git a/basis/compiler/cfg/liveness/ssa/ssa-tests.factor b/basis/compiler/cfg/liveness/ssa/ssa-tests.factor
new file mode 100644
index 0000000000..945d49272c
--- /dev/null
+++ b/basis/compiler/cfg/liveness/ssa/ssa-tests.factor
@@ -0,0 +1,65 @@
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.liveness.ssa
+compiler.cfg.liveness arrays sequences assocs
+compiler.cfg.registers kernel namespaces tools.test ;
+IN: compiler.cfg.liveness.ssa.tests
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##load-integer f 0 0 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##load-integer f 1 1 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##phi f 2 }
+    T{ ##branch }
+} 4 test-bb
+
+2 get 0 2array
+3 get 1 2array 2array
+4 get instructions>> first (>>inputs)
+
+V{
+    T{ ##branch }
+} 5 test-bb
+
+V{
+    T{ ##replace f 2 D 0 }
+    T{ ##branch }
+} 6 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 7 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 { 5 6 } edges
+5 6 edge
+6 7 edge
+
+[ ] [ cfg new 0 get >>entry dup cfg set compute-ssa-live-sets ] unit-test
+
+[ t ] [ 0 get live-in assoc-empty? ] unit-test
+
+[ H{ { 2 2 } } ] [ 4 get live-out ] unit-test
+
+[ H{ { 0 0 } } ] [ 2 get 4 get edge-live-in ] unit-test
+
+[ H{ { 1 1 } } ] [ 3 get 4 get edge-live-in ] unit-test
diff --git a/basis/compiler/cfg/liveness/ssa/ssa.factor b/basis/compiler/cfg/liveness/ssa/ssa.factor
index 3e54333265..84428514aa 100644
--- a/basis/compiler/cfg/liveness/ssa/ssa.factor
+++ b/basis/compiler/cfg/liveness/ssa/ssa.factor
@@ -11,9 +11,9 @@ IN: compiler.cfg.liveness.ssa
 
 ! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
 ! is in correspondence with a predecessor
-SYMBOL: phi-live-ins
+SYMBOL: edge-live-ins
 
-: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
+: edge-live-in ( predecessor basic-block -- set ) edge-live-ins get at at ;
 
 SYMBOL: work-list
 
@@ -23,19 +23,19 @@ SYMBOL: work-list
 : compute-live-in ( basic-block -- live-in )
     [ live-out ] keep instructions>> transfer-liveness ;
 
-: compute-phi-live-in ( basic-block -- phi-live-in )
+: compute-edge-live-in ( basic-block -- edge-live-in )
     H{ } clone [
         '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each-phi
     ] keep ;
 
 : update-live-in ( basic-block -- changed? )
     [ [ compute-live-in ] keep live-ins get maybe-set-at ]
-    [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
+    [ [ compute-edge-live-in ] keep edge-live-ins get maybe-set-at ]
     bi or ;
 
 : compute-live-out ( basic-block -- live-out )
     [ successors>> [ live-in ] map ]
-    [ dup successors>> [ phi-live-in ] with map ] bi
+    [ dup successors>> [ edge-live-in ] with map ] bi
     append assoc-combine ;
 
 : update-live-out ( basic-block -- changed? )
@@ -53,7 +53,7 @@ SYMBOL: work-list
 
     <hashed-dlist> work-list set
     H{ } clone live-ins set
-    H{ } clone phi-live-ins set
+    H{ } clone edge-live-ins set
     H{ } clone live-outs set
     post-order add-to-work-list
     work-list get [ liveness-step ] slurp-deque ;
diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor
index 03252dce0d..eea64eec07 100644
--- a/basis/compiler/cfg/ssa/destruction/destruction.factor
+++ b/basis/compiler/cfg/ssa/destruction/destruction.factor
@@ -3,9 +3,9 @@
 USING: accessors arrays assocs fry kernel namespaces
 sequences sequences.deep
 sets vectors
+cpu.architecture
 compiler.cfg.rpo
 compiler.cfg.def-use
-compiler.cfg.renaming
 compiler.cfg.registers
 compiler.cfg.dominance
 compiler.cfg.instructions
@@ -18,27 +18,38 @@ compiler.utilities ;
 FROM: namespaces => set ;
 IN: compiler.cfg.ssa.destruction
 
-! Maps vregs to leaders.
+! Because of the design of the register allocator, this pass
+! has three peculiar properties.
+!
+! 1) Instead of renaming vreg usages in the CFG, a map from
+! vregs to canonical representatives is computed. This allows
+! the register allocator to use the original SSA names to get
+! reaching definitions.
+! 2) Useless ##copy instructions, and all ##phi instructions,
+! are eliminated, so the register allocator does not have to
+! remove any redundant operations.
+! 3) A side effect of running this pass is that SSA liveness
+! information is computed, so the register allocator does not
+! need to compute it again.
+
 SYMBOL: leader-map
 
 : leader ( vreg -- vreg' ) leader-map get compress-path ;
 
-! Maps basic blocks to ##phi instruction outputs
-SYMBOL: phi-sets
-
-: phi-set ( bb -- vregs ) phi-sets get at ;
-
 ! Maps leaders to equivalence class elements.
 SYMBOL: class-element-map
 
 : class-elements ( vreg -- elts ) class-element-map get at ;
 
+<PRIVATE
+
 ! Sequence of vreg pairs
 SYMBOL: copies
 
 : init-coalescing ( -- )
-    H{ } clone leader-map set
-    H{ } clone class-element-map set
+    defs get keys
+    [ [ dup ] H{ } map>assoc leader-map set ]
+    [ [ dup 1vector ] H{ } map>assoc class-element-map set ] bi
     V{ } clone copies set ;
 
 : classes-interfere? ( vreg1 vreg2 -- ? )
@@ -61,25 +72,27 @@ SYMBOL: copies
         2bi
     ] if ;
 
-: introduce-vreg ( vreg -- )
-    [ leader-map get conjoin ]
-    [ [ 1vector ] keep class-element-map get set-at ] bi ;
-
 GENERIC: prepare-insn ( insn -- )
 
 : try-to-coalesce ( dst src -- ) 2array copies get push ;
 
 M: insn prepare-insn
-    [ defs-vreg ] [ uses-vregs ] bi
-    2dup empty? not and [
-        first
-        2dup [ rep-of ] bi@ eq?
-        [ try-to-coalesce ] [ 2drop ] if
-    ] [ 2drop ] if ;
+    [ temp-vregs [ leader-map get conjoin ] each ]
+    [
+        [ defs-vreg ] [ uses-vregs ] bi
+        2dup empty? not and [
+            first
+            2dup [ rep-of ] bi@ eq?
+            [ try-to-coalesce ] [ 2drop ] if
+        ] [ 2drop ] if
+    ] bi ;
 
 M: ##copy prepare-insn
     [ dst>> ] [ src>> ] bi try-to-coalesce ;
 
+M: ##tagged>integer prepare-insn
+    [ dst>> ] [ src>> ] bi eliminate-copy ;
+
 M: ##phi prepare-insn
     [ dst>> ] [ inputs>> values ] bi
     [ eliminate-copy ] with each ;
@@ -89,7 +102,6 @@ M: ##phi prepare-insn
 
 : prepare-coalescing ( cfg -- )
     init-coalescing
-    defs get keys [ introduce-vreg ] each
     [ prepare-block ] each-basic-block ;
 
 : process-copies ( -- )
@@ -98,34 +110,26 @@ M: ##phi prepare-insn
         [ 2drop ] [ eliminate-copy ] if
     ] assoc-each ;
 
-GENERIC: rename-insn ( insn -- keep? )
+GENERIC: useful-insn? ( insn -- ? )
 
-M: vreg-insn rename-insn
-    [ rename-insn-defs ] [ rename-insn-uses ] bi t ;
+: useful-copy? ( insn -- ? )
+    [ dst>> leader ] [ src>> leader ] bi eq? not ; inline
 
-M: ##copy rename-insn
-    [ call-next-method drop ]
-    [ [ dst>> ] [ src>> ] bi eq? not ] bi ;
+M: ##copy useful-insn? useful-copy? ;
 
-SYMBOL: current-phi-set
+M: ##tagged>integer useful-insn? useful-copy? ;
 
-M: ##phi rename-insn dst>> current-phi-set get push f ;
+M: ##phi useful-insn? drop f ;
 
-M: ##call-gc rename-insn
-    [ renamings get '[ _ at ] map members ] change-gc-roots drop t ;
+M: insn useful-insn? drop t ;
 
-M: insn rename-insn drop t ;
+: cleanup-block ( bb -- )
+    instructions>> [ useful-insn? ] filter! drop ;
 
-: renaming-in-block ( bb -- )
-    V{ } clone current-phi-set set
-    [ [ current-phi-set ] dip phi-sets get set-at ]
-    [ instructions>> [ rename-insn ] filter! drop ]
-    bi ;
+: cleanup-cfg ( cfg -- )
+    [ cleanup-block ] each-basic-block ;
 
-: perform-renaming ( cfg -- )
-    H{ } clone phi-sets set
-    leader-map get keys [ dup leader ] H{ } map>assoc renamings set
-    [ renaming-in-block ] each-basic-block ;
+PRIVATE>
 
 : destruct-ssa ( cfg -- cfg' )
     needs-dominance
@@ -136,4 +140,4 @@ M: insn rename-insn drop t ;
     dup compute-live-ranges
     dup prepare-coalescing
     process-copies
-    dup perform-renaming ;
+    dup cleanup-cfg ;
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 225e62dc0e..79ff4b1e35 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -346,8 +346,7 @@ M: x86.32 %cleanup ( params -- )
 
 M:: x86.32 %call-gc ( gc-roots -- )
     4 save-vm-ptr
-    EAX gc-roots gc-root-offsets %load-reference
-    0 stack@ EAX MOV
+    0 stack@ gc-roots gc-root-offsets %load-reference
     "inline_gc" f %alien-invoke ;
 
 M: x86.32 dummy-stack-params? f ;

From 33eb15bf44a06c4f00b31d2b43ce8269c6de87bc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Apr 2010 05:33:17 -0400
Subject: [PATCH 139/158] compiler.cfg.debugger: clean up and make it more
 flexible

---
 basis/compiler/cfg/debugger/debugger.factor | 67 +++++++++++++++------
 basis/typed/debugger/debugger.factor        | 15 +++--
 basis/typed/typed.factor                    |  1 +
 extra/compiler/graphviz/graphviz.factor     |  4 +-
 4 files changed, 58 insertions(+), 29 deletions(-)

diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 9aa81a1b0d..8cbd23db02 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -10,21 +10,45 @@ compiler.cfg.stack-frame compiler.cfg.linear-scan
 compiler.cfg.optimizer compiler.cfg.finalization
 compiler.cfg.instructions compiler.cfg.utilities
 compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
-compiler.cfg.representations.preferred compiler.cfg ;
+compiler.cfg.representations
+compiler.cfg.representations.preferred
+compiler.cfg.gc-checks compiler.cfg.save-contexts compiler.cfg ;
 IN: compiler.cfg.debugger
 
-GENERIC: test-cfg ( quot -- cfgs )
+GENERIC: test-builder ( quot -- cfgs )
 
-M: callable test-cfg
+M: callable test-builder
     0 vreg-counter set-global
     build-tree optimize-tree gensym build-cfg ;
 
-M: word test-cfg
+M: word test-builder
     0 vreg-counter set-global
     [ build-tree optimize-tree ] keep build-cfg ;
 
-: test-mr ( quot -- mrs )
-    test-cfg [
+: test-optimizer ( quot -- cfgs )
+    test-builder [ [ optimize-cfg ] with-cfg ] map ;
+
+: test-ssa ( quot -- mrs )
+    test-builder [
+        [
+            optimize-cfg
+            flatten-cfg
+        ] with-cfg
+    ] map ;
+
+: test-flat ( quot -- mrs )
+    test-builder [
+        [
+            optimize-cfg
+            select-representations
+            insert-gc-checks
+            insert-save-contexts
+            flatten-cfg
+        ] with-cfg
+    ] map ;
+
+: test-regs ( quot -- mrs )
+    test-builder [
         [
             optimize-cfg
             finalize-cfg
@@ -32,21 +56,26 @@ M: word test-cfg
         ] with-cfg
     ] map ;
 
-: insn. ( insn -- )
-    tuple>array but-last [ pprint bl ] each nl ;
+GENERIC: insn. ( insn -- )
 
-: mr. ( mrs -- )
-    [
-        "=== word: " write
-        dup word>> pprint
-        ", label: " write
-        dup label>> pprint nl nl
-        instructions>> [ insn. ] each
-        nl
-    ] each ;
+M: ##phi insn.
+    clone [ [ [ number>> ] dip ] assoc-map ] change-inputs
+    call-next-method ;
 
-: test-mr. ( quot -- )
-    test-mr mr. ; inline
+M: insn insn. tuple>array but-last [ bl ] [ pprint ] interleave nl ;
+
+: mr. ( mr -- )
+    "=== word: " write
+    dup word>> pprint
+    ", label: " write
+    dup label>> pprint nl nl
+    instructions>> [ insn. ] each ;
+
+: mrs. ( mrs -- )
+    [ nl ] [ mr. ] interleave ;
+
+: flat. ( quot -- ) test-flat mrs. ; inline
+: regs. ( quot -- ) test-regs mrs. ; inline
 
 ! Prettyprinting
 : pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
diff --git a/basis/typed/debugger/debugger.factor b/basis/typed/debugger/debugger.factor
index dae30fa9d8..98a083a2ba 100644
--- a/basis/typed/debugger/debugger.factor
+++ b/basis/typed/debugger/debugger.factor
@@ -3,12 +3,11 @@ USING: typed compiler.cfg.debugger compiler.tree.debugger
 tools.disassembler words ;
 IN: typed.debugger
 
-: typed-test-mr ( word -- mrs )
-    "typed-word" word-prop test-mr ; inline
-: typed-test-mr. ( word -- )
-    "typed-word" word-prop test-mr mr. ; inline
-: typed-optimized. ( word -- )
-    "typed-word" word-prop optimized. ; inline
+M: typed-word test-builder
+    "typed-word" word-prop test-builder ;
 
-: typed-disassemble ( word -- )
-    "typed-word" word-prop disassemble ; inline
+: typed-optimized. ( word -- )
+    "typed-word" word-prop optimized. ;
+
+M: typed-word disassemble ( word -- )
+    "typed-word" word-prop disassemble ;
diff --git a/basis/typed/typed.factor b/basis/typed/typed.factor
index 65b21fcc38..50da7b1bad 100644
--- a/basis/typed/typed.factor
+++ b/basis/typed/typed.factor
@@ -167,3 +167,4 @@ SYNTAX: TYPED::
 USE: vocabs.loader
 
 { "typed" "prettyprint" } "typed.prettyprint" require-when
+{ "typed" "compiler.cfg.debugger" } "typed.debugger" require-when
diff --git a/extra/compiler/graphviz/graphviz.factor b/extra/compiler/graphviz/graphviz.factor
index 7378d3284c..79a72b33ea 100644
--- a/extra/compiler/graphviz/graphviz.factor
+++ b/extra/compiler/graphviz/graphviz.factor
@@ -78,8 +78,8 @@ IN: compiler.graphviz
 : optimized-cfg ( quot -- cfgs )
     {
         { [ dup cfg? ] [ 1array ] }
-        { [ dup quotation? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
-        { [ dup word? ] [ test-cfg [ dup cfg set optimize-cfg ] map ] }
+        { [ dup quotation? ] [ test-optimizer ] }
+        { [ dup word? ] [ test-optimizer ] }
         [ ]
     } cond ;
 

From e436ae7314faf47170ceeda855c816b5ae796526 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Apr 2010 05:33:34 -0400
Subject: [PATCH 140/158] continuations: keep original error when throwing
 wrapped errors as well, for easier debugging of bootstrap failures

---
 basis/bootstrap/stage2.factor           |  5 ++++-
 core/continuations/continuations.factor | 10 ++++++----
 2 files changed, 10 insertions(+), 5 deletions(-)

diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
index 98b6a472ed..da4fbc444b 100644
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@@ -51,9 +51,11 @@ SYMBOL: bootstrap-time
 
 : save/restore-error ( quot -- )
     error get-global
+    original-error get-global
     error-continuation get-global
-    [ call ] 2dip
+    [ call ] 3dip
     error-continuation set-global
+    original-error set-global
     error set-global ; inline
 
 
@@ -89,6 +91,7 @@ SYMBOL: bootstrap-time
     run-bootstrap-init
 
     f error set-global
+    f original-error set-global
     f error-continuation set-global
 
     nano-count swap - bootstrap-time set-global
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index 196a12d0d2..896a4b982d 100644
--- a/core/continuations/continuations.factor
+++ b/core/continuations/continuations.factor
@@ -12,6 +12,7 @@ IN: continuations
         swap [ set-datastack ] dip
     ] (( stack quot -- new-stack )) call-effect-unsafe ;
 
+SYMBOL: original-error
 SYMBOL: error
 SYMBOL: error-continuation
 SYMBOL: error-thread
@@ -102,8 +103,8 @@ GENERIC: compute-restarts ( error -- seq )
 <PRIVATE
 
 : save-error ( error -- )
-    dup error set-global
-    compute-restarts restarts set-global ;
+    [ error set-global ]
+    [ compute-restarts restarts set-global ] bi ;
 
 PRIVATE>
 
@@ -113,7 +114,8 @@ SYMBOL: thread-error-hook
     dup save-error
     catchstack* empty? [
         thread-error-hook get-global
-        [ (( error -- * )) call-effect-unsafe ] [ die ] if*
+        [ original-error get-global die ] or
+        (( error -- * )) call-effect-unsafe
     ] when
     c> continue-with ;
 
@@ -176,7 +178,7 @@ M: condition compute-restarts
         ! 63 = self
         63 special-object error-thread set-global
         continuation error-continuation set-global
-        rethrow
+        [ original-error set-global ] [ rethrow ] bi
     ] 5 set-special-object
     ! VM adds this to kernel errors, so that user-space
     ! can identify them

From ce73031ec3fa3929a9a29f75345638409371b827 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Apr 2010 18:17:52 -0400
Subject: [PATCH 141/158] compiler.cfg.alias-analysis: write unit tests and fix
 redundant store elimination

---
 .../alias-analysis-tests.factor               | 244 ++++++++++++++++++
 .../cfg/alias-analysis/alias-analysis.factor  |  20 +-
 2 files changed, 256 insertions(+), 8 deletions(-)
 create mode 100644 basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
new file mode 100644
index 0000000000..4a41129ef4
--- /dev/null
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
@@ -0,0 +1,244 @@
+USING: arrays compiler.cfg.alias-analysis compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
+cpu.architecture tools.test ;
+IN: compiler.cfg.alias-analysis.tests
+
+! Redundant load elimination
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##copy f 2 1 any-rep }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##slot-imm f 2 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Store-load forwarding
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+        T{ ##copy f 2 1 any-rep }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+        T{ ##slot-imm f 2 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Dead store elimination
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##set-slot-imm f 2 0 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+        T{ ##set-slot-imm f 2 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Redundant store elimination
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##copy f 2 1 any-rep }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##copy f 2 1 any-rep }
+        T{ ##set-slot-imm f 2 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Not a redundant load
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##set-slot-imm f 0 1 1 0 }
+        T{ ##slot-imm f 2 0 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##set-slot-imm f 0 1 1 0 }
+        T{ ##slot-imm f 2 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Not a redundant store
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##set-slot-imm f 2 1 1 0 }
+        T{ ##slot-imm f 4 0 1 0 }
+        T{ ##set-slot-imm f 3 1 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##set-slot-imm f 2 1 1 0 }
+        T{ ##slot-imm f 4 0 1 0 }
+        T{ ##set-slot-imm f 3 1 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! There's a redundant load, but not a redundant store
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##slot-imm f 4 0 1 0 }
+        T{ ##set-slot-imm f 2 0 1 0 }
+        T{ ##slot f 5 0 3 0 0 }
+        T{ ##set-slot-imm f 3 0 1 0 }
+        T{ ##copy f 6 3 any-rep }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##slot-imm f 4 0 1 0 }
+        T{ ##set-slot-imm f 2 0 1 0 }
+        T{ ##slot f 5 0 3 0 0 }
+        T{ ##set-slot-imm f 3 0 1 0 }
+        T{ ##slot-imm f 6 0 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Fresh allocations don't alias existing values
+
+! Redundant load elimination
+[
+    V{
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##set-slot-imm f 3 4 1 0 }
+        T{ ##set-slot-imm f 2 1 1 0 }
+        T{ ##copy f 5 3 any-rep }
+    }
+] [
+    V{
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##set-slot-imm f 3 4 1 0 }
+        T{ ##set-slot-imm f 2 1 1 0 }
+        T{ ##slot-imm f 5 4 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Redundant store elimination
+[
+    V{
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##slot-imm f 5 1 1 0 }
+        T{ ##set-slot-imm f 3 4 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##set-slot-imm f 1 4 1 0 }
+        T{ ##slot-imm f 5 1 1 0 }
+        T{ ##set-slot-imm f 3 4 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Storing a new alias class into another object means that heap-ac
+! can now alias the new ac
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##set-slot-imm f 0 4 1 0 }
+        T{ ##set-slot-imm f 4 2 1 0 }
+        T{ ##slot-imm f 5 3 1 0 }
+        T{ ##set-slot-imm f 1 5 1 0 }
+        T{ ##slot-imm f 6 4 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##peek f 3 D 3 }
+        T{ ##allot f 4 16 array }
+        T{ ##set-slot-imm f 0 4 1 0 }
+        T{ ##set-slot-imm f 4 2 1 0 }
+        T{ ##slot-imm f 5 3 1 0 }
+        T{ ##set-slot-imm f 1 5 1 0 }
+        T{ ##slot-imm f 6 4 1 0 }
+    } alias-analysis-step
+] unit-test
+
+! Compares between objects which cannot alias are eliminated
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##allot f 1 16 array }
+        T{ ##load-reference f 2 f }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##allot f 1 16 array }
+        T{ ##compare f 2 0 1 cc= }
+    } alias-analysis-step
+] unit-test
diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index ba2caa1e71..ee60e112b7 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -7,7 +7,6 @@ compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.def-use
 compiler.cfg.liveness
-compiler.cfg.copy-prop
 compiler.cfg.registers
 compiler.cfg.utilities
 compiler.cfg.comparisons
@@ -69,6 +68,14 @@ IN: compiler.cfg.alias-analysis
 ! e = c
 ! x[1] = c
 
+! Local copy propagation
+SYMBOL: copies
+
+: resolve ( vreg -- vreg ) copies get ?at drop ;
+
+: record-copy ( ##copy -- )
+    [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
+
 ! Map vregs -> alias classes
 SYMBOL: vregs>acs
 
@@ -86,15 +93,10 @@ SYMBOL: acs>vregs
 
 : ac>vregs ( ac -- vregs ) acs>vregs get at ;
 
-GENERIC: aliases ( vreg -- vregs )
-
-M: integer aliases
+: aliases ( vreg -- vregs )
     #! All vregs which may contain the same value as vreg.
     vreg>ac ac>vregs ;
 
-M: word aliases
-    1array ;
-
 : each-alias ( vreg quot -- )
     [ aliases ] dip each ; inline
 
@@ -259,7 +261,9 @@ M: ##read analyze-aliases*
 M: ##write analyze-aliases*
     dup
     [ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
-    [ remember-set-slot drop ] [ load-slot ] 3bi ;
+    3dup idempotent? [ 3drop ] [
+        [ remember-set-slot drop ] [ load-slot ] 3bi
+    ] if ;
 
 M: ##copy analyze-aliases*
     #! The output vreg gets the same alias class as the input

From 65f86bfce7ecbddbc1be8555a0c5b03d3ae068b5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Apr 2010 18:18:30 -0400
Subject: [PATCH 142/158] compiler.cfg.ssa.detruction: coalesce different
 representations in more cases

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

diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor
index eea64eec07..ff174bc713 100644
--- a/basis/compiler/cfg/ssa/destruction/destruction.factor
+++ b/basis/compiler/cfg/ssa/destruction/destruction.factor
@@ -82,7 +82,7 @@ M: insn prepare-insn
         [ defs-vreg ] [ uses-vregs ] bi
         2dup empty? not and [
             first
-            2dup [ rep-of ] bi@ eq?
+            2dup [ rep-of reg-class-of ] bi@ eq?
             [ try-to-coalesce ] [ 2drop ] if
         ] [ 2drop ] if
     ] bi ;

From ffd1844d5298b52d1df05389ec4f26f23e6274bd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Apr 2010 18:19:56 -0400
Subject: [PATCH 143/158] compiler.cfg.linear-scan: clean up spill slot
 assignment

---
 .../cfg/linear-scan/allocation/state/state.factor         | 8 +++-----
 basis/compiler/cfg/linear-scan/resolve/resolve.factor     | 2 +-
 2 files changed, 4 insertions(+), 6 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
index 8bdd6231b5..f9e6fc6a36 100644
--- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
@@ -118,7 +118,7 @@ SYMBOL: unhandled-intervals
     [ reg-classes ] dip { } map>assoc ; inline
 
 : next-spill-slot ( rep -- n )
-    rep-size cfg get
+    cfg get
     [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
     <spill-slot> ;
 
@@ -129,12 +129,10 @@ SYMBOL: unhandled-sync-points
 SYMBOL: spill-slots
 
 : assign-spill-slot ( coalesced-vreg rep -- spill-slot )
-    dup tagged-rep? [ drop int-rep ] when
-    spill-slots get [ nip next-spill-slot ] 2cache ;
+    rep-size spill-slots get [ nip next-spill-slot ] 2cache ;
 
 : lookup-spill-slot ( coalesced-vreg rep -- spill-slot )
-    dup tagged-rep? [ drop int-rep ] when
-    2array spill-slots get ?at [ ] [ bad-vreg ] if ;
+    rep-size 2array spill-slots get ?at [ ] [ bad-vreg ] if ;
 
 : init-allocator ( registers -- )
     registers set
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index 9964389ce6..9d3c91ca18 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -36,7 +36,7 @@ M: location hashcode*
 SYMBOL: spill-temps
 
 : spill-temp ( rep -- n )
-    spill-temps get [ next-spill-slot ] cache ;
+    rep-size spill-temps get [ next-spill-slot ] cache ;
 
 : add-mapping ( from to rep -- )
     '[ _ <location> ] bi@ 2array , ;

From df86d1341f61ee52e56189f7d00c140049810e7a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Apr 2010 18:40:34 -0400
Subject: [PATCH 144/158] compiler.cfg: clean up ##phi literals in tests

---
 .../compiler/cfg/builder/builder-tests.factor | 30 +++++++++----------
 .../cfg/gc-checks/gc-checks-tests.factor      |  5 +---
 .../cfg/liveness/ssa/ssa-tests.factor         |  6 +---
 .../coalescing/coalescing-tests.factor        |  5 +---
 .../representations-tests.factor              | 15 ++--------
 .../value-numbering-tests.factor              | 10 ++-----
 6 files changed, 23 insertions(+), 48 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index 9ed7c592ce..b8fde7fef6 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -11,8 +11,8 @@ FROM: alien.c-types => int ;
 IN: compiler.cfg.builder.tests
 
 ! Just ensure that various CFGs build correctly.
-: unit-test-cfg ( quot -- )
-    '[ _ test-cfg [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
+: unit-test-builder ( quot -- )
+    '[ _ test-builder [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
 
 : blahblah ( nodes -- ? )
     { fixnum } declare [
@@ -105,7 +105,7 @@ IN: compiler.cfg.builder.tests
         set-string-nth-fast
     ]
 } [
-    unit-test-cfg
+    unit-test-builder
 ] each
 
 : test-1 ( -- ) test-1 ;
@@ -116,7 +116,7 @@ IN: compiler.cfg.builder.tests
     test-1
     test-2
     test-3
-} [ unit-test-cfg ] each
+} [ unit-test-builder ] each
 
 {
     byte-array
@@ -134,8 +134,8 @@ IN: compiler.cfg.builder.tests
         alien-float
         alien-double
     } [| word |
-        { class } word '[ _ declare 10 _ execute ] unit-test-cfg
-        { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+        { class } word '[ _ declare 10 _ execute ] unit-test-builder
+        { class fixnum } word '[ _ declare _ execute ] unit-test-builder
     ] each
     
     {
@@ -146,22 +146,22 @@ IN: compiler.cfg.builder.tests
         set-alien-unsigned-2
         set-alien-unsigned-4
     } [| word |
-        { fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
-        { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+        { fixnum class } word '[ _ declare 10 _ execute ] unit-test-builder
+        { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-builder
     ] each
     
-    { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
-    { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
+    { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-builder
+    { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-builder
     
-    { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
-    { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
+    { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-builder
+    { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-builder
     
-    { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
-    { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
+    { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-builder
+    { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
 ] each
 
 : count-insns ( quot insn-check -- ? )
-    [ test-mr [ instructions>> ] map ] dip
+    [ test-regs [ instructions>> ] map ] dip
     '[ _ count ] map-sum ; inline
 
 : contains-insn? ( quot insn-check -- ? )
diff --git a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor
index de5e35aaa4..496954de2c 100644
--- a/basis/compiler/cfg/gc-checks/gc-checks-tests.factor
+++ b/basis/compiler/cfg/gc-checks/gc-checks-tests.factor
@@ -184,14 +184,11 @@ V{
 } 2 test-bb
 
 V{
-    T{ ##phi f 3 }
+    T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
     T{ ##allot f 1 64 byte-array }
     T{ ##branch }
 } 3 test-bb
 
-1 get 1 2array
-2 get 2 2array 2array 3 get instructions>> first (>>inputs)
-
 0 { 1 2 } edges
 1 3 edge
 2 3 edge
diff --git a/basis/compiler/cfg/liveness/ssa/ssa-tests.factor b/basis/compiler/cfg/liveness/ssa/ssa-tests.factor
index 945d49272c..5413c65b32 100644
--- a/basis/compiler/cfg/liveness/ssa/ssa-tests.factor
+++ b/basis/compiler/cfg/liveness/ssa/ssa-tests.factor
@@ -24,14 +24,10 @@ V{
 } 3 test-bb
 
 V{
-    T{ ##phi f 2 }
+    T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
     T{ ##branch }
 } 4 test-bb
 
-2 get 0 2array
-3 get 1 2array 2array
-4 get instructions>> first (>>inputs)
-
 V{
     T{ ##branch }
 } 5 test-bb
diff --git a/basis/compiler/cfg/representations/coalescing/coalescing-tests.factor b/basis/compiler/cfg/representations/coalescing/coalescing-tests.factor
index f22fe0d147..cc1bde36f1 100644
--- a/basis/compiler/cfg/representations/coalescing/coalescing-tests.factor
+++ b/basis/compiler/cfg/representations/coalescing/coalescing-tests.factor
@@ -26,16 +26,13 @@ V{
 } 2 test-bb
 
 V{
-    T{ ##phi f 3 }
+    T{ ##phi f 3 H{ { 1 0 } { 2 1 } } }
 } 3 test-bb
 
 0 { 1 2 } edges
 1 3 edge
 2 3 edge
 
-1 get 0 2array
-2 get 1 2array 2array 3 get instructions>> first (>>inputs)
-
 [ ] [ test-scc ] unit-test
 
 [ t ] [ 0 vreg>scc 1 vreg>scc = ] unit-test
diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor
index 3f406660ca..f4728bc7e7 100644
--- a/basis/compiler/cfg/representations/representations-tests.factor
+++ b/basis/compiler/cfg/representations/representations-tests.factor
@@ -251,7 +251,7 @@ V{
 } 2 test-bb
 
 V{
-    T{ ##phi f 3 }
+    T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
     T{ ##replace f 3 D 0 }
     T{ ##branch }
 } 3 test-bb
@@ -261,9 +261,6 @@ V{
     T{ ##return }
 } 4 test-bb
 
-1 get 1 2array
-2 get 2 2array 2array 3 get instructions>> first (>>inputs)
-
 0 { 1 2 } edges
 1 3 edge
 2 3 edge
@@ -298,7 +295,7 @@ V{
 } 2 test-bb
 
 V{
-    T{ ##phi f 4 }
+    T{ ##phi f 4 H{ { 1 2 } { 2 3 } } }
     T{ ##replace f 4 D 0 }
     T{ ##branch }
 } 3 test-bb
@@ -308,9 +305,6 @@ V{
     T{ ##return }
 } 4 test-bb
 
-1 get 2 2array
-2 get 3 2array 2array 3 get instructions>> first (>>inputs)
-
 0 { 1 2 } edges
 1 3 edge
 2 3 edge
@@ -371,7 +365,7 @@ cpu x86.32? [
     } 3 test-bb
 
     V{
-        T{ ##phi f 4 }
+        T{ ##phi f 4 H{ { 2 2 } { 3 3 } } }
         T{ ##peek f 5 D 0 }
         T{ ##add-float f 6 4 5 }
         T{ ##replace f 6 D 0 }
@@ -385,9 +379,6 @@ cpu x86.32? [
     test-diamond
     4 5 edge
 
-    2 get 2 2array
-    3 get 3 2array 2array 4 get instructions>> first (>>inputs)
-
     [ ] [ test-representations ] unit-test
 
     [ t ] [ 2 get instructions>> first ##load-double? ] unit-test
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 0b1b8ab0fe..b7084fb2d8 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -2302,14 +2302,11 @@ V{
 } 3 test-bb
 
 V{
-    T{ ##phi f 3 }
+    T{ ##phi f 3 H{ { 2 1 } { 3 2 } } }
     T{ ##replace f 3 D 0 }
     T{ ##return }
 } 4 test-bb
 
-2 get 1 2array
-3 get 2 2array 2array 4 get instructions>> first (>>inputs)
-
 test-diamond
 
 [ ] [
@@ -2341,7 +2338,7 @@ V{
 } 2 test-bb
 
 V{
-    T{ ##phi f 3 V{ } }
+    T{ ##phi f 3 H{ { 1 1 } { 2 0 } } }
     T{ ##branch }
 } 3 test-bb
 
@@ -2350,9 +2347,6 @@ V{
     T{ ##return }
 } 4 test-bb
 
-1 get 1 2array
-2 get 0 2array 2array 3 get instructions>> first (>>inputs)
-
 test-diamond
 
 [ ] [

From e90712b1eddbf48b2d65705bfe727540fcf03317 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Apr 2010 18:55:20 -0400
Subject: [PATCH 145/158] compiler.cfg: cleanup

---
 .../compiler/cfg/alias-analysis/alias-analysis.factor  |  4 ++--
 basis/compiler/cfg/rpo/rpo.factor                      |  4 ++--
 basis/compiler/cfg/ssa/destruction/destruction.factor  |  5 +----
 .../cfg/value-numbering/value-numbering.factor         |  4 ++--
 basis/compiler/cfg/write-barrier/write-barrier.factor  | 10 +++++-----
 5 files changed, 12 insertions(+), 15 deletions(-)

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index ee60e112b7..3cf099d149 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -319,5 +319,5 @@ M: insn eliminate-dead-stores* ;
     compute-live-stores
     eliminate-dead-stores ;
 
-: alias-analysis ( cfg -- cfg' )
-    [ alias-analysis-step ] local-optimization ;
+: alias-analysis ( cfg -- cfg )
+    dup [ alias-analysis-step ] simple-optimization ;
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index 6e09d9885f..a76beca181 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/basis/compiler/cfg/rpo/rpo.factor
@@ -39,8 +39,8 @@ SYMBOL: visited
     [ drop basic-block set ]
     [ change-instructions drop ] 2bi ; inline
 
-: local-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... cfg' )
-    dupd '[ _ optimize-basic-block ] each-basic-block ; inline
+: simple-optimization ( ... cfg quot: ( ... insns -- ... insns' ) -- ... )
+    '[ _ optimize-basic-block ] each-basic-block ; inline
 
 : needs-post-order ( cfg -- cfg' )
     dup post-order drop ;
diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor
index ff174bc713..ede012eb2f 100644
--- a/basis/compiler/cfg/ssa/destruction/destruction.factor
+++ b/basis/compiler/cfg/ssa/destruction/destruction.factor
@@ -123,11 +123,8 @@ M: ##phi useful-insn? drop f ;
 
 M: insn useful-insn? drop t ;
 
-: cleanup-block ( bb -- )
-    instructions>> [ useful-insn? ] filter! drop ;
-
 : cleanup-cfg ( cfg -- )
-    [ cleanup-block ] each-basic-block ;
+    [ [ useful-insn? ] filter! ] simple-optimization ;
 
 PRIVATE>
 
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index ad3ccb1693..81e9d53bad 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -49,7 +49,7 @@ M: array process-instruction
     init-value-graph
     [ process-instruction ] map flatten ;
 
-: value-numbering ( cfg -- cfg' )
-    [ value-numbering-step ] local-optimization
+: value-numbering ( cfg -- cfg )
+    dup [ value-numbering-step ] simple-optimization
 
     cfg-changed predecessors-changed ;
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index cecf5f7251..a34bf6c07f 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators.short-circuit
 compiler.cfg.instructions compiler.cfg.rpo kernel namespaces
@@ -35,10 +35,10 @@ M: ##copy eliminate-write-barrier
 
 M: insn eliminate-write-barrier drop t ;
 
-: write-barriers-step ( bb -- )
+: write-barriers-step ( insns -- insns' )
     H{ } clone fresh-allocations set
     H{ } clone mutated-objects set
-    instructions>> [ eliminate-write-barrier ] filter! drop ;
+    [ eliminate-write-barrier ] filter! ;
 
-: eliminate-write-barriers ( cfg -- cfg' )
-    dup [ write-barriers-step ] each-basic-block ;
+: eliminate-write-barriers ( cfg -- cfg )
+    dup [ write-barriers-step ] simple-optimization ;

From 5979fe7f414dc362861f47e4d3563e16139bd408 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Apr 2010 19:50:30 -0400
Subject: [PATCH 146/158] compiler.cfg.copy-prop: optimistic copy propagation

---
 .../cfg/copy-prop/copy-prop-tests.factor      | 107 ++++++++++++++++++
 basis/compiler/cfg/copy-prop/copy-prop.factor | 100 +++++++++-------
 2 files changed, 163 insertions(+), 44 deletions(-)
 create mode 100644 basis/compiler/cfg/copy-prop/copy-prop-tests.factor

diff --git a/basis/compiler/cfg/copy-prop/copy-prop-tests.factor b/basis/compiler/cfg/copy-prop/copy-prop-tests.factor
new file mode 100644
index 0000000000..84641183b7
--- /dev/null
+++ b/basis/compiler/cfg/copy-prop/copy-prop-tests.factor
@@ -0,0 +1,107 @@
+USING: compiler.cfg.copy-prop tools.test namespaces kernel
+compiler.cfg.debugger compiler.cfg accessors
+compiler.cfg.registers compiler.cfg.instructions
+cpu.architecture ;
+IN: compiler.cfg.copy-prop.tests
+
+: test-copy-propagation ( -- )
+    cfg new 0 get >>entry copy-propagation drop ;
+
+! Simple example
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 0 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##peek f 1 D 1 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##copy f 2 0 any-rep }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##phi f 3 H{ { 2 0 } { 3 2 } } }
+    T{ ##phi f 4 H{ { 2 1 } { 3 2 } } }
+    T{ ##phi f 5 H{ { 2 1 } { 3 0 } } }
+    T{ ##branch }
+} 4 test-bb
+
+V{
+    T{ ##copy f 6 4 any-rep }
+    T{ ##replace f 3 D 0 }
+    T{ ##replace f 5 D 1 }
+    T{ ##replace f 6 D 2 }
+    T{ ##branch }
+} 5 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 6 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 5 edge
+
+[ ] [ test-copy-propagation ] unit-test
+
+[
+    V{
+        T{ ##replace f 0 D 0 }
+        T{ ##replace f 4 D 1 }
+        T{ ##replace f 4 D 2 }
+        T{ ##branch }
+    }
+] [ 5 get instructions>> ] unit-test
+
+! Test optimistic assumption
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 0 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##phi f 1 H{ { 1 0 } { 2 2 } } }
+    T{ ##copy f 2 1 any-rep }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##replace f 2 D 1 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 2 edge
+2 { 2 3 } edges
+3 4 edge
+
+[ ] [ test-copy-propagation ] unit-test
+
+[
+    V{
+        T{ ##replace f 0 D 1 }
+        T{ ##branch }
+    }
+] [ 3 get instructions>> ] unit-test
diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor
index 23382c3dbe..e18c0fa792 100644
--- a/basis/compiler/cfg/copy-prop/copy-prop.factor
+++ b/basis/compiler/cfg/copy-prop/copy-prop.factor
@@ -1,78 +1,90 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs accessors sequences grouping
-combinators compiler.cfg.rpo compiler.cfg.renaming
-compiler.cfg.instructions compiler.cfg.predecessors ;
+USING: sets kernel namespaces assocs accessors sequences grouping
+combinators fry compiler.cfg.def-use compiler.cfg.rpo
+compiler.cfg.renaming compiler.cfg.instructions
+compiler.cfg.predecessors ;
+FROM: namespaces => set ;
 IN: compiler.cfg.copy-prop
 
-! The first three definitions are also used in compiler.cfg.alias-analysis.
-SYMBOL: copies
-
-! Initialized per-basic-block; a mapping from inputs to dst for eliminating
-! redundant phi instructions
-SYMBOL: phis
-
-: resolve ( vreg -- vreg )
-    copies get ?at drop ;
-
-: (record-copy) ( dst src -- )
-    swap copies get set-at ; inline
-
-: record-copy ( ##copy -- )
-    [ dst>> ] [ src>> resolve ] bi (record-copy) ; inline
-
 <PRIVATE
 
+SYMBOL: changed?
+
+SYMBOL: copies
+
+! Initialized per-basic-block; a mapping from inputs to dst for
+! eliminating redundant ##phi instructions
+SYMBOL: phis
+
+: resolve ( vreg -- vreg )
+    copies get at ;
+
+: record-copy ( dst src -- )
+    swap copies get maybe-set-at [ changed? on ] when ; inline
+
 GENERIC: visit-insn ( insn -- )
 
-M: ##copy visit-insn record-copy ;
+M: ##copy visit-insn
+    [ dst>> ] [ src>> resolve ] bi
+    dup [ record-copy ] [ 2drop ] if ;
 
-: useless-phi ( dst inputs -- ) first (record-copy) ;
+: useless-phi ( dst inputs -- ) first record-copy ;
 
-: redundant-phi ( dst inputs -- ) phis get at (record-copy) ;
+: redundant-phi ( dst inputs -- ) phis get at record-copy ;
 
-: record-phi ( dst inputs -- ) phis get set-at ;
+: record-phi ( dst inputs -- )
+    [ phis get set-at ] [ drop dup record-copy ] 2bi ;
 
 M: ##phi visit-insn
     [ dst>> ] [ inputs>> values [ resolve ] map ] bi
-    {
-        { [ dup all-equal? ] [ useless-phi ] }
-        { [ dup phis get key? ] [ redundant-phi ] }
-        [ record-phi ]
-    } cond ;
+    dup phis get key? [ redundant-phi ] [
+        dup sift
+        dup all-equal?
+        [ nip useless-phi ]
+        [ drop record-phi ] if
+    ] if ;
+
+M: vreg-insn visit-insn
+    defs-vreg [ dup record-copy ] when* ;
 
 M: insn visit-insn drop ;
 
-: collect-copies ( cfg -- )
-    H{ } clone copies set
+: (collect-copies) ( cfg -- )
     [
-        H{ } clone phis set
+        phis get clear-assoc
         instructions>> [ visit-insn ] each
     ] each-basic-block ;
 
+: collect-copies ( cfg -- )
+    H{ } clone copies set
+    H{ } clone phis set
+    '[
+        changed? off
+        _ (collect-copies)
+        changed? get
+    ] loop ;
+
 GENERIC: update-insn ( insn -- keep? )
 
 M: ##copy update-insn drop f ;
 
 M: ##phi update-insn
-    dup dst>> copies get key? [ drop f ] [ call-next-method ] if ;
+    dup call-next-method drop
+    [ dst>> ] [ inputs>> values ] bi [ = not ] with any? ;
 
-M: insn update-insn rename-insn-uses t ;
+M: vreg-insn update-insn rename-insn-uses t ;
+
+M: insn update-insn drop t ;
 
 : rename-copies ( cfg -- )
-    copies get dup assoc-empty? [ 2drop ] [
-        renamings set
-        [
-            instructions>> [ update-insn ] filter! drop
-        ] each-basic-block
-    ] if ;
+    copies get renamings set
+    [ [ update-insn ] filter! ] simple-optimization ;
 
 PRIVATE>
 
 : copy-propagation ( cfg -- cfg' )
     needs-predecessors
 
-    [ collect-copies ]
-    [ rename-copies ]
-    [ ]
-    tri ;
+    dup collect-copies
+    dup rename-copies ;

From 1b4b66e3415a1d673fadd22390db1bd9a926eff2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Apr 2010 20:14:17 -0400
Subject: [PATCH 147/158] cpu.x86: use available type info to generate more
 efficient %box-displaced-alien where possible

---
 basis/cpu/x86/x86.factor | 117 +++++++++++++++++++++++----------------
 vm/alien.cpp             |   4 +-
 2 files changed, 70 insertions(+), 51 deletions(-)

diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 891995e6b3..619fb2d3ec 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -5,7 +5,8 @@ cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
 cpu.x86.features cpu.x86.features.private cpu.architecture kernel
 kernel.private math memory namespaces make sequences words system
 layouts combinators math.order math.vectors fry locals compiler.constants
-byte-arrays io macros quotations compiler compiler.units init vm
+byte-arrays io macros quotations classes.algebra compiler
+compiler.units init vm
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.intrinsics
@@ -232,12 +233,68 @@ M:: x86 %box-alien ( dst src temp -- )
         "end" resolve-label
     ] with-scope ;
 
+:: %box-displaced-alien/f ( dst displacement -- )
+    dst 1 alien@ \ f type-number MOV
+    dst 3 alien@ displacement MOV
+    dst 4 alien@ displacement MOV ;
+
+:: %box-displaced-alien/alien ( dst displacement base temp -- )
+    ! Set new alien's base to base.base
+    temp base 1 alien@ MOV
+    dst 1 alien@ temp MOV
+
+    ! Compute displacement
+    temp base 3 alien@ MOV
+    temp displacement ADD
+    dst 3 alien@ temp MOV
+
+    ! Compute address
+    temp base 4 alien@ MOV
+    temp displacement ADD
+    dst 4 alien@ temp MOV ;
+
+:: %box-displaced-alien/byte-array ( dst displacement base temp -- )
+    dst 1 alien@ base MOV
+    dst 3 alien@ displacement MOV
+    temp base displacement byte-array-offset [++] LEA
+    dst 4 alien@ temp MOV ;
+
+:: %box-displaced-alien/dynamic ( dst displacement base temp -- )
+    "not-f" define-label
+    "not-alien" define-label
+
+    ! Check base type
+    temp base MOV
+    temp tag-mask get AND
+
+    ! Is base f?
+    temp \ f type-number CMP
+    "not-f" get JNE
+
+    ! Yes, it is f. Fill in new object
+    dst displacement %box-displaced-alien/f
+
+    "end" get JMP
+
+    "not-f" resolve-label
+
+    ! Is base an alien?
+    temp alien type-number CMP
+    "not-alien" get JNE
+
+    dst displacement base temp %box-displaced-alien/alien
+
+    ! We are done
+    "end" get JMP
+
+    ! Is base a byte array? It has to be, by now...
+    "not-alien" resolve-label
+
+    dst displacement base temp %box-displaced-alien/byte-array ;
+
 M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
-    ! This is ridiculous
     [
         "end" define-label
-        "not-f" define-label
-        "not-alien" define-label
 
         ! If displacement is zero, return the base
         dst base MOV
@@ -251,51 +308,13 @@ M:: x86 %box-displaced-alien ( dst displacement base temp base-class -- )
         ! Set expired to f
         dst 2 alien@ \ f type-number MOV
 
-        ! Is base f?
-        base \ f type-number CMP
-        "not-f" get JNE
-
-        ! Yes, it is f. Fill in new object
-        dst 1 alien@ base MOV
-        dst 3 alien@ displacement MOV
-        dst 4 alien@ displacement MOV
-
-        "end" get JMP
-
-        "not-f" resolve-label
-
-        ! Check base type
-        temp base MOV
-        temp tag-mask get AND
-
-        ! Is base an alien?
-        temp alien type-number CMP
-        "not-alien" get JNE
-
-        ! Yes, it is an alien. Set new alien's base to base.base
-        temp base 1 alien@ MOV
-        dst 1 alien@ temp MOV
-
-        ! Compute displacement
-        temp base 3 alien@ MOV
-        temp displacement ADD
-        dst 3 alien@ temp MOV
-
-        ! Compute address
-        temp base 4 alien@ MOV
-        temp displacement ADD
-        dst 4 alien@ temp MOV
-
-        ! We are done
-        "end" get JMP
-
-        ! Is base a byte array? It has to be, by now...
-        "not-alien" resolve-label
-
-        dst 1 alien@ base MOV
-        dst 3 alien@ displacement MOV
-        temp base displacement byte-array-offset [++] LEA
-        dst 4 alien@ temp MOV
+        dst displacement base temp
+        {
+            { [ base-class \ f class<= ] [ 2drop %box-displaced-alien/f ] }
+            { [ base-class \ alien class<= ] [ %box-displaced-alien/alien ] }
+            { [ base-class \ byte-array class<= ] [ %box-displaced-alien/byte-array ] }
+            [ %box-displaced-alien/dynamic ]
+        } cond
 
         "end" resolve-label
     ] with-scope ;
diff --git a/vm/alien.cpp b/vm/alien.cpp
index da70fa134e..5354c959ae 100755
--- a/vm/alien.cpp
+++ b/vm/alien.cpp
@@ -35,8 +35,8 @@ VM_C_API char *pinned_alien_offset(cell obj, factor_vm *parent)
 /* make an alien */
 cell factor_vm::allot_alien(cell delegate_, cell displacement)
 {
-	if(delegate_ == false_object && displacement == 0)
-		return false_object;
+	if(displacement == 0)
+		return delegate_;
 
 	data_root<object> delegate(delegate_,this);
 	data_root<alien> new_alien(allot<alien>(sizeof(alien)),this);

From 9788323d25b76d3749eef04dfede127f811f397b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 30 Apr 2010 21:33:42 -0400
Subject: [PATCH 148/158] compiler: add ##load-vector instruction to avoid
 wasting a temporary register on x86-32

---
 .../cfg/instructions/instructions.factor      |  6 +++-
 .../representations/peephole/peephole.factor  | 31 +++++++++++--------
 basis/compiler/codegen/codegen.factor         |  1 +
 basis/compiler/codegen/fixup/fixup.factor     |  3 ++
 basis/compiler/constants/constants.factor     |  1 +
 basis/cpu/architecture/architecture.factor    |  8 +++--
 basis/cpu/x86/32/32.factor                    |  5 ++-
 vm/code_blocks.cpp                            |  5 ++-
 vm/compaction.cpp                             |  3 ++
 vm/image.cpp                                  |  3 ++
 vm/instruction_operands.cpp                   | 15 +++++++++
 vm/instruction_operands.hpp                   |  8 ++++-
 vm/layouts.hpp                                |  2 ++
 vm/slot_visitor.hpp                           |  3 ++
 14 files changed, 74 insertions(+), 20 deletions(-)

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 5286fd861b..e7a8338d91 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -29,7 +29,7 @@ INSN: ##load-reference
 def: dst/tagged-rep
 literal: obj ;
 
-! These two are inserted by representation selection
+! These three are inserted by representation selection
 INSN: ##load-tagged
 def: dst/tagged-rep
 literal: val ;
@@ -38,6 +38,10 @@ INSN: ##load-double
 def: dst/double-rep
 literal: val ;
 
+INSN: ##load-vector
+def: dst
+literal: val rep ;
+
 ! Stack operations
 INSN: ##peek
 def: dst/tagged-rep
diff --git a/basis/compiler/cfg/representations/peephole/peephole.factor b/basis/compiler/cfg/representations/peephole/peephole.factor
index 23e2e9c50c..4080e8077c 100644
--- a/basis/compiler/cfg/representations/peephole/peephole.factor
+++ b/basis/compiler/cfg/representations/peephole/peephole.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators combinators.short-circuit kernel
-layouts locals make math namespaces sequences cpu.architecture
-compiler.cfg.registers
+USING: accessors byte-arrays combinators
+combinators.short-circuit kernel layouts locals make math
+namespaces sequences cpu.architecture compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.representations.rewrite
 compiler.cfg.representations.selection ;
@@ -46,11 +46,18 @@ M: ##load-integer optimize-insn
 ! if the architecture supports it
 : convert-to-load-double? ( insn -- ? )
     {
-        [ drop load-double? ]
+        [ drop object-immediates? ]
         [ dst>> rep-of double-rep? ]
         [ obj>> float? ]
     } 1&& ;
 
+: convert-to-load-vector? ( insn -- ? )
+    {
+        [ drop object-immediates? ]
+        [ dst>> rep-of vector-rep? ]
+        [ obj>> byte-array? ]
+    } 1&& ;
+
 ! When a literal zeroes/ones vector is unboxed, we replace the ##load-reference
 ! with a ##zero-vector or ##fill-vector instruction since this is more efficient.
 : convert-to-zero-vector? ( insn -- ? )
@@ -65,25 +72,23 @@ M: ##load-integer optimize-insn
         [ obj>> B{ 255 255 255 255  255 255 255 255  255 255 255 255  255 255 255 255 } = ]
     } 1&& ;
 
-: (convert-to-load-double) ( insn -- dst val )
-    [ dst>> ] [ obj>> ] bi ; inline
-
-: (convert-to-zero/fill-vector) ( insn -- dst rep )
-    dst>> dup rep-of ; inline
-
 M: ##load-reference optimize-insn
     {
         {
             [ dup convert-to-load-double? ]
-            [ (convert-to-load-double) ##load-double here ]
+            [ [ dst>> ] [ obj>> ] bi ##load-double here ]
         }
         {
             [ dup convert-to-zero-vector? ]
-            [ (convert-to-zero/fill-vector) ##zero-vector here ]
+            [ dst>> dup rep-of ##zero-vector here ]
         }
         {
             [ dup convert-to-fill-vector? ]
-            [ (convert-to-zero/fill-vector) ##fill-vector here ]
+            [ dst>> dup rep-of ##fill-vector here ]
+        }
+        {
+            [ dup convert-to-load-vector? ]
+            [ [ dst>> ] [ obj>> ] [ dst>> rep-of ] tri ##load-vector here ]
         }
         [ call-next-method ]
     } cond ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 2d0cfa8289..3d0a6ee8af 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -78,6 +78,7 @@ CODEGEN: ##load-integer %load-immediate
 CODEGEN: ##load-tagged %load-immediate
 CODEGEN: ##load-reference %load-reference
 CODEGEN: ##load-double %load-double
+CODEGEN: ##load-vector %load-vector
 CODEGEN: ##peek %peek
 CODEGEN: ##replace %replace
 CODEGEN: ##inc-d %inc-d
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index fa8dfc2149..ebc9c7b476 100644
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -76,6 +76,9 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
 : rel-float ( literal class -- )
     [ add-literal ] dip rt-float rel-fixup ;
 
+: rel-byte-array ( literal class -- )
+    [ add-literal ] dip rt-byte-array rel-fixup ;
+
 : rel-this ( class -- )
     rt-this rel-fixup ;
 
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index 2fdf814521..ca9dc5136d 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -68,6 +68,7 @@ CONSTANT: rt-cards-offset 10
 CONSTANT: rt-decks-offset 11
 CONSTANT: rt-exception-handler 12
 CONSTANT: rt-float 13
+CONSTANT: rt-byte-array 14
 
 : rc-absolute? ( n -- ? )
     ${
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 09745dea6b..1418ab90b6 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -225,6 +225,7 @@ HOOK: complex-addressing? cpu ( -- ? )
 HOOK: %load-immediate cpu ( reg val -- )
 HOOK: %load-reference cpu ( reg obj -- )
 HOOK: %load-double cpu ( reg val -- )
+HOOK: %load-vector cpu ( reg val rep -- )
 
 HOOK: %peek cpu ( vreg loc -- )
 HOOK: %replace cpu ( vreg loc -- )
@@ -500,10 +501,11 @@ M: reg-class param-reg param-regs nth ;
 
 M: stack-params param-reg 2drop ;
 
-! Does this architecture support %load-double?
-HOOK: load-double? cpu ( -- ? )
+! Does this architecture support %load-double, %load-vector and
+! objects in %compare-imm?
+HOOK: object-immediates? cpu ( -- ? )
 
-M: object load-double? f ;
+M: object object-immediates? f ;
 
 ! Can this value be an immediate operand for %add-imm, %sub-imm,
 ! or %mul-imm?
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 79ff4b1e35..4df4fbd602 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -27,11 +27,14 @@ M: x86.32 temp-reg ECX ;
 M: x86.32 immediate-comparand? ( n -- ? )
     [ call-next-method ] [ word? ] bi or ;
 
-M: x86.32 load-double? ( -- ? ) t ;
+M: x86.32 object-immediates? ( -- ? ) t ;
 
 M: x86.32 %load-double ( dst val -- )
     [ 0 [] MOVSD ] dip rc-absolute rel-float ;
 
+M:: x86.32 %load-vector ( dst val rep -- )
+    dst 0 [] rep copy-memory* val rc-absolute rel-byte-array ;
+
 M: x86.32 %mov-vm-ptr ( reg -- )
     0 MOV 0 rc-absolute-cell rel-vm ;
 
diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp
index 2e7b8d4f09..351ce5a95e 100755
--- a/vm/code_blocks.cpp
+++ b/vm/code_blocks.cpp
@@ -231,7 +231,7 @@ void factor_vm::store_external_address(instruction_operand op)
 		break;
 #endif
 	default:
-		critical_error("Bad rel type",op.rel_type());
+		critical_error("Bad rel type in store_external_address()",op.rel_type());
 		break;
 	}
 }
@@ -268,6 +268,9 @@ struct initial_code_block_visitor {
 		case RT_FLOAT:
 			op.store_float(next_literal());
 			break;
+		case RT_BYTE_ARRAY:
+			op.store_byte_array(next_literal());
+			break;
 		case RT_ENTRY_POINT:
 			op.store_value(parent->compute_entry_point_address(next_literal()));
 			break;
diff --git a/vm/compaction.cpp b/vm/compaction.cpp
index 34398e3d88..f596c3040f 100644
--- a/vm/compaction.cpp
+++ b/vm/compaction.cpp
@@ -114,6 +114,9 @@ struct code_block_compaction_relocation_visitor {
 		case RT_FLOAT:
 			op.store_float(slot_forwarder.visit_pointer(op.load_float(old_offset)));
 			break;
+		case RT_BYTE_ARRAY:
+			op.store_byte_array(slot_forwarder.visit_pointer(op.load_byte_array(old_offset)));
+			break;
 		case RT_ENTRY_POINT:
 		case RT_ENTRY_POINT_PIC:
 		case RT_ENTRY_POINT_PIC_TAIL:
diff --git a/vm/image.cpp b/vm/image.cpp
index 4dfdc4242e..b64d828947 100755
--- a/vm/image.cpp
+++ b/vm/image.cpp
@@ -188,6 +188,9 @@ struct code_block_fixup_relocation_visitor {
 		case RT_FLOAT:
 			op.store_float(data_visitor.visit_pointer(op.load_float(old_offset)));
 			break;
+		case RT_BYTE_ARRAY:
+			op.store_byte_array(data_visitor.visit_pointer(op.load_byte_array(old_offset)));
+			break;
 		case RT_ENTRY_POINT:
 		case RT_ENTRY_POINT_PIC:
 		case RT_ENTRY_POINT_PIC_TAIL:
diff --git a/vm/instruction_operands.cpp b/vm/instruction_operands.cpp
index af7d363aef..65a2f93b2d 100644
--- a/vm/instruction_operands.cpp
+++ b/vm/instruction_operands.cpp
@@ -72,6 +72,16 @@ cell instruction_operand::load_float(cell pointer)
 	return (cell)load_value(pointer) - boxed_float_offset;
 }
 
+cell instruction_operand::load_byte_array()
+{
+	return (cell)load_value() - byte_array_offset;
+}
+
+cell instruction_operand::load_byte_array(cell pointer)
+{
+	return (cell)load_value(pointer) - byte_array_offset;
+}
+
 code_block *instruction_operand::load_code_block(cell relative_to)
 {
 	return ((code_block *)load_value(relative_to) - 1);
@@ -150,6 +160,11 @@ void instruction_operand::store_float(cell value)
 	store_value((fixnum)value + boxed_float_offset);
 }
 
+void instruction_operand::store_byte_array(cell value)
+{
+	store_value((fixnum)value + byte_array_offset);
+}
+
 void instruction_operand::store_code_block(code_block *compiled)
 {
 	store_value((cell)compiled->entry_point());
diff --git a/vm/instruction_operands.hpp b/vm/instruction_operands.hpp
index 5c120c2ec7..7adb517f18 100644
--- a/vm/instruction_operands.hpp
+++ b/vm/instruction_operands.hpp
@@ -32,6 +32,8 @@ enum relocation_type {
 	RT_EXCEPTION_HANDLER,
 	/* pointer to a float's payload */
 	RT_FLOAT,
+	/* pointer to a byte array's payload */
+	RT_BYTE_ARRAY,
 
 };
 
@@ -116,9 +118,10 @@ struct relocation_entry {
 		case RT_DECKS_OFFSET:
 		case RT_EXCEPTION_HANDLER:
 		case RT_FLOAT:
+		case RT_BYTE_ARRAY:
 			return 0;
 		default:
-			critical_error("Bad rel type",rel_type());
+			critical_error("Bad rel type in number_of_parameters()",rel_type());
 			return -1; /* Can't happen */
 		}
 	}
@@ -158,6 +161,8 @@ struct instruction_operand {
 	fixnum load_value();
 	cell load_float(cell relative_to);
 	cell load_float();
+	cell load_byte_array(cell relative_to);
+	cell load_byte_array();
 	code_block *load_code_block(cell relative_to);
 	code_block *load_code_block();
 
@@ -165,6 +170,7 @@ struct instruction_operand {
 	void store_value_masked(fixnum value, cell mask, cell shift);
 	void store_value(fixnum value);
 	void store_float(cell value);
+	void store_byte_array(cell value);
 	void store_code_block(code_block *compiled);
 };
 
diff --git a/vm/layouts.hpp b/vm/layouts.hpp
index 5275c79612..35f04e7cc5 100644
--- a/vm/layouts.hpp
+++ b/vm/layouts.hpp
@@ -178,6 +178,8 @@ struct bignum : public object {
 	cell *data() const { return (cell *)(this + 1); }
 };
 
+const cell byte_array_offset = 16 - BYTE_ARRAY_TYPE;
+
 struct byte_array : public object {
 	static const cell type_number = BYTE_ARRAY_TYPE;
 	static const cell element_size = 1;
diff --git a/vm/slot_visitor.hpp b/vm/slot_visitor.hpp
index cb2db1c705..d0507da93f 100644
--- a/vm/slot_visitor.hpp
+++ b/vm/slot_visitor.hpp
@@ -200,6 +200,9 @@ struct literal_references_visitor {
 		case RT_FLOAT:
 			op.store_float(visitor->visit_pointer(op.load_float()));
 			break;
+		case RT_BYTE_ARRAY:
+			op.store_byte_array(visitor->visit_pointer(op.load_byte_array()));
+			break;
 		default:
 			break;
 		}

From 428ba9fd0f085027c267f89717ae4e04b8810e13 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 1 May 2010 03:04:31 -0400
Subject: [PATCH 149/158] compiler.cfg: fuse ##load-integer/##load-reference
 into ##replace to form ##replace-imm

---
 .../cfg/instructions/instructions.factor         |  3 +++
 .../stacks/uninitialized/uninitialized.factor    | 11 ++++++++---
 .../comparisons/comparisons.factor               |  8 +++-----
 .../cfg/value-numbering/misc/authors.txt         |  1 +
 .../cfg/value-numbering/misc/misc.factor         | 13 +++++++++++++
 .../cfg/value-numbering/rewrite/rewrite.factor   | 14 ++++++++------
 .../cfg/value-numbering/value-numbering.factor   |  1 +
 basis/compiler/codegen/codegen.factor            |  5 +++--
 .../propagation/known-words/known-words.factor   | 12 +++++++-----
 basis/cpu/architecture/architecture.factor       |  3 +++
 basis/cpu/x86/32/32.factor                       | 13 ++++++++++---
 basis/cpu/x86/x86.factor                         | 16 +++++++++++++---
 12 files changed, 73 insertions(+), 27 deletions(-)
 create mode 100644 basis/compiler/cfg/value-numbering/misc/authors.txt
 create mode 100644 basis/compiler/cfg/value-numbering/misc/misc.factor

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index e7a8338d91..e483b707ae 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -51,6 +51,9 @@ INSN: ##replace
 use: src/tagged-rep
 literal: loc ;
 
+INSN: ##replace-imm
+literal: src loc ;
+
 INSN: ##inc-d
 literal: n ;
 
diff --git a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor
index 5b2bbf3765..3d7519e14b 100644
--- a/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor
+++ b/basis/compiler/cfg/stacks/uninitialized/uninitialized.factor
@@ -33,14 +33,19 @@ M: ##inc-r visit-insn n>> rs-loc handle-inc ;
 
 ERROR: uninitialized-peek insn ;
 
-M: ##peek visit-insn
+: visit-peek ( ##peek -- )
     dup loc>> [ n>> ] [ class get ] bi ?nth 0 =
-    [ uninitialized-peek ] [ drop ] if ;
+    [ uninitialized-peek ] [ drop ] if ; inline
 
-M: ##replace visit-insn
+M: ##peek visit-insn visit-peek ;
+
+: visit-replace ( ##replace -- )
     loc>> [ n>> ] [ class get ] bi
     2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ;
 
+M: ##replace visit-insn visit-replace ;
+M: ##replace-imm visit-insn visit-replace ;
+
 M: insn visit-insn drop ;
 
 : prepare ( pair -- )
diff --git a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
index 63ac3575ef..f28092d8cc 100644
--- a/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
+++ b/basis/compiler/cfg/value-numbering/comparisons/comparisons.factor
@@ -17,13 +17,11 @@ IN: compiler.cfg.value-numbering.comparisons
 ! 3) Folding comparisons where both inputs are congruent
 ! 4) Converting compare instructions into compare-imm instructions
 
-UNION: literal-insn ##load-integer ##load-reference ;
-
 : fold-compare-imm? ( insn -- ? )
     src1>> vreg>insn literal-insn? ;
 
 : evaluate-compare-imm ( insn -- ? )
-    [ src1>> vreg>comparand ] [ src2>> ] [ cc>> ] tri
+    [ src1>> vreg>literal ] [ src2>> ] [ cc>> ] tri
     {
         { cc= [ eq? ] }
         { cc/= [ eq? not ] }
@@ -107,7 +105,7 @@ M: ##compare-integer-imm-branch rewrite
 
 : >compare-imm-branch ( insn swap? -- insn' )
     (>compare-imm-branch)
-    [ vreg>comparand ] dip
+    [ vreg>literal ] dip
     \ ##compare-imm-branch new-insn ; inline
 
 : >compare-integer-imm-branch ( insn swap? -- insn' )
@@ -143,7 +141,7 @@ M: ##compare-integer-branch rewrite
 
 : >compare-imm ( insn swap? -- insn' )
     (>compare-imm)
-    [ vreg>comparand ] dip
+    [ vreg>literal ] dip
     next-vreg \ ##compare-imm new-insn ; inline
 
 : >compare-integer-imm ( insn swap? -- insn' )
diff --git a/basis/compiler/cfg/value-numbering/misc/authors.txt b/basis/compiler/cfg/value-numbering/misc/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/misc/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/cfg/value-numbering/misc/misc.factor b/basis/compiler/cfg/value-numbering/misc/misc.factor
new file mode 100644
index 0000000000..e608c6e4ce
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/misc/misc.factor
@@ -0,0 +1,13 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite cpu.architecture kernel ;
+IN: compiler.cfg.value-numbering.misc
+
+M: ##replace rewrite
+    object-immediates? [
+        [ loc>> ] [ src>> vreg>insn ] bi dup literal-insn?
+        [ insn>literal swap \ ##replace-imm new-insn ]
+        [ 2drop f ] if
+    ] [ drop f ] if ;
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 1e2327d765..4f22c5bec2 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators combinators.short-circuit kernel layouts
-cpu.architecture
+USING: accessors combinators combinators.short-circuit kernel
+layouts math cpu.architecture
 compiler.cfg.instructions
 compiler.cfg.value-numbering.graph ;
 IN: compiler.cfg.value-numbering.rewrite
@@ -30,13 +30,15 @@ M: ##load-integer insn>integer val>> ;
         [ val>> immediate-bitwise? ]
     } 1&& ;
 
-GENERIC: insn>comparand ( expr -- n )
+UNION: literal-insn ##load-integer ##load-reference ;
 
-M: ##load-integer insn>comparand val>> tag-fixnum ;
+GENERIC: insn>literal ( insn -- n )
 
-M: ##load-reference insn>comparand obj>> ;
+M: ##load-integer insn>literal val>> >fixnum ;
 
-: vreg>comparand ( vreg -- n ) vreg>insn insn>comparand ; inline
+M: ##load-reference insn>literal obj>> ;
+
+: vreg>literal ( vreg -- n ) vreg>insn insn>literal ; inline
 
 : vreg-immediate-comparand? ( vreg -- ? )
     vreg>insn {
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index 81e9d53bad..23fae4932e 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -15,6 +15,7 @@ compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.math
 compiler.cfg.value-numbering.rewrite
 compiler.cfg.value-numbering.slots
+compiler.cfg.value-numbering.misc
 compiler.cfg.value-numbering.expressions ;
 IN: compiler.cfg.value-numbering
 
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 3d0a6ee8af..4737f1a47d 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -81,6 +81,7 @@ CODEGEN: ##load-double %load-double
 CODEGEN: ##load-vector %load-vector
 CODEGEN: ##peek %peek
 CODEGEN: ##replace %replace
+CODEGEN: ##replace-imm %replace-imm
 CODEGEN: ##inc-d %inc-d
 CODEGEN: ##inc-r %inc-r
 CODEGEN: ##call %call
@@ -193,7 +194,7 @@ CODEGEN: ##write-barrier-imm %write-barrier-imm
 CODEGEN: ##compare %compare
 CODEGEN: ##compare-imm %compare-imm
 CODEGEN: ##compare-integer %compare
-CODEGEN: ##compare-integer-imm %compare-imm
+CODEGEN: ##compare-integer-imm %compare-integer-imm
 CODEGEN: ##compare-float-ordered %compare-float-ordered
 CODEGEN: ##compare-float-unordered %compare-float-unordered
 CODEGEN: ##save-context %save-context
@@ -227,7 +228,7 @@ SYNTAX: CONDITIONAL:
 CONDITIONAL: ##compare-branch %compare-branch
 CONDITIONAL: ##compare-imm-branch %compare-imm-branch
 CONDITIONAL: ##compare-integer-branch %compare-branch
-CONDITIONAL: ##compare-integer-imm-branch %compare-imm-branch
+CONDITIONAL: ##compare-integer-imm-branch %compare-integer-imm-branch
 CONDITIONAL: ##compare-float-ordered-branch %compare-float-ordered-branch
 CONDITIONAL: ##compare-float-unordered-branch %compare-float-unordered-branch
 CONDITIONAL: ##test-vector-branch %test-vector-branch
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index ada01e213a..351da4e2f8 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -221,12 +221,14 @@ generic-comparison-ops [
 ] "outputs" set-word-prop
 
 \ both-fixnums? [
-    [ class>> ] bi@ {
-        { [ 2dup [ fixnum classes-intersect? not ] either? ] [ f <literal-info> ] }
-        { [ 2dup [ fixnum class<= ] both? ] [ t <literal-info> ] }
-        [ object-info ]
+    node-input-infos first2 [ class>> ] bi@ {
+        { [ 2dup [ fixnum classes-intersect? not ] either? ] [ [ 2drop f ] ] }
+        { [ 2dup [ fixnum class<= ] both? ] [ [ 2drop t ] ] }
+        { [ dup fixnum class<= ] [ [ drop fixnum? ] ] }
+        { [ over fixnum class<= ] [ [ nip fixnum? ] ] }
+        [ f ]
     } cond 2nip
-] "outputs" set-word-prop
+] "custom-inlining" set-word-prop
 
 {
     { >fixnum fixnum }
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 1418ab90b6..cac7ea4d7a 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -229,6 +229,7 @@ HOOK: %load-vector cpu ( reg val rep -- )
 
 HOOK: %peek cpu ( vreg loc -- )
 HOOK: %replace cpu ( vreg loc -- )
+HOOK: %replace-imm cpu ( src loc -- )
 HOOK: %inc-d cpu ( n -- )
 HOOK: %inc-r cpu ( n -- )
 
@@ -472,11 +473,13 @@ HOOK: %epilogue cpu ( n -- )
 
 HOOK: %compare cpu ( dst temp cc src1 src2 -- )
 HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- )
+HOOK: %compare-integer-imm cpu ( dst temp cc src1 src2 -- )
 HOOK: %compare-float-ordered cpu ( dst temp cc src1 src2 -- )
 HOOK: %compare-float-unordered cpu ( dst temp cc src1 src2 -- )
 
 HOOK: %compare-branch cpu ( label cc src1 src2 -- )
 HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-integer-imm-branch cpu ( label cc src1 src2 -- )
 HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- )
 HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- )
 
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 4df4fbd602..6a7ecd9d14 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -24,11 +24,18 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 frame-reg EBP ;
 M: x86.32 temp-reg ECX ;
 
-M: x86.32 immediate-comparand? ( n -- ? )
-    [ call-next-method ] [ word? ] bi or ;
-
 M: x86.32 object-immediates? ( -- ? ) t ;
 
+M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
+
+M: x86.32 %replace-imm ( src loc -- )
+    loc>operand swap
+    {
+        { [ dup not ] [ drop \ f type-number MOV ] }
+        { [ dup fixnum? ] [ tag-fixnum MOV ] }
+        [ [ HEX: ffffffff MOV ] dip rc-absolute rel-literal ]
+    } cond ;
+
 M: x86.32 %load-double ( dst val -- )
     [ 0 [] MOVSD ] dip rc-absolute rel-float ;
 
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 619fb2d3ec..6c485e1630 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -531,12 +531,18 @@ M:: x86 %compare ( dst src1 src2 cc temp -- )
 : (%compare-tagged) ( src1 src2 -- )
     [ HEX: ffffffff CMP ] dip rc-absolute rel-literal ;
 
+: (%compare-integer-imm) ( src1 src2 cc -- )
+    3dup use-test? [ 2drop dup TEST ] [ drop CMP ] if ;
+
+M:: x86 %compare-integer-imm ( dst src1 src2 cc temp -- )
+    src1 src2 cc (%compare-integer-imm)
+    dst cc temp %boolean ;
+
 : (%compare-imm) ( src1 src2 cc -- )
     {
-        { [ 3dup use-test? ] [ 2drop dup TEST ] }
-        { [ over integer? ] [ drop CMP ] }
-        { [ over word? ] [ drop (%compare-tagged) ] }
+        { [ over fixnum? ] [ [ tag-fixnum ] dip (%compare-integer-imm) ] }
         { [ over not ] [ 2drop \ f type-number CMP ] }
+        [ drop (%compare-tagged) ]
     } cond ;
 
 M:: x86 %compare-imm ( dst src1 src2 cc temp -- )
@@ -557,6 +563,10 @@ M:: x86 %compare-branch ( label src1 src2 cc -- )
     src1 src2 CMP
     label cc %branch ;
 
+M:: x86 %compare-integer-imm-branch ( label src1 src2 cc -- )
+    src1 src2 cc (%compare-integer-imm)
+    label cc %branch ;
+
 M:: x86 %compare-imm-branch ( label src1 src2 cc -- )
     src1 src2 cc (%compare-imm)
     label cc %branch ;

From 38bafd2be8844d759af8492d688f9deb01313e97 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 May 2010 02:40:19 -0400
Subject: [PATCH 150/158] compiler.cfg.linear-scan.assignment: spill slot
 representation logic was backwards, just like Factor

---
 .../linear-scan/assignment/assignment.factor  |  2 +-
 basis/compiler/tests/float.factor             | 20 ++++++++++++++++++-
 basis/math/vectors/simd/simd-tests.factor     |  2 +-
 3 files changed, 21 insertions(+), 3 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index f457713380..b160bd776c 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -93,7 +93,7 @@ SYMBOL: machine-live-outs
     init-unhandled ;
 
 : insert-spill ( live-interval -- )
-    [ reg>> ] [ first-use rep>> ] [ spill-to>> ] tri ##spill ;
+    [ reg>> ] [ last-use rep>> ] [ spill-to>> ] tri ##spill ;
 
 : handle-spill ( live-interval -- )
     dup spill-to>> [ insert-spill ] [ drop ] if ;
diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor
index 0d4e30279e..b1ce0e454d 100644
--- a/basis/compiler/tests/float.factor
+++ b/basis/compiler/tests/float.factor
@@ -1,6 +1,8 @@
 USING: compiler.units compiler.test kernel kernel.private memory
 math math.private tools.test math.floats.private math.order fry
-;
+specialized-arrays sequences ;
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
 IN: compiler.tests.float
 
 [ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
@@ -116,3 +118,19 @@ IN: compiler.tests.float
 [ t ] [ 3.0 0/0. \ min check-compiled-binary-op ] unit-test
 [ t ] [ 0/0. 3.0 \ max check-compiled-binary-op ] unit-test
 [ t ] [ 3.0 0/0. \ max check-compiled-binary-op ] unit-test
+
+! Test vector ops
+[ 30.0 ] [
+    float-array{ 1 2 3 4 } float-array{ 1 2 3 4 }
+    [ { float-array float-array } declare [ * ] [ + ] 2map-reduce ] compile-call
+] unit-test
+
+[ 30.0 ] [
+    float-array{ 1 2 3 4 }
+    [ { float-array } declare dup [ * ] [ + ] 2map-reduce ] compile-call
+] unit-test
+
+[ 30.0 ] [
+    float-array{ 1 2 3 4 }
+    [ { float-array } declare [ dup * ] [ + ] map-reduce ] compile-call
+] unit-test
diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor
index 1d19c76dc1..f3d56ba868 100644
--- a/basis/math/vectors/simd/simd-tests.factor
+++ b/basis/math/vectors/simd/simd-tests.factor
@@ -128,7 +128,7 @@ CONSTANT: vector-words
         @
         [ dup [ class ] { } map-as ] dip '[ _ declare @ ]
         {
-            [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
+            [ "print-mr" get [ nip regs. ] [ 2drop ] if ]
             [ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
             [ [ [ call ] dip call ] call( quot quot -- result ) ]
             [ [ [ call ] dip compile-call ] call( quot quot -- result ) ]

From 7f6ae34d7232184524133a1e0129beda34e4e054 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 May 2010 16:21:56 -0400
Subject: [PATCH 151/158] Updating tests for recent compiler changes

---
 .../cfg/linear-scan/linear-scan-tests.factor  | 883 ------------------
 .../value-numbering-tests.factor              |  84 +-
 basis/compiler/tests/low-level-ir.factor      |   8 +-
 .../specialized-arrays-tests.factor           |   1 +
 core/alien/alien-tests.factor                 |   6 +-
 5 files changed, 43 insertions(+), 939 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 6d479c9daa..eb2dc2d64d 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -600,886 +600,3 @@ H{
     }
     register-status
 ] unit-test
-
-:: test-linear-scan-on-cfg ( regs -- )
-    [
-        cfg new 0 get >>entry
-        dup cfg set
-        dup fake-representations
-        dup { { int-regs regs } } (linear-scan)
-        flatten-cfg 1array mr.
-    ] with-scope ;
-
-! Bug in live spill slots calculation
-
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
-    T{ ##peek
-       { dst 703128 }
-       { loc D 1 }
-    }
-    T{ ##peek
-       { dst 703129 }
-       { loc D 0 }
-    }
-    T{ ##copy
-       { dst 703134 }
-       { src 703128 }
-    }
-    T{ ##copy
-       { dst 703135 }
-       { src 703129 }
-    }
-    T{ ##compare-imm-branch
-       { src1 703128 }
-       { src2 5 }
-       { cc cc/= }
-    }
-} 1 test-bb
-
-V{
-    T{ ##copy
-       { dst 703134 }
-       { src 703129 }
-    }
-    T{ ##copy
-       { dst 703135 }
-       { src 703128 }
-    }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##replace
-       { src 703134 }
-       { loc D 0 }
-    }
-    T{ ##replace
-       { src 703135 }
-       { loc D 1 }
-    }
-    T{ ##epilogue }
-    T{ ##return }
-} 3 test-bb
-
-0 1 edge
-1 { 2 3 } edges
-2 3 edge
-
-! Bug in inactive interval handling
-! [ rot dup [ -rot ] when ]
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-    
-V{
-    T{ ##peek
-       { dst 689473 }
-       { loc D 2 }
-    }
-    T{ ##peek
-       { dst 689474 }
-       { loc D 1 }
-    }
-    T{ ##peek
-       { dst 689475 }
-       { loc D 0 }
-    }
-    T{ ##compare-imm-branch
-       { src1 689473 }
-       { src2 5 }
-       { cc cc/= }
-    }
-} 1 test-bb
-
-V{
-    T{ ##copy
-       { dst 689481 }
-       { src 689475 }
-       { rep int-rep }
-    }
-    T{ ##copy
-       { dst 689482 }
-       { src 689474 }
-       { rep int-rep }
-    }
-    T{ ##copy
-       { dst 689483 }
-       { src 689473 }
-       { rep int-rep }
-    }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##copy
-       { dst 689481 }
-       { src 689473 }
-       { rep int-rep }
-    }
-    T{ ##copy
-       { dst 689482 }
-       { src 689475 }
-       { rep int-rep }
-    }
-    T{ ##copy
-       { dst 689483 }
-       { src 689474 }
-       { rep int-rep }
-    }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##replace
-       { src 689481 }
-       { loc D 0 }
-    }
-    T{ ##replace
-       { src 689482 }
-       { loc D 1 }
-    }
-    T{ ##replace
-       { src 689483 }
-       { loc D 2 }
-    }
-    T{ ##epilogue }
-    T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-! Similar to the above
-! [ swap dup [ rot ] when ]
-
-T{ basic-block
-   { id 201537 }
-   { number 0 }
-   { instructions V{ T{ ##prologue } T{ ##branch } } }
-} 0 set
-    
-V{
-    T{ ##peek
-       { dst 689600 }
-       { loc D 1 }
-    }
-    T{ ##peek
-       { dst 689601 }
-       { loc D 0 }
-    }
-    T{ ##compare-imm-branch
-       { src1 689600 }
-       { src2 5 }
-       { cc cc/= }
-    }
-} 1 test-bb
-    
-V{
-    T{ ##peek
-       { dst 689604 }
-       { loc D 2 }
-    }
-    T{ ##copy
-       { dst 689607 }
-       { src 689604 }
-       { rep int-rep }
-    }
-    T{ ##copy
-       { dst 689608 }
-       { src 689600 }
-       { rep int-rep }
-    }
-    T{ ##copy
-       { dst 689610 }
-       { src 689601 }
-       { rep int-rep }
-    }
-    T{ ##branch }
-} 2 test-bb
-    
-V{
-    T{ ##peek
-       { dst 689609 }
-       { loc D 2 }
-    }
-    T{ ##copy
-       { dst 689607 }
-       { src 689600 }
-       { rep int-rep }
-    }
-    T{ ##copy
-       { dst 689608 }
-       { src 689601 }
-       { rep int-rep }
-    }
-    T{ ##copy
-       { dst 689610 }
-       { src 689609 }
-       { rep int-rep }
-    }
-    T{ ##branch }
-} 3 test-bb
-    
-V{
-    T{ ##replace
-       { src 689607 }
-       { loc D 0 }
-    }
-    T{ ##replace
-       { src 689608 }
-       { loc D 1 }
-    }
-    T{ ##replace
-       { src 689610 }
-       { loc D 2 }
-    }
-    T{ ##epilogue }
-    T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-! compute-live-registers was inaccurate since it didn't take
-! lifetime holes into account
-
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
-    T{ ##peek
-       { dst 0 }
-       { loc D 0 }
-    }
-    T{ ##compare-imm-branch
-       { src1 0 }
-       { src2 5 }
-       { cc cc/= }
-    }
-} 1 test-bb
-
-V{
-    T{ ##peek
-       { dst 1 }
-       { loc D 1 }
-    }
-    T{ ##copy
-       { dst 2 }
-       { src 1 }
-       { rep int-rep }
-    }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##peek
-       { dst 3 }
-       { loc D 2 }
-    }
-    T{ ##copy
-       { dst 2 }
-       { src 3 }
-       { rep int-rep }
-    }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##replace
-       { src 2 }
-       { loc D 0 }
-    }
-    T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-! Inactive interval handling: splitting active interval
-! if it fits in lifetime hole only partially
-
-V{ T{ ##peek f 3 R 1 } T{ ##branch } } 0 test-bb
-
-V{
-    T{ ##peek f 2 R 0 }
-    T{ ##compare-imm-branch f 2 5 cc= }
-} 1 test-bb
-
-V{
-    T{ ##peek f 0 D 0 }
-    T{ ##branch }
-} 2 test-bb
-
-
-V{
-    T{ ##peek f 1 D 1 }
-    T{ ##peek f 0 D 0 }
-    T{ ##replace f 1 D 2 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##replace f 3 R 2 }
-    T{ ##replace f 0 D 0 }
-    T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] 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 3 R 1 } T{ ##branch } } 0 test-bb
-
-V{
-    T{ ##peek f 2 R 0 }
-    T{ ##compare-imm-branch f 2 5 cc= }
-} 1 test-bb
-
-V{
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##replace f 3 R 1 }
-    T{ ##peek f 1 D 1 }
-    T{ ##peek f 0 D 0 }
-    T{ ##replace f 1 D 2 }
-    T{ ##replace f 0 D 2 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##replace f 3 R 2 }
-    T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-[ ##spill ] [ 2 get successors>> first instructions>> first class ] unit-test
-
-[ ##spill ] [ 3 get instructions>> second class ] unit-test
-
-[ f ] [ 3 get instructions>> [ ##reload? ] any? ] unit-test
-
-[ ##reload ] [ 4 get instructions>> first class ] unit-test
-
-! Resolve pass
-V{
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f 0 D 0 }
-    T{ ##compare-imm-branch f 0 5 cc= }
-} 1 test-bb
-
-V{
-    T{ ##replace f 0 D 0 }
-    T{ ##peek f 1 D 0 }
-    T{ ##peek f 2 D 0 }
-    T{ ##replace f 1 D 0 }
-    T{ ##replace f 2 D 0 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##peek f 1 D 0 }
-    T{ ##compare-imm-branch f 1 5 cc= }
-} 4 test-bb
-
-V{
-    T{ ##replace f 0 D 0 }
-    T{ ##return }
-} 5 test-bb
-
-V{
-    T{ ##replace f 0 D 0 }
-    T{ ##return }
-} 6 test-bb
-
-0 1 edge
-1 { 2 3 } edges
-2 4 edge
-3 4 edge
-4 { 5 6 } edges
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-[ t ] [ 2 get instructions>> [ ##spill? ] any? ] unit-test
-
-[ t ] [ 3 get predecessors>> first instructions>> [ ##spill? ] any? ] unit-test
-
-[ t ] [ 5 get instructions>> [ ##reload? ] any? ] unit-test
-
-! A more complicated failure case with resolve that came up after the above
-! got fixed
-V{ T{ ##branch } } 0 test-bb
-V{
-    T{ ##peek f 0 D 0 }
-    T{ ##peek f 1 D 1 }
-    T{ ##peek f 2 D 2 }
-    T{ ##peek f 3 D 3 }
-    T{ ##peek f 4 D 0 }
-    T{ ##branch }
-} 1 test-bb
-V{ T{ ##branch } } 2 test-bb
-V{ T{ ##branch } } 3 test-bb
-V{
-    
-    T{ ##replace f 1 D 1 }
-    T{ ##replace f 2 D 2 }
-    T{ ##replace f 3 D 3 }
-    T{ ##replace f 4 D 4 }
-    T{ ##replace f 0 D 0 }
-    T{ ##branch }
-} 4 test-bb
-V{ T{ ##replace f 0 D 0 } T{ ##branch } } 5 test-bb
-V{ T{ ##return } } 6 test-bb
-V{ T{ ##branch } } 7 test-bb
-V{
-    T{ ##replace f 1 D 1 }
-    T{ ##replace f 2 D 2 }
-    T{ ##replace f 3 D 3 }
-    T{ ##peek f 5 D 1 }
-    T{ ##peek f 6 D 2 }
-    T{ ##peek f 7 D 3 }
-    T{ ##peek f 8 D 4 }
-    T{ ##replace f 5 D 1 }
-    T{ ##replace f 6 D 2 }
-    T{ ##replace f 7 D 3 }
-    T{ ##replace f 8 D 4 }
-    T{ ##branch }
-} 8 test-bb
-V{
-    T{ ##replace f 1 D 1 }
-    T{ ##replace f 2 D 2 }
-    T{ ##replace f 3 D 3 }
-    T{ ##return }
-} 9 test-bb
-
-0 1 edge
-1 { 2 7 } edges
-7 8 edge
-8 9 edge
-2 { 3 5 } edges
-3 4 edge
-4 9 edge
-5 6 edge
-
-[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
-
-[ ##spill ] [ 1 get instructions>> second class ] unit-test
-[ ##reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
-[ V{ 3 2 1 } ] [ 8 get instructions>> [ ##spill? ] filter [ dst>> n>> cell / ] map ] unit-test
-[ V{ 3 2 1 } ] [ 9 get instructions>> [ ##reload? ] filter [ src>> n>> cell / ] map ] unit-test
-
-! Resolve pass should insert this
-[ ##reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
-
-! Some random bug
-V{
-    T{ ##peek f 1 D 1 }
-    T{ ##peek f 2 D 2 }
-    T{ ##replace f 1 D 1 }
-    T{ ##replace f 2 D 2 }
-    T{ ##peek f 3 D 0 }
-    T{ ##peek f 0 D 0 }
-    T{ ##branch }
-} 0 test-bb
-
-V{ T{ ##branch } } 1 test-bb
-
-V{
-    T{ ##peek f 1 D 1 }
-    T{ ##peek f 2 D 2 }
-    T{ ##replace f 3 D 3 }
-    T{ ##replace f 1 D 1 }
-    T{ ##replace f 2 D 2 }
-    T{ ##replace f 0 D 3 }
-    T{ ##branch }
-} 2 test-bb
-
-V{ T{ ##branch } } 3 test-bb
-
-V{
-    T{ ##return }
-} 4 test-bb
-
-test-diamond
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-! Spilling an interval immediately after its activated;
-! and the interval does not have a use at the activation point
-V{
-    T{ ##peek f 1 D 1 }
-    T{ ##peek f 2 D 2 }
-    T{ ##replace f 1 D 1 }
-    T{ ##replace f 2 D 2 }
-    T{ ##peek f 0 D 0 }
-    T{ ##branch }
-} 0 test-bb
-
-V{ T{ ##branch } } 1 test-bb
-
-V{
-    T{ ##peek f 1 D 1 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##replace f 1 D 1 }
-    T{ ##peek f 2 D 2 }
-    T{ ##replace f 2 D 2 }
-    T{ ##branch }
-} 3 test-bb
-
-V{ T{ ##branch } } 4 test-bb
-
-V{
-    T{ ##replace f 0 D 0 }
-    T{ ##return }
-} 5 test-bb
-
-0 1 edge
-1 { 2 4 } edges
-4 5 edge
-2 3 edge
-3 5 edge
-
-[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-
-! Reduction of push-all regression, x86-32
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
-    T{ ##load-integer { dst 61 } }
-    T{ ##peek { dst 62 } { loc D 0 } }
-    T{ ##peek { dst 64 } { loc D 1 } }
-    T{ ##slot-imm
-        { dst 69 }
-        { obj 64 }
-        { slot 1 }
-        { tag 2 }
-    }
-    T{ ##copy { dst 79 } { src 69 } { rep int-rep } }
-    T{ ##slot-imm
-        { dst 85 }
-        { obj 62 }
-        { slot 2 }
-        { tag 7 }
-    }
-    T{ ##compare-branch
-        { src1 69 }
-        { src2 85 }
-        { cc cc> }
-    }
-} 1 test-bb
-
-V{
-    T{ ##slot-imm
-        { dst 97 }
-        { obj 62 }
-        { slot 2 }
-        { tag 7 }
-    }
-    T{ ##replace { src 79 } { loc D 3 } }
-    T{ ##replace { src 62 } { loc D 4 } }
-    T{ ##replace { src 79 } { loc D 1 } }
-    T{ ##replace { src 62 } { loc D 2 } }
-    T{ ##replace { src 61 } { loc D 5 } }
-    T{ ##replace { src 62 } { loc R 0 } }
-    T{ ##replace { src 69 } { loc R 1 } }
-    T{ ##replace { src 97 } { loc D 0 } }
-    T{ ##call { word resize-array } }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##peek { dst 98 } { loc R 0 } }
-    T{ ##peek { dst 100 } { loc D 0 } }
-    T{ ##set-slot-imm
-        { src 100 }
-        { obj 98 }
-        { slot 2 }
-        { tag 7 }
-    }
-    T{ ##peek { dst 108 } { loc D 2 } }
-    T{ ##peek { dst 110 } { loc D 3 } }
-    T{ ##peek { dst 112 } { loc D 0 } }
-    T{ ##peek { dst 114 } { loc D 1 } }
-    T{ ##peek { dst 116 } { loc D 4 } }
-    T{ ##peek { dst 119 } { loc R 0 } }
-    T{ ##copy { dst 109 } { src 108 } { rep int-rep } }
-    T{ ##copy { dst 111 } { src 110 } { rep int-rep } }
-    T{ ##copy { dst 113 } { src 112 } { rep int-rep } }
-    T{ ##copy { dst 115 } { src 114 } { rep int-rep } }
-    T{ ##copy { dst 117 } { src 116 } { rep int-rep } }
-    T{ ##copy { dst 120 } { src 119 } { rep int-rep } }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##copy { dst 109 } { src 62 } { rep int-rep } }
-    T{ ##copy { dst 111 } { src 61 } { rep int-rep } }
-    T{ ##copy { dst 113 } { src 62 } { rep int-rep } }
-    T{ ##copy { dst 115 } { src 79 } { rep int-rep } }
-    T{ ##copy { dst 117 } { src 64 } { rep int-rep } }
-    T{ ##copy { dst 120 } { src 69 } { rep int-rep } }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##replace { src 120 } { loc D 0 } }
-    T{ ##replace { src 109 } { loc D 3 } }
-    T{ ##replace { src 111 } { loc D 4 } }
-    T{ ##replace { src 113 } { loc D 1 } }
-    T{ ##replace { src 115 } { loc D 2 } }
-    T{ ##replace { src 117 } { loc D 5 } }
-    T{ ##epilogue }
-    T{ ##return }
-} 5 test-bb
-
-0 1 edge
-1 { 2 4 } edges
-2 3 edge
-3 5 edge
-4 5 edge
-
-[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
-
-! Another reduction of push-all
-V{ T{ ##prologue } T{ ##branch } } 0 test-bb
-
-V{
-    T{ ##peek { dst 85 } { loc D 0 } }
-    T{ ##slot-imm
-        { dst 89 }
-        { obj 85 }
-        { slot 3 }
-        { tag 7 }
-    }
-    T{ ##peek { dst 91 } { loc D 1 } }
-    T{ ##slot-imm
-        { dst 96 }
-        { obj 91 }
-        { slot 1 }
-        { tag 2 }
-    }
-    T{ ##add
-        { dst 109 }
-        { src1 89 }
-        { src2 96 }
-    }
-    T{ ##slot-imm
-        { dst 115 }
-        { obj 85 }
-        { slot 2 }
-        { tag 7 }
-    }
-    T{ ##slot-imm
-        { dst 118 }
-        { obj 115 }
-        { slot 1 }
-        { tag 2 }
-    }
-    T{ ##compare-branch
-        { src1 109 }
-        { src2 118 }
-        { cc cc> }
-    }
-} 1 test-bb
-
-V{
-    T{ ##add-imm
-        { dst 128 }
-        { src1 109 }
-        { src2 8 }
-    }
-    T{ ##load-integer { dst 129 } { val 24 } }
-    T{ ##inc-d { n 4 } }
-    T{ ##inc-r { n 1 } }
-    T{ ##replace { src 109 } { loc D 2 } }
-    T{ ##replace { src 85 } { loc D 3 } }
-    T{ ##replace { src 128 } { loc D 0 } }
-    T{ ##replace { src 85 } { loc D 1 } }
-    T{ ##replace { src 89 } { loc D 4 } }
-    T{ ##replace { src 96 } { loc R 0 } }
-    T{ ##replace { src 129 } { loc R 0 } }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##peek { dst 134 } { loc D 1 } }
-    T{ ##slot-imm
-        { dst 140 }
-        { obj 134 }
-        { slot 2 }
-        { tag 7 }
-    }
-    T{ ##inc-d { n 1 } }
-    T{ ##inc-r { n 1 } }
-    T{ ##replace { src 140 } { loc D 0 } }
-    T{ ##replace { src 134 } { loc R 0 } }
-    T{ ##call { word resize-array } }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##peek { dst 141 } { loc R 0 } }
-    T{ ##peek { dst 143 } { loc D 0 } }
-    T{ ##set-slot-imm
-        { src 143 }
-        { obj 141 }
-        { slot 2 }
-        { tag 7 }
-    }
-    T{ ##write-barrier-imm
-        { src 141 }
-        { slot 2 }
-        { temp1 145 }
-        { temp2 146 }
-    }
-    T{ ##inc-d { n -1 } }
-    T{ ##inc-r { n -1 } }
-    T{ ##peek { dst 156 } { loc D 2 } }
-    T{ ##peek { dst 158 } { loc D 3 } }
-    T{ ##peek { dst 160 } { loc D 0 } }
-    T{ ##peek { dst 162 } { loc D 1 } }
-    T{ ##peek { dst 164 } { loc D 4 } }
-    T{ ##peek { dst 167 } { loc R 0 } }
-    T{ ##copy { dst 157 } { src 156 } { rep int-rep } }
-    T{ ##copy { dst 159 } { src 158 } { rep int-rep } }
-    T{ ##copy { dst 161 } { src 160 } { rep int-rep } }
-    T{ ##copy { dst 163 } { src 162 } { rep int-rep } }
-    T{ ##copy { dst 165 } { src 164 } { rep int-rep } }
-    T{ ##copy { dst 168 } { src 167 } { rep int-rep } }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##inc-d { n 3 } }
-    T{ ##inc-r { n 1 } }
-    T{ ##copy { dst 157 } { src 85 } }
-    T{ ##copy { dst 159 } { src 89 } }
-    T{ ##copy { dst 161 } { src 85 } }
-    T{ ##copy { dst 163 } { src 109 } }
-    T{ ##copy { dst 165 } { src 91 } }
-    T{ ##copy { dst 168 } { src 96 } }
-    T{ ##branch }
-} 5 test-bb
-
-V{
-    T{ ##set-slot-imm
-        { src 163 }
-        { obj 161 }
-        { slot 3 }
-        { tag 7 }
-    }
-    T{ ##inc-d { n 1 } }
-    T{ ##inc-r { n -1 } }
-    T{ ##replace { src 168 } { loc D 0 } }
-    T{ ##replace { src 157 } { loc D 3 } }
-    T{ ##replace { src 159 } { loc D 4 } }
-    T{ ##replace { src 161 } { loc D 1 } }
-    T{ ##replace { src 163 } { loc D 2 } }
-    T{ ##replace { src 165 } { loc D 5 } }
-    T{ ##epilogue }
-    T{ ##return }
-} 6 test-bb
-
-0 1 edge
-1 { 2 5 } edges
-2 3 edge
-3 4 edge
-4 6 edge
-5 6 edge
-
-[ ] [ { 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 0 D 0 }
-    T{ ##compare-imm-branch f 0 5 cc= }
-} 1 test-bb
-
-V{ T{ ##branch } } 2 test-bb
-
-V{
-    T{ ##peek f 1 D 0 }
-    T{ ##peek f 2 D 0 }
-    T{ ##replace f 1 D 0 }
-    T{ ##replace f 2 D 0 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##replace f 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 predecessors>> first 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 0 D 0 }
-    T{ ##compare-imm-branch f 0 5 cc= }
-} 1 test-bb
-
-V{
-    T{ ##peek f 1 D 0 }
-    T{ ##peek f 2 D 0 }
-    T{ ##replace f 1 D 0 }
-    T{ ##replace f 2 D 0 }
-    T{ ##replace f 0 D 0 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##replace f 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
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index b7084fb2d8..c9c4327be6 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -28,15 +28,11 @@ IN: compiler.cfg.value-numbering.tests
     {
         T{ ##load-reference f 0 0.0 }
         T{ ##load-reference f 1 -0.0 }
-        T{ ##replace f 0 D 0 }
-        T{ ##replace f 1 D 1 }
     }
 ] [
     {
         T{ ##load-reference f 0 0.0 }
         T{ ##load-reference f 1 -0.0 }
-        T{ ##replace f 0 D 0 }
-        T{ ##replace f 1 D 1 }
     } value-numbering-step
 ] unit-test
 
@@ -44,15 +40,11 @@ IN: compiler.cfg.value-numbering.tests
     {
         T{ ##load-reference f 0 0.0 }
         T{ ##copy f 1 0 any-rep }
-        T{ ##replace f 0 D 0 }
-        T{ ##replace f 1 D 1 }
     }
 ] [
     {
         T{ ##load-reference f 0 0.0 }
         T{ ##load-reference f 1 0.0 }
-        T{ ##replace f 0 D 0 }
-        T{ ##replace f 1 D 1 }
     } value-numbering-step
 ] unit-test
 
@@ -60,15 +52,11 @@ IN: compiler.cfg.value-numbering.tests
     {
         T{ ##load-reference f 0 t }
         T{ ##copy f 1 0 any-rep }
-        T{ ##replace f 0 D 0 }
-        T{ ##replace f 1 D 1 }
     }
 ] [
     {
         T{ ##load-reference f 0 t }
         T{ ##load-reference f 1 t }
-        T{ ##replace f 0 D 0 }
-        T{ ##replace f 1 D 1 }
     } value-numbering-step
 ] unit-test
 
@@ -508,7 +496,7 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 100 }
-        T{ ##compare-imm f 2 0 $[ 100 tag-fixnum ] cc= }
+        T{ ##compare-imm f 2 0 100 cc= }
     }
 ] [
     {
@@ -562,33 +550,35 @@ cpu x86.32? [
     ] unit-test
 ] when
 
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 3.5 }
-        T{ ##compare f 2 0 1 cc= }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 3.5 }
-        T{ ##compare f 2 0 1 cc= }
-    } value-numbering-step trim-temps
-] unit-test
+cpu x86.32? [
+    [
+        {
+            T{ ##peek f 0 D 0 }
+            T{ ##load-reference f 1 3.5 }
+            T{ ##compare f 2 0 1 cc= }
+        }
+    ] [
+        {
+            T{ ##peek f 0 D 0 }
+            T{ ##load-reference f 1 3.5 }
+            T{ ##compare f 2 0 1 cc= }
+        } value-numbering-step trim-temps
+    ] unit-test
 
-[
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 3.5 }
-        T{ ##compare-branch f 0 1 cc= }
-    }
-] [
-    {
-        T{ ##peek f 0 D 0 }
-        T{ ##load-reference f 1 3.5 }
-        T{ ##compare-branch f 0 1 cc= }
-    } value-numbering-step trim-temps
-] unit-test
+    [
+        {
+            T{ ##peek f 0 D 0 }
+            T{ ##load-reference f 1 3.5 }
+            T{ ##compare-branch f 0 1 cc= }
+        }
+    ] [
+        {
+            T{ ##peek f 0 D 0 }
+            T{ ##load-reference f 1 3.5 }
+            T{ ##compare-branch f 0 1 cc= }
+        } value-numbering-step trim-temps
+    ] unit-test
+] unless
 
 [
     {
@@ -818,7 +808,7 @@ cpu x86.32? [
 [
     {
         T{ ##load-integer f 1 10 }
-        T{ ##load-reference f 2 f }
+        T{ ##load-reference f 2 t }
     }
 ] [
     {
@@ -830,12 +820,12 @@ cpu x86.32? [
 [
     {
         T{ ##load-integer f 1 10 }
-        T{ ##load-reference f 2 t }
+        T{ ##load-reference f 2 f }
     }
 ] [
     {
         T{ ##load-integer f 1 10 }
-        T{ ##compare-imm f 2 1 $[ 10 tag-fixnum ] cc= }
+        T{ ##compare-imm f 2 1 20 cc= }
     } value-numbering-step
 ] unit-test
 
@@ -847,7 +837,7 @@ cpu x86.32? [
 ] [
     {
         T{ ##load-integer f 1 10 }
-        T{ ##compare-imm f 2 1 10 cc/= }
+        T{ ##compare-imm f 2 1 100 cc/= }
     } value-numbering-step
 ] unit-test
 
@@ -859,7 +849,7 @@ cpu x86.32? [
 ] [
     {
         T{ ##load-integer f 1 10 }
-        T{ ##compare-imm f 2 1 $[ 10 tag-fixnum ] cc/= }
+        T{ ##compare-imm f 2 1 10 cc/= }
     } value-numbering-step
 ] unit-test
 
@@ -1390,13 +1380,11 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 0 }
-        T{ ##replace f 1 D 0 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
         T{ ##and-imm f 1 0 0 }
-        T{ ##replace f 1 D 0 }
     } value-numbering-step
 ] unit-test
 
@@ -1446,13 +1434,11 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 -1 }
-        T{ ##replace f 1 D 0 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
         T{ ##or-imm f 1 0 -1 }
-        T{ ##replace f 1 D 0 }
     } value-numbering-step
 ] unit-test
 
@@ -1502,13 +1488,11 @@ cpu x86.32? [
     {
         T{ ##peek f 0 D 0 }
         T{ ##load-integer f 1 0 }
-        T{ ##replace f 1 D 0 }
     }
 ] [
     {
         T{ ##peek f 0 D 0 }
         T{ ##xor f 1 0 0 }
-        T{ ##replace f 1 D 0 }
     } value-numbering-step
 ] unit-test
 
diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index 5cba592163..60c68072ec 100644
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -1,8 +1,9 @@
 USING: accessors assocs compiler compiler.cfg
 compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr
-compiler.cfg.registers compiler.cfg.linear-scan compiler.codegen
-compiler.units cpu.architecture hashtables kernel namespaces
-sequences tools.test vectors words layouts literals math arrays
+compiler.cfg.registers compiler.cfg.linear-scan
+compiler.cfg.ssa.destruction compiler.codegen compiler.units
+cpu.architecture hashtables kernel namespaces sequences
+tools.test vectors words layouts literals math arrays
 alien.c-types alien.syntax math.private ;
 IN: compiler.tests.low-level-ir
 
@@ -15,6 +16,7 @@ IN: compiler.tests.low-level-ir
     cfg new 0 get >>entry
     dup cfg set
     dup fake-representations
+    destruct-ssa
     compile-cfg ;
 
 : compile-test-bb ( insns -- result )
diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor
index 2dee88df88..ad1b4ad2b7 100644
--- a/basis/specialized-arrays/specialized-arrays-tests.factor
+++ b/basis/specialized-arrays/specialized-arrays-tests.factor
@@ -188,5 +188,6 @@ SPECIALIZED-ARRAY: struct-resize-test
 [ ] [
     [
         struct-resize-test specialized-array-vocab forget-vocab
+        \ struct-resize-test-usage forget
     ] with-compilation-unit
 ] unit-test
diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor
index 3321dbe2ed..1009081236 100644
--- a/core/alien/alien-tests.factor
+++ b/core/alien/alien-tests.factor
@@ -64,13 +64,13 @@ cell 8 = [
 
 [ 1 1 <displaced-alien> ] must-fail
 
-[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
+[ f ] [ 1 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
 
-[ f ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
+[ f ] [ 2 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
 
 [ t ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> underlying>> byte-array? ] unit-test
 
-[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
+[ "( displaced alien )" ] [ 1 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
 
 SYMBOL: initialize-test
 

From 0fbf454b186371d1a2aef800a18ee126f27494e5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 May 2010 16:22:08 -0400
Subject: [PATCH 152/158] compiler.tree.propagation: fix both-fixnums? trick

---
 .../tree/propagation/known-words/known-words.factor   | 10 ----------
 .../tree/propagation/transforms/transforms.factor     | 11 +++++++++++
 2 files changed, 11 insertions(+), 10 deletions(-)

diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 351da4e2f8..7fb36c96fd 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -220,16 +220,6 @@ generic-comparison-ops [
     2bi and maybe-or-never
 ] "outputs" set-word-prop
 
-\ both-fixnums? [
-    node-input-infos first2 [ class>> ] bi@ {
-        { [ 2dup [ fixnum classes-intersect? not ] either? ] [ [ 2drop f ] ] }
-        { [ 2dup [ fixnum class<= ] both? ] [ [ 2drop t ] ] }
-        { [ dup fixnum class<= ] [ [ drop fixnum? ] ] }
-        { [ over fixnum class<= ] [ [ nip fixnum? ] ] }
-        [ f ]
-    } cond 2nip
-] "custom-inlining" set-word-prop
-
 {
     { >fixnum fixnum }
     { bignum>fixnum fixnum }
diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index f8d43e37c4..3d2d7ac298 100644
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -313,3 +313,14 @@ M\ set intersect [ intersect-quot ] 1 define-partial-eval
         [ depends-on-definition ] [ heap-size '[ _ ] ] bi
     ] [ drop f ] if
 ] 1 define-partial-eval
+
+! Eliminates a few redundant checks here and there
+\ both-fixnums? [
+    in-d>> first2 [ value-info class>> ] bi@ {
+        { [ 2dup [ fixnum classes-intersect? not ] either? ] [ [ 2drop f ] ] }
+        { [ 2dup [ fixnum class<= ] both? ] [ [ 2drop t ] ] }
+        { [ dup fixnum class<= ] [ [ drop fixnum? ] ] }
+        { [ over fixnum class<= ] [ [ nip fixnum? ] ] }
+        [ f ]
+    } cond 2nip
+] "custom-inlining" set-word-prop

From 5236f327ba6d1b69b75ae92b1ae7c09a8022274d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 May 2010 16:22:22 -0400
Subject: [PATCH 153/158] compiler.cfg.debugger: add ssa. word to print IR
 before representation selection runs

---
 basis/compiler/cfg/debugger/debugger.factor | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 8cbd23db02..0d74531961 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -74,8 +74,9 @@ M: insn insn. tuple>array but-last [ bl ] [ pprint ] interleave nl ;
 : mrs. ( mrs -- )
     [ nl ] [ mr. ] interleave ;
 
-: flat. ( quot -- ) test-flat mrs. ; inline
-: regs. ( quot -- ) test-regs mrs. ; inline
+: ssa. ( quot -- ) test-ssa mrs. ;
+: flat. ( quot -- ) test-flat mrs. ;
+: regs. ( quot -- ) test-regs mrs. ;
 
 ! Prettyprinting
 : pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;

From f5c5d8b44cf7b3f87a7623af3263349dfd8f6717 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 May 2010 18:48:41 -0400
Subject: [PATCH 154/158] compiler: remove flat machine representation and
 generate code directly from the CFG

---
 .../build-stack-frame.factor                  |  47 +--
 .../compiler/cfg/builder/builder-tests.factor |  21 +-
 basis/compiler/cfg/cfg.factor                 |   9 +-
 basis/compiler/cfg/checker/checker.factor     |  17 +-
 basis/compiler/cfg/debugger/debugger.factor   |  55 +--
 basis/compiler/cfg/def-use/def-use.factor     |   6 +-
 .../cfg/finalization/finalization.factor      |   8 +-
 .../cfg/instructions/instructions.factor      |  37 +-
 .../linear-scan/allocation/state/state.factor |   2 +-
 .../linear-scan/assignment/assignment.factor  |   2 +-
 .../cfg/linear-scan/linear-scan-tests.factor  |   1 -
 .../live-intervals/live-intervals.factor      |   2 +-
 .../linear-scan/numbering/numbering.factor    |   2 +-
 ...ests.factor => linearization-tests.factor} |   4 +-
 .../cfg/linearization/linearization.factor    | 147 ++++----
 .../cfg/linearization/order/order.factor      |  84 -----
 basis/compiler/cfg/linearization/summary.txt  |   1 -
 basis/compiler/cfg/mr/authors.txt             |   1 -
 basis/compiler/cfg/mr/mr.factor               |   8 -
 .../cfg/stack-frame/stack-frame.factor        |  15 +-
 basis/compiler/codegen/alien/alien.factor     | 231 +++++++++++++
 basis/compiler/codegen/alien/authors.txt      |   1 +
 basis/compiler/codegen/codegen.factor         | 322 ++++--------------
 basis/compiler/compiler.factor                |  10 +-
 basis/compiler/tests/low-level-ir.factor      |  12 +-
 basis/cpu/x86/32/32.factor                    |   9 +-
 26 files changed, 488 insertions(+), 566 deletions(-)
 rename basis/compiler/cfg/linearization/{order/order-tests.factor => linearization-tests.factor} (83%)
 delete mode 100644 basis/compiler/cfg/linearization/order/order.factor
 delete mode 100644 basis/compiler/cfg/linearization/summary.txt
 delete mode 100644 basis/compiler/cfg/mr/authors.txt
 delete mode 100644 basis/compiler/cfg/mr/mr.factor
 create mode 100644 basis/compiler/codegen/alien/alien.factor
 create mode 100644 basis/compiler/codegen/alien/authors.txt

diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
index 49dfb95164..8f98ab7add 100644
--- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
+++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math.order assocs kernel sequences
-combinators make classes words cpu.architecture layouts
-compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.stack-frame ;
+combinators classes words cpu.architecture layouts compiler.cfg
+compiler.cfg.rpo compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.stack-frame ;
 IN: compiler.cfg.build-stack-frame
 
 SYMBOL: frame-required?
@@ -30,43 +30,24 @@ M: ##call-gc compute-stack-frame*
     frame-required? on
     stack-frame new t >>calls-vm? request-stack-frame ;
 
-M: _spill-area-size compute-stack-frame*
-    n>> stack-frame get (>>spill-area-size) ;
-
 M: insn compute-stack-frame*
-    class frame-required? word-prop [
-        frame-required? on
-    ] when ;
+    class "frame-required?" word-prop
+    [ frame-required? on ] when ;
 
-! PowerPC backend sets frame-required? for ##integer>float!
-\ ##spill t frame-required? set-word-prop
-\ ##unary-float-function t frame-required? set-word-prop
-\ ##binary-float-function t frame-required? set-word-prop
+: initial-stack-frame ( -- stack-frame )
+    stack-frame new cfg get spill-area-size>> >>spill-area-size ;
 
 : compute-stack-frame ( insns -- )
     frame-required? off
-    stack-frame new stack-frame set
-    [ compute-stack-frame* ] each
+    initial-stack-frame stack-frame set
+    [ instructions>> [ compute-stack-frame* ] each ] each-basic-block
     stack-frame get dup stack-frame-size >>total-size drop ;
 
-GENERIC: insert-pro/epilogues* ( insn -- )
-
-M: ##prologue insert-pro/epilogues*
-    drop frame-required? get [ stack-frame get _prologue ] when ;
-
-M: ##epilogue insert-pro/epilogues*
-    drop frame-required? get [ stack-frame get _epilogue ] when ;
-
-M: insn insert-pro/epilogues* , ;
-
-: insert-pro/epilogues ( insns -- insns )
-    [ [ insert-pro/epilogues* ] each ] { } make ;
-
-: build-stack-frame ( mr -- mr )
+: build-stack-frame ( cfg -- cfg )
     [
+        [ compute-stack-frame ]
         [
-            [ compute-stack-frame ]
-            [ insert-pro/epilogues ]
-            bi
-        ] change-instructions
+            frame-required? get stack-frame get f ?
+            >>stack-frame
+        ] bi
     ] with-scope ;
diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index b8fde7fef6..5d2c5e2e3c 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -1,12 +1,13 @@
 USING: tools.test kernel sequences words sequences.private fry
-prettyprint alien alien.accessors math.private compiler.tree.builder
-compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
-compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
-compiler.cfg arrays locals byte-arrays kernel.private math
-slots.private vectors sbufs strings math.partial-dispatch
-hashtables assocs combinators.short-circuit
-strings.private accessors compiler.cfg.instructions
-compiler.cfg.representations ;
+prettyprint alien alien.accessors math.private
+compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.debugger
+compiler.cfg.optimizer compiler.cfg.rpo
+compiler.cfg.predecessors compiler.cfg.checker compiler.cfg
+arrays locals byte-arrays kernel.private math slots.private
+vectors sbufs strings math.partial-dispatch hashtables assocs
+combinators.short-circuit strings.private accessors
+compiler.cfg.instructions compiler.cfg.representations ;
 FROM: alien.c-types => int ;
 IN: compiler.cfg.builder.tests
 
@@ -161,8 +162,8 @@ IN: compiler.cfg.builder.tests
 ] each
 
 : count-insns ( quot insn-check -- ? )
-    [ test-regs [ instructions>> ] map ] dip
-    '[ _ count ] map-sum ; inline
+    [ test-regs [ post-order [ instructions>> ] map concat ] map concat ] dip
+    count ; inline
 
 : contains-insn? ( quot insn-check -- ? )
     count-insns 0 > ; inline
diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 1391c37077..c49d638509 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -22,6 +22,7 @@ M: basic-block hashcode* nip id>> ;
 
 TUPLE: cfg { entry basic-block } word label
 spill-area-size
+stack-frame
 post-order linear-order
 predecessors-valid? dominance-valid? loops-valid? ;
 
@@ -42,11 +43,3 @@ predecessors-valid? dominance-valid? loops-valid? ;
 
 : with-cfg ( ..a cfg quot: ( ..a cfg -- ..b ) -- ..b )
     [ dup cfg ] dip with-variable ; inline
-
-TUPLE: mr { instructions array } word label ;
-
-: <mr> ( instructions word label -- mr )
-    mr new
-        swap >>label
-        swap >>word
-        swap >>instructions ;
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index b84742b8b0..d7a48a1511 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -3,7 +3,7 @@
 USING: kernel combinators.short-circuit accessors math sequences
 sets assocs compiler.cfg.instructions compiler.cfg.rpo
 compiler.cfg.def-use compiler.cfg.linearization
-compiler.cfg.utilities compiler.cfg.finalization compiler.cfg.mr
+compiler.cfg.utilities compiler.cfg.finalization
 compiler.utilities ;
 IN: compiler.cfg.checker
 
@@ -52,18 +52,5 @@ ERROR: bad-successors ;
     [ check-successors ]
     bi ;
 
-ERROR: bad-live-in ;
-
-ERROR: undefined-values uses defs ;
-
-: check-mr ( mr -- )
-    ! Check that every used register has a definition
-    instructions>>
-    [ [ uses-vregs ] map concat ]
-    [ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi
-    2dup subset? [ 2drop ] [ undefined-values ] if ;
-
 : check-cfg ( cfg -- )
-    [ [ check-basic-block ] each-basic-block ]
-    [ finalize-cfg build-mr check-mr ]
-    bi ;
+    [ check-basic-block ] each-basic-block ;
diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 0d74531961..dc0be45cc0 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words sequences quotations namespaces io vectors
 arrays hashtables classes.tuple accessors prettyprint
@@ -9,10 +9,11 @@ compiler.cfg.linearization compiler.cfg.registers
 compiler.cfg.stack-frame compiler.cfg.linear-scan
 compiler.cfg.optimizer compiler.cfg.finalization
 compiler.cfg.instructions compiler.cfg.utilities
-compiler.cfg.def-use compiler.cfg.rpo compiler.cfg.mr
-compiler.cfg.representations
-compiler.cfg.representations.preferred
-compiler.cfg.gc-checks compiler.cfg.save-contexts compiler.cfg ;
+compiler.cfg.def-use compiler.cfg.rpo
+compiler.cfg.representations compiler.cfg.gc-checks
+compiler.cfg.save-contexts compiler.cfg
+compiler.cfg.representations.preferred ;
+FROM: compiler.cfg.linearization => number-blocks ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-builder ( quot -- cfgs )
@@ -28,31 +29,28 @@ M: word test-builder
 : test-optimizer ( quot -- cfgs )
     test-builder [ [ optimize-cfg ] with-cfg ] map ;
 
-: test-ssa ( quot -- mrs )
+: test-ssa ( quot -- cfgs )
     test-builder [
         [
             optimize-cfg
-            flatten-cfg
         ] with-cfg
     ] map ;
 
-: test-flat ( quot -- mrs )
+: test-flat ( quot -- cfgs )
     test-builder [
         [
             optimize-cfg
             select-representations
             insert-gc-checks
             insert-save-contexts
-            flatten-cfg
         ] with-cfg
     ] map ;
 
-: test-regs ( quot -- mrs )
+: test-regs ( quot -- cfgs )
     test-builder [
         [
             optimize-cfg
             finalize-cfg
-            build-mr
         ] with-cfg
     ] map ;
 
@@ -64,19 +62,32 @@ M: ##phi insn.
 
 M: insn insn. tuple>array but-last [ bl ] [ pprint ] interleave nl ;
 
-: mr. ( mr -- )
-    "=== word: " write
-    dup word>> pprint
-    ", label: " write
-    dup label>> pprint nl nl
-    instructions>> [ insn. ] each ;
+: block. ( bb -- )
+    "=== Basic block #" write dup block-number . nl
+    dup instructions>> [ insn. ] each nl
+    successors>> [
+        "Successors: " write
+        [ block-number unparse ] map ", " join print nl
+    ] unless-empty ;
 
-: mrs. ( mrs -- )
-    [ nl ] [ mr. ] interleave ;
+: cfg. ( cfg -- )
+    [
+        dup linearization-order number-blocks
+        "=== word: " write
+        dup word>> pprint
+        ", label: " write
+        dup label>> pprint nl nl
+        dup linearization-order [ block. ] each
+        "=== stack frame: " write
+        stack-frame>> .
+    ] with-scope ;
 
-: ssa. ( quot -- ) test-ssa mrs. ;
-: flat. ( quot -- ) test-flat mrs. ;
-: regs. ( quot -- ) test-regs mrs. ;
+: cfgs. ( cfgs -- )
+    [ nl ] [ cfg. ] interleave ;
+
+: ssa. ( quot -- ) test-ssa cfgs. ;
+: flat. ( quot -- ) test-flat cfgs. ;
+: regs. ( quot -- ) test-regs cfgs. ;
 
 ! Prettyprinting
 : pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index a576a54884..93c1a53b44 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -19,10 +19,6 @@ M: insn uses-vregs drop { } ;
 
 M: ##phi uses-vregs inputs>> values ;
 
-M: _conditional-branch defs-vreg insn>> defs-vreg ;
-
-M: _conditional-branch uses-vregs insn>> uses-vregs ;
-
 <PRIVATE
 
 : slot-array-quot ( slots -- quot )
@@ -59,7 +55,7 @@ PRIVATE>
 [
     insn-classes get
     [ [ define-defs-vreg-method ] each ]
-    [ { ##phi _conditional-branch } diff [ define-uses-vregs-method ] each ]
+    [ { ##phi } diff [ define-uses-vregs-method ] each ]
     [ [ define-temp-vregs-method ] each ]
     tri
 ] with-compilation-unit
diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor
index 24097d63a4..3ee7ba06e3 100644
--- a/basis/compiler/cfg/finalization/finalization.factor
+++ b/basis/compiler/cfg/finalization/finalization.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler.cfg.empty-blocks compiler.cfg.gc-checks
-compiler.cfg.linear-scan compiler.cfg.representations
-compiler.cfg.save-contexts compiler.cfg.ssa.destruction ;
+compiler.cfg.representations compiler.cfg.save-contexts
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
+compiler.cfg.linear-scan ;
 IN: compiler.cfg.finalization
 
 : finalize-cfg ( cfg -- cfg' )
@@ -10,4 +11,5 @@ IN: compiler.cfg.finalization
     insert-gc-checks
     insert-save-contexts
     destruct-ssa
-    linear-scan ;
+    linear-scan
+    build-stack-frame ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index e483b707ae..d4e019d8dd 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -67,6 +67,10 @@ literal: word ;
 INSN: ##jump
 literal: word ;
 
+INSN: ##prologue ;
+
+INSN: ##epilogue ;
+
 INSN: ##return ;
 
 ! Dummy instruction that simply inhibits TCO
@@ -613,16 +617,13 @@ literal: params stack-frame ;
 INSN: ##alien-callback
 literal: params stack-frame ;
 
-! Instructions used by CFG IR only.
-INSN: ##prologue ;
-INSN: ##epilogue ;
-
-INSN: ##branch ;
-
+! Control flow
 INSN: ##phi
 def: dst
 literal: inputs ;
 
+INSN: ##branch ;
+
 ! Tagged conditionals
 INSN: ##compare-branch
 use: src1/tagged-rep src2/tagged-rep
@@ -725,30 +726,6 @@ INSN: ##reload
 def: dst
 literal: rep src ;
 
-! Instructions used by machine IR only.
-INSN: _spill-area-size
-literal: n ;
-
-INSN: _prologue
-literal: stack-frame ;
-
-INSN: _epilogue
-literal: stack-frame ;
-
-INSN: _label
-literal: label ;
-
-INSN: _branch
-literal: label ;
-
-INSN: _loop-entry ;
-
-INSN: _dispatch-label
-literal: label ;
-
-INSN: _conditional-branch
-literal: label insn ;
-
 UNION: ##allocation
 ##allot
 ##box-alien
diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
index f9e6fc6a36..89ec1b7785 100644
--- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
@@ -117,7 +117,7 @@ SYMBOL: unhandled-intervals
 : reg-class-assoc ( quot -- assoc )
     [ reg-classes ] dip { } map>assoc ; inline
 
-: next-spill-slot ( rep -- n )
+: next-spill-slot ( size -- n )
     cfg get
     [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
     <spill-slot> ;
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index b160bd776c..1682cf9eb6 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -9,9 +9,9 @@ compiler.cfg.liveness
 compiler.cfg.liveness.ssa
 compiler.cfg.registers
 compiler.cfg.instructions
+compiler.cfg.linearization
 compiler.cfg.ssa.destruction
 compiler.cfg.renaming.functor
-compiler.cfg.linearization.order
 compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.live-intervals ;
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index eb2dc2d64d..9e6ec76d2c 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -8,7 +8,6 @@ compiler.cfg.instructions
 compiler.cfg.registers
 compiler.cfg.predecessors
 compiler.cfg.rpo
-compiler.cfg.linearization
 compiler.cfg.debugger
 compiler.cfg.def-use
 compiler.cfg.comparisons
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index 9766bb62d1..cb697c2136 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -6,7 +6,7 @@ compiler.cfg.instructions
 compiler.cfg.registers
 compiler.cfg.def-use
 compiler.cfg.liveness
-compiler.cfg.linearization.order
+compiler.cfg.linearization
 compiler.cfg.ssa.destruction
 compiler.cfg
 cpu.architecture ;
diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor
index 44b2ff907a..391edf21d6 100644
--- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor
+++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors math sequences grouping namespaces
-compiler.cfg.linearization.order ;
+compiler.cfg.linearization ;
 IN: compiler.cfg.linear-scan.numbering
 
 ERROR: already-numbered insn ;
diff --git a/basis/compiler/cfg/linearization/order/order-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor
similarity index 83%
rename from basis/compiler/cfg/linearization/order/order-tests.factor
rename to basis/compiler/cfg/linearization/linearization-tests.factor
index 67fb55f507..edaeb720c7 100644
--- a/basis/compiler/cfg/linearization/order/order-tests.factor
+++ b/basis/compiler/cfg/linearization/linearization-tests.factor
@@ -1,6 +1,6 @@
-USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization.order
+USING: compiler.cfg.debugger compiler.cfg compiler.cfg.linearization
 kernel accessors sequences sets tools.test namespaces ;
-IN: compiler.cfg.linearization.order.tests
+IN: compiler.cfg.linearization.tests
 
 V{ } 0 test-bb
 
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 9c3a0068bc..c44b29d271 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -1,74 +1,91 @@
-! Copyright (C) 2008, 2010 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces make
-combinators assocs arrays locals layouts hashtables
-cpu.architecture generalizations
-compiler.cfg
-compiler.cfg.comparisons
-compiler.cfg.stack-frame
-compiler.cfg.instructions
-compiler.cfg.utilities
-compiler.cfg.linearization.order ;
+USING: accessors arrays assocs deques dlists hashtables kernel
+make sorting namespaces sequences combinators
+combinators.short-circuit fry math compiler.cfg.rpo
+compiler.cfg.utilities compiler.cfg.loop-detection
+compiler.cfg.predecessors sets hash-sets ;
+FROM: namespaces => set ;
 IN: compiler.cfg.linearization
 
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
+
 <PRIVATE
 
+SYMBOLS: work-list loop-heads visited ;
+
+: visited? ( bb -- ? ) visited get in? ;
+
+: add-to-work-list ( bb -- )
+    dup visited? [ drop ] [
+        work-list get push-back
+    ] if ;
+
+: init-linearization-order ( cfg -- )
+    <dlist> work-list set
+    HS{ } clone visited set
+    entry>> add-to-work-list ;
+
+: (find-alternate-loop-head) ( bb -- bb' )
+    dup {
+        [ predecessor visited? not ]
+        [ predecessors>> length 1 = ]
+        [ predecessor successors>> length 1 = ]
+        [ [ number>> ] [ predecessor number>> ] bi > ]
+    } 1&& [ predecessor (find-alternate-loop-head) ] when ;
+
+: find-back-edge ( bb -- pred )
+    [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
+
+: find-alternate-loop-head ( bb -- bb' )
+    dup find-back-edge dup visited? [ drop ] [
+        nip (find-alternate-loop-head)
+    ] if ;
+
+: predecessors-ready? ( bb -- ? )
+    [ predecessors>> ] keep '[
+        _ 2dup back-edge?
+        [ 2drop t ] [ drop visited? ] if
+    ] all? ;
+
+: process-successor ( bb -- )
+    dup predecessors-ready? [
+        dup loop-entry? [ find-alternate-loop-head ] when
+        add-to-work-list
+    ] [ drop ] if ;
+
+: sorted-successors ( bb -- seq )
+    successors>> <reversed> [ loop-nesting-at ] sort-with ;
+
+: process-block ( bb -- )
+    dup visited? [ drop ] [
+        [ , ]
+        [ visited get adjoin ]
+        [ sorted-successors [ process-successor ] each ]
+        tri
+    ] if ;
+
+: (linearization-order) ( cfg -- bbs )
+    init-linearization-order
+
+    [ work-list get [ process-block ] slurp-deque ] { } make
+    ! [ unlikely?>> not ] partition append
+    ;
+
+PRIVATE>
+
+: linearization-order ( cfg -- bbs )
+    needs-post-order needs-loops needs-predecessors
+
+    dup linear-order>> [ ] [
+        dup (linearization-order)
+        >>linear-order linear-order>>
+    ] ?if ;
+
 SYMBOL: numbers
 
 : block-number ( bb -- n ) numbers get at ;
 
-: number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
-
-GENERIC: linearize-insn ( basic-block insn -- )
-
-M: insn linearize-insn , drop ;
-
-: useless-branch? ( basic-block successor -- ? )
-    ! If our successor immediately follows us in linearization
-    ! order then we don't need to branch.
-    [ block-number ] bi@ 1 - = ; inline
-
-: emit-branch ( bb successor -- )
-    2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
-
-M: ##branch linearize-insn
-    drop dup successors>> first emit-branch ;
-
-GENERIC: negate-insn-cc ( insn -- )
-
-M: conditional-branch-insn negate-insn-cc
-    [ negate-cc ] change-cc drop ;
-
-M: ##test-vector-branch negate-insn-cc
-    [ negate-vcc ] change-vcc drop ;
-
-M:: conditional-branch-insn linearize-insn ( bb insn -- )
-    bb successors>> first2 :> ( first second )
-    bb second useless-branch?
-    [ bb second first ]
-    [ bb first second insn negate-insn-cc ] if
-    block-number insn _conditional-branch
-    emit-branch ;
-
-M: ##dispatch linearize-insn
-    , successors>> [ block-number _dispatch-label ] each ;
-
-: linearize-basic-block ( bb -- )
-    [ block-number _label ]
-    [ dup instructions>> [ linearize-insn ] with each ]
-    bi ;
-
-: linearize-basic-blocks ( cfg -- insns )
-    [
-        [
-            linearization-order
-            [ number-blocks ]
-            [ [ linearize-basic-block ] each ] bi
-        ] [ spill-area-size>> _spill-area-size ] bi
-    ] { } make ;
-
-PRIVATE>
-
-: flatten-cfg ( cfg -- mr )
-    [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
-    <mr> ;
+: number-blocks ( bbs -- )
+    [ 2array ] map-index >hashtable numbers set ;
diff --git a/basis/compiler/cfg/linearization/order/order.factor b/basis/compiler/cfg/linearization/order/order.factor
deleted file mode 100644
index a68a90a8e8..0000000000
--- a/basis/compiler/cfg/linearization/order/order.factor
+++ /dev/null
@@ -1,84 +0,0 @@
-! Copyright (C) 2009, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel make sorting
-namespaces sequences combinators combinators.short-circuit
-fry math compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg.loop-detection compiler.cfg.predecessors
-sets hash-sets ;
-FROM: namespaces => set ;
-IN: compiler.cfg.linearization.order
-
-! This is RPO except loops are rotated and unlikely blocks go
-! at the end. Based on SBCL's src/compiler/control.lisp
-
-<PRIVATE
-
-SYMBOLS: work-list loop-heads visited ;
-
-: visited? ( bb -- ? ) visited get in? ;
-
-: add-to-work-list ( bb -- )
-    dup visited? [ drop ] [
-        work-list get push-back
-    ] if ;
-
-: init-linearization-order ( cfg -- )
-    <dlist> work-list set
-    HS{ } clone visited set
-    entry>> add-to-work-list ;
-
-: (find-alternate-loop-head) ( bb -- bb' )
-    dup {
-        [ predecessor visited? not ]
-        [ predecessors>> length 1 = ]
-        [ predecessor successors>> length 1 = ]
-        [ [ number>> ] [ predecessor number>> ] bi > ]
-    } 1&& [ predecessor (find-alternate-loop-head) ] when ;
-
-: find-back-edge ( bb -- pred )
-    [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
-
-: find-alternate-loop-head ( bb -- bb' )
-    dup find-back-edge dup visited? [ drop ] [
-        nip (find-alternate-loop-head)
-    ] if ;
-
-: predecessors-ready? ( bb -- ? )
-    [ predecessors>> ] keep '[
-        _ 2dup back-edge?
-        [ 2drop t ] [ drop visited? ] if
-    ] all? ;
-
-: process-successor ( bb -- )
-    dup predecessors-ready? [
-        dup loop-entry? [ find-alternate-loop-head ] when
-        add-to-work-list
-    ] [ drop ] if ;
-
-: sorted-successors ( bb -- seq )
-    successors>> <reversed> [ loop-nesting-at ] sort-with ;
-
-: process-block ( bb -- )
-    dup visited? [ drop ] [
-        [ , ]
-        [ visited get adjoin ]
-        [ sorted-successors [ process-successor ] each ]
-        tri
-    ] if ;
-
-: (linearization-order) ( cfg -- bbs )
-    init-linearization-order
-
-    [ work-list get [ process-block ] slurp-deque ] { } make
-    ! [ unlikely?>> not ] partition append
-    ;
-
-PRIVATE>
-
-: linearization-order ( cfg -- bbs )
-    needs-post-order needs-loops needs-predecessors
-
-    dup linear-order>> [ ] [
-        dup (linearization-order)
-        >>linear-order linear-order>>
-    ] ?if ;
diff --git a/basis/compiler/cfg/linearization/summary.txt b/basis/compiler/cfg/linearization/summary.txt
deleted file mode 100644
index 96daec8046..0000000000
--- a/basis/compiler/cfg/linearization/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Flattening CFG into MR (machine representation)
diff --git a/basis/compiler/cfg/mr/authors.txt b/basis/compiler/cfg/mr/authors.txt
deleted file mode 100644
index d4f5d6b3ae..0000000000
--- a/basis/compiler/cfg/mr/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor
deleted file mode 100644
index 5b9e9ee2c3..0000000000
--- a/basis/compiler/cfg/mr/mr.factor
+++ /dev/null
@@ -1,8 +0,0 @@
-! Copyright (C) 2009, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg.linearization compiler.cfg.build-stack-frame ;
-IN: compiler.cfg.mr
-
-: build-mr ( cfg -- mr )
-    flatten-cfg
-    build-stack-frame ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index 5861ca67bd..8ad55d76d8 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -1,14 +1,15 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math math.order namespaces accessors kernel layouts combinators
-combinators.smart assocs sequences cpu.architecture ;
+USING: math math.order namespaces accessors kernel layouts
+combinators combinators.smart assocs sequences cpu.architecture
+words compiler.cfg.instructions ;
 IN: compiler.cfg.stack-frame
 
 TUPLE: stack-frame
 { params integer }
 { return integer }
-{ total-size integer }
 { spill-area-size integer }
+{ total-size integer }
 { calls-vm? boolean } ;
 
 ! Stack frame utilities
@@ -28,5 +29,11 @@ TUPLE: stack-frame
     {
         [ [ params>> ] bi@ max >>params ]
         [ [ return>> ] bi@ max >>return ]
+        [ [ spill-area-size>> ] bi@ max >>spill-area-size ]
         [ [ calls-vm?>> ] bi@ or >>calls-vm? ]
-    } 2cleave ;
\ No newline at end of file
+    } 2cleave ;
+
+! PowerPC backend sets frame-required? for ##integer>float too
+\ ##spill t "frame-required?" set-word-prop
+\ ##unary-float-function t "frame-required?" set-word-prop
+\ ##binary-float-function t "frame-required?" set-word-prop
\ No newline at end of file
diff --git a/basis/compiler/codegen/alien/alien.factor b/basis/compiler/codegen/alien/alien.factor
new file mode 100644
index 0000000000..5123b1c62c
--- /dev/null
+++ b/basis/compiler/codegen/alien/alien.factor
@@ -0,0 +1,231 @@
+! Copyright (C) 2008, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.complex alien.c-types
+alien.libraries alien.private alien.strings arrays
+classes.struct combinators compiler.alien
+compiler.cfg.instructions compiler.codegen
+compiler.codegen.fixup compiler.errors compiler.utilities
+cpu.architecture fry kernel layouts libc locals make math
+math.order math.parser namespaces quotations sequences strings ;
+FROM: compiler.errors => no-such-symbol ;
+IN: compiler.codegen.alien
+
+! ##alien-invoke
+GENERIC: next-fastcall-param ( rep -- )
+
+: ?dummy-stack-params ( rep -- )
+    dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
+
+: ?dummy-int-params ( rep -- )
+    dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
+
+: ?dummy-fp-params ( rep -- )
+    drop dummy-fp-params? [ float-regs inc ] when ;
+
+M: int-rep next-fastcall-param
+    int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
+
+M: float-rep next-fastcall-param
+    float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
+
+M: double-rep next-fastcall-param
+    float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
+
+GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
+
+M: stack-params reg-class-full? 2drop t ;
+
+M: reg-class reg-class-full?
+    [ get ] swap '[ _ param-regs length ] bi >= ;
+
+: alloc-stack-param ( rep -- n reg-class rep )
+    stack-params get
+    [ rep-size cell align stack-params +@ ] dip
+    stack-params dup ;
+
+: alloc-fastcall-param ( rep -- n reg-class rep )
+    [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
+
+:: alloc-parameter ( parameter abi -- reg rep )
+    parameter c-type-rep dup reg-class-of abi reg-class-full?
+    [ alloc-stack-param ] [ alloc-fastcall-param ] if
+    [ abi param-reg ] dip ;
+
+SYMBOL: (stack-value)
+<< void* c-type clone \ (stack-value) define-primitive-type
+stack-params \ (stack-value) c-type (>>rep) >>
+
+: ((flatten-type)) ( type to-type -- seq )
+    [ stack-size cell align cell /i ] dip c-type <repetition> ; inline
+
+: (flatten-int-type) ( type -- seq )
+    void* ((flatten-type)) ;
+: (flatten-stack-type) ( type -- seq )
+    (stack-value) ((flatten-type)) ;
+
+GENERIC: flatten-value-type ( type -- types )
+
+M: object flatten-value-type 1array ;
+M: struct-c-type flatten-value-type (flatten-int-type) ;
+M: long-long-type flatten-value-type (flatten-int-type) ;
+M: c-type-name flatten-value-type c-type flatten-value-type ;
+
+: flatten-value-types ( params -- params )
+    #! Convert value type structs to consecutive void*s.
+    [
+        0 [
+            c-type
+            [ parameter-align cell /i void* c-type <repetition> % ] keep
+            [ stack-size cell align + ] keep
+            flatten-value-type %
+        ] reduce drop
+    ] { } make ;
+
+: each-parameter ( parameters quot -- )
+    [ [ parameter-offsets nip ] keep ] dip 2each ; inline
+
+: reset-fastcall-counts ( -- )
+    { int-regs float-regs stack-params } [ 0 swap set ] each ;
+
+: with-param-regs ( quot -- )
+    #! In quot you can call alloc-parameter
+    [ reset-fastcall-counts call ] with-scope ; inline
+
+: move-parameters ( node word -- )
+    #! Moves values from C stack to registers (if word is
+    #! %load-param-reg) and registers to C stack (if word is
+    #! %save-param-reg).
+    [ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
+    [ '[ _ alloc-parameter _ execute ] ]
+    bi* each-parameter ; inline
+
+: reverse-each-parameter ( parameters quot -- )
+    [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
+
+: prepare-unbox-parameters ( parameters -- offsets types indices )
+    [ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
+
+: unbox-parameters ( offset node -- )
+    parameters>> swap
+    '[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
+    [ length neg %inc-d ]
+    bi ;
+
+: prepare-box-struct ( node -- offset )
+    #! Return offset on C stack where to store unboxed
+    #! parameters. If the C function is returning a structure,
+    #! the first parameter is an implicit target area pointer,
+    #! so we need to use a different offset.
+    return>> large-struct?
+    [ %prepare-box-struct cell ] [ 0 ] if ;
+
+: objects>registers ( params -- )
+    #! Generate code for unboxing a list of C types, then
+    #! generate code for moving these parameters to registers on
+    #! architectures where parameters are passed in registers.
+    [
+        [ prepare-box-struct ] keep
+        [ unbox-parameters ] keep
+        \ %load-param-reg move-parameters
+    ] with-param-regs ;
+
+: box-return* ( node -- )
+    return>> [ ] [ box-return %push-stack ] if-void ;
+
+GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
+
+M: string dlsym-valid? dlsym ;
+
+M: array dlsym-valid? '[ _ dlsym ] any? ;
+
+: check-dlsym ( symbols dll -- )
+    dup dll-valid? [
+        dupd dlsym-valid?
+        [ drop ] [ compiling-word get no-such-symbol ] if
+    ] [
+        dll-path compiling-word get no-such-library drop
+    ] if ;
+
+: decorated-symbol ( params -- symbols )
+    [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
+    {
+        [ drop ]
+        [ "@" glue ]
+        [ "@" glue "_" prepend ]
+        [ "@" glue "@" prepend ]
+    } 2cleave
+    4array ;
+
+: alien-invoke-dlsym ( params -- symbols dll )
+    [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
+    [ library>> load-library ]
+    bi 2dup check-dlsym ;
+
+M: ##alien-invoke generate-insn
+    params>>
+    ! Unbox parameters
+    dup objects>registers
+    %prepare-var-args
+    ! Call function
+    dup alien-invoke-dlsym %alien-invoke
+    ! Box return value
+    dup %cleanup
+    box-return* ;
+
+M: ##alien-assembly generate-insn
+    params>>
+    ! Unbox parameters
+    dup objects>registers
+    %prepare-var-args
+    ! Generate assembly
+    dup quot>> call( -- )
+    ! Box return value
+    box-return* ;
+
+! ##alien-indirect
+M: ##alien-indirect generate-insn
+    params>>
+    ! Save alien at top of stack to temporary storage
+    %prepare-alien-indirect
+    ! Unbox parameters
+    dup objects>registers
+    %prepare-var-args
+    ! Call alien in temporary storage
+    %alien-indirect
+    ! Box return value
+    dup %cleanup
+    box-return* ;
+
+! ##alien-callback
+: box-parameters ( params -- )
+    alien-parameters [ box-parameter %push-context-stack ] each-parameter ;
+
+: registers>objects ( node -- )
+    ! Generate code for boxing input parameters in a callback.
+    [
+        dup \ %save-param-reg move-parameters
+        %begin-callback
+        box-parameters
+    ] with-param-regs ;
+
+: callback-return-quot ( ctype -- quot )
+    return>> {
+        { [ dup void? ] [ drop [ ] ] }
+        { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
+        [ c-type c-type-unboxer-quot ]
+    } cond ;
+
+: callback-prep-quot ( params -- quot )
+    parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
+
+: wrap-callback-quot ( params -- quot )
+    [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
+     yield-hook get
+     '[ _ _ do-callback ]
+     >quotation ;
+
+M: ##alien-callback generate-insn
+    params>>
+    [ registers>objects ]
+    [ wrap-callback-quot %alien-callback ]
+    [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;
diff --git a/basis/compiler/codegen/alien/authors.txt b/basis/compiler/codegen/alien/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/compiler/codegen/alien/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 4737f1a47d..604fb2570e 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -2,23 +2,20 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces make math math.order math.parser sequences
 accessors kernel layouts assocs words summary arrays combinators
-classes.algebra alien alien.private alien.c-types alien.strings
-alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture classes
-classes.struct locals source-files.errors slots parser
-generic.parser strings quotations
-compiler.errors
-compiler.alien
+classes.algebra sets continuations.private fry cpu.architecture
+classes classes.struct locals slots parser generic.parser
+strings quotations hashtables
 compiler.constants
 compiler.cfg
+compiler.cfg.linearization
 compiler.cfg.instructions
+compiler.cfg.comparisons
 compiler.cfg.stack-frame
 compiler.cfg.registers
 compiler.cfg.builder
 compiler.codegen.fixup
 compiler.utilities ;
 FROM: namespaces => set ;
-FROM: compiler.errors => no-such-symbol ;
 IN: compiler.codegen
 
 SYMBOL: insn-counts
@@ -27,40 +24,88 @@ H{ } clone insn-counts set-global
 
 GENERIC: generate-insn ( insn -- )
 
-! Mapping _label IDs to label instances
+! Control flow
 SYMBOL: labels
 
-: lookup-label ( id -- label )
+: lookup-label ( bb -- label )
     labels get [ drop <label> ] cache ;
 
-: generate ( mr -- code )
-    dup label>> [
-        H{ } clone labels set
+: useless-branch? ( bb successor -- ? )
+    ! If our successor immediately follows us in linearization
+    ! order then we don't need to branch.
+    [ block-number ] bi@ 1 - = ; inline
+
+: emit-branch ( bb successor -- )
+    2dup useless-branch?
+    [ 2drop ] [ nip lookup-label %jump-label ] if ;
+
+M: ##branch generate-insn
+    drop basic-block get dup successors>> first emit-branch ;
+
+GENERIC: generate-conditional-insn ( label insn -- )
+
+GENERIC: negate-insn-cc ( insn -- )
+
+M: conditional-branch-insn negate-insn-cc
+    [ negate-cc ] change-cc drop ;
+
+M: ##test-vector-branch negate-insn-cc
+    [ negate-vcc ] change-vcc drop ;
+
+M:: conditional-branch-insn generate-insn ( insn -- )
+    basic-block get :> bb
+    bb successors>> first2 :> ( first second )
+    bb second useless-branch?
+    [ bb second first ]
+    [ bb first second insn negate-insn-cc ] if
+    lookup-label insn generate-conditional-insn
+    emit-branch ;
+
+: %dispatch-label ( label -- )
+    cell 0 <repetition> %
+    rc-absolute-cell label-fixup ;
+
+M: ##dispatch generate-insn
+    [ src>> ] [ temp>> ] bi %dispatch
+    basic-block get successors>>
+    [ lookup-label %dispatch-label ] each ;
+
+: generate-block ( bb -- )
+    [ basic-block set ]
+    [ lookup-label resolve-label ]
+    [
         instructions>> [
             [ class insn-counts get inc-at ]
             [ generate-insn ]
             bi
         ] each
+    ] tri ;
+
+: generate ( cfg -- code )
+    dup label>> [
+        H{ } clone labels set
+        linearization-order
+        [ number-blocks ] [ [ generate-block ] each ] bi
     ] with-fixup ;
 
 ! Special cases
 M: ##no-tco generate-insn drop ;
 
-M: _prologue generate-insn
-    stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
+M: ##prologue generate-insn
+    drop
+    cfg get stack-frame>>
+    [ [ stack-frame set ] [ total-size>> %prologue ] bi ] when* ;
 
-M: _epilogue generate-insn
-    stack-frame>> total-size>> %epilogue ;
-
-M: _spill-area-size generate-insn drop ;
+M: ##epilogue generate-insn
+    drop
+    cfg get stack-frame>> [ total-size>> %epilogue ] when* ;
 
 ! Some meta-programming to generate simple code generators, where
 ! the instruction is unpacked and then a %word is called
 <<
 
 : insn-slot-quot ( spec -- quot )
-    name>> [ reader-word ] [ "label" = ] bi
-    [ \ lookup-label [ ] 2sequence ] [ [ ] 1sequence ] if ;
+    name>> reader-word 1quotation ;
 
 : codegen-method-body ( class word -- quot )
     [
@@ -204,18 +249,6 @@ CODEGEN: ##alien-global %alien-global
 CODEGEN: ##call-gc %call-gc
 CODEGEN: ##spill %spill
 CODEGEN: ##reload %reload
-CODEGEN: ##dispatch %dispatch
-
-: %dispatch-label ( label -- )
-    cell 0 <repetition> %
-    rc-absolute-cell label-fixup ;
-
-CODEGEN: _label resolve-label
-CODEGEN: _dispatch-label %dispatch-label
-CODEGEN: _branch %jump-label
-CODEGEN: _loop-entry %loop-entry
-
-GENERIC: generate-conditional-insn ( label insn -- )
 
 <<
 
@@ -236,226 +269,3 @@ CONDITIONAL: ##check-nursery-branch %check-nursery-branch
 CONDITIONAL: ##fixnum-add %fixnum-add
 CONDITIONAL: ##fixnum-sub %fixnum-sub
 CONDITIONAL: ##fixnum-mul %fixnum-mul
-
-M: _conditional-branch generate-insn
-    [ label>> lookup-label ] [ insn>> ] bi generate-conditional-insn ;
-
-! ##alien-invoke
-GENERIC: next-fastcall-param ( rep -- )
-
-: ?dummy-stack-params ( rep -- )
-    dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
-
-: ?dummy-int-params ( rep -- )
-    dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
-
-: ?dummy-fp-params ( rep -- )
-    drop dummy-fp-params? [ float-regs inc ] when ;
-
-M: int-rep next-fastcall-param
-    int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
-
-M: float-rep next-fastcall-param
-    float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-
-M: double-rep next-fastcall-param
-    float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-
-GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
-
-M: stack-params reg-class-full? 2drop t ;
-
-M: reg-class reg-class-full?
-    [ get ] swap '[ _ param-regs length ] bi >= ;
-
-: alloc-stack-param ( rep -- n reg-class rep )
-    stack-params get
-    [ rep-size cell align stack-params +@ ] dip
-    stack-params dup ;
-
-: alloc-fastcall-param ( rep -- n reg-class rep )
-    [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
-
-:: alloc-parameter ( parameter abi -- reg rep )
-    parameter c-type-rep dup reg-class-of abi reg-class-full?
-    [ alloc-stack-param ] [ alloc-fastcall-param ] if
-    [ abi param-reg ] dip ;
-
-SYMBOL: (stack-value)
-<< void* c-type clone \ (stack-value) define-primitive-type
-stack-params \ (stack-value) c-type (>>rep) >>
-
-: ((flatten-type)) ( type to-type -- seq )
-    [ stack-size cell align cell /i ] dip c-type <repetition> ; inline
-
-: (flatten-int-type) ( type -- seq )
-    void* ((flatten-type)) ;
-: (flatten-stack-type) ( type -- seq )
-    (stack-value) ((flatten-type)) ;
-
-GENERIC: flatten-value-type ( type -- types )
-
-M: object flatten-value-type 1array ;
-M: struct-c-type flatten-value-type (flatten-int-type) ;
-M: long-long-type flatten-value-type (flatten-int-type) ;
-M: c-type-name flatten-value-type c-type flatten-value-type ;
-
-: flatten-value-types ( params -- params )
-    #! Convert value type structs to consecutive void*s.
-    [
-        0 [
-            c-type
-            [ parameter-align cell /i void* c-type <repetition> % ] keep
-            [ stack-size cell align + ] keep
-            flatten-value-type %
-        ] reduce drop
-    ] { } make ;
-
-: each-parameter ( parameters quot -- )
-    [ [ parameter-offsets nip ] keep ] dip 2each ; inline
-
-: reset-fastcall-counts ( -- )
-    { int-regs float-regs stack-params } [ 0 swap set ] each ;
-
-: with-param-regs ( quot -- )
-    #! In quot you can call alloc-parameter
-    [ reset-fastcall-counts call ] with-scope ; inline
-
-: move-parameters ( node word -- )
-    #! Moves values from C stack to registers (if word is
-    #! %load-param-reg) and registers to C stack (if word is
-    #! %save-param-reg).
-    [ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
-    [ '[ _ alloc-parameter _ execute ] ]
-    bi* each-parameter ; inline
-
-: reverse-each-parameter ( parameters quot -- )
-    [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
-
-: prepare-unbox-parameters ( parameters -- offsets types indices )
-    [ parameter-offsets nip ] [ ] [ length iota <reversed> ] tri ;
-
-: unbox-parameters ( offset node -- )
-    parameters>> swap
-    '[ prepare-unbox-parameters [ %pop-stack [ _ + ] dip unbox-parameter ] 3each ]
-    [ length neg %inc-d ]
-    bi ;
-
-: prepare-box-struct ( node -- offset )
-    #! Return offset on C stack where to store unboxed
-    #! parameters. If the C function is returning a structure,
-    #! the first parameter is an implicit target area pointer,
-    #! so we need to use a different offset.
-    return>> large-struct?
-    [ %prepare-box-struct cell ] [ 0 ] if ;
-
-: objects>registers ( params -- )
-    #! Generate code for unboxing a list of C types, then
-    #! generate code for moving these parameters to registers on
-    #! architectures where parameters are passed in registers.
-    [
-        [ prepare-box-struct ] keep
-        [ unbox-parameters ] keep
-        \ %load-param-reg move-parameters
-    ] with-param-regs ;
-
-: box-return* ( node -- )
-    return>> [ ] [ box-return %push-stack ] if-void ;
-
-GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
-
-M: string dlsym-valid? dlsym ;
-
-M: array dlsym-valid? '[ _ dlsym ] any? ;
-
-: check-dlsym ( symbols dll -- )
-    dup dll-valid? [
-        dupd dlsym-valid?
-        [ drop ] [ compiling-word get no-such-symbol ] if
-    ] [
-        dll-path compiling-word get no-such-library drop
-    ] if ;
-
-: decorated-symbol ( params -- symbols )
-    [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
-    {
-        [ drop ]
-        [ "@" glue ]
-        [ "@" glue "_" prepend ]
-        [ "@" glue "@" prepend ]
-    } 2cleave
-    4array ;
-
-: alien-invoke-dlsym ( params -- symbols dll )
-    [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
-    [ library>> load-library ]
-    bi 2dup check-dlsym ;
-
-M: ##alien-invoke generate-insn
-    params>>
-    ! Unbox parameters
-    dup objects>registers
-    %prepare-var-args
-    ! Call function
-    dup alien-invoke-dlsym %alien-invoke
-    ! Box return value
-    dup %cleanup
-    box-return* ;
-
-M: ##alien-assembly generate-insn
-    params>>
-    ! Unbox parameters
-    dup objects>registers
-    %prepare-var-args
-    ! Generate assembly
-    dup quot>> call( -- )
-    ! Box return value
-    box-return* ;
-
-! ##alien-indirect
-M: ##alien-indirect generate-insn
-    params>>
-    ! Save alien at top of stack to temporary storage
-    %prepare-alien-indirect
-    ! Unbox parameters
-    dup objects>registers
-    %prepare-var-args
-    ! Call alien in temporary storage
-    %alien-indirect
-    ! Box return value
-    dup %cleanup
-    box-return* ;
-
-! ##alien-callback
-: box-parameters ( params -- )
-    alien-parameters [ box-parameter %push-context-stack ] each-parameter ;
-
-: registers>objects ( node -- )
-    ! Generate code for boxing input parameters in a callback.
-    [
-        dup \ %save-param-reg move-parameters
-        %begin-callback
-        box-parameters
-    ] with-param-regs ;
-
-: callback-return-quot ( ctype -- quot )
-    return>> {
-        { [ dup void? ] [ drop [ ] ] }
-        { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
-        [ c-type c-type-unboxer-quot ]
-    } cond ;
-
-: callback-prep-quot ( params -- quot )
-    parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
-
-: wrap-callback-quot ( params -- quot )
-    [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
-     yield-hook get
-     '[ _ _ do-callback ]
-     >quotation ;
-
-M: ##alien-callback generate-insn
-    params>>
-    [ registers>objects ]
-    [ wrap-callback-quot %alien-callback ]
-    [ alien-return [ %end-callback ] [ %end-callback-value ] if-void ] tri ;
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index 9bc473e330..4c8a9ca61d 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -17,9 +17,9 @@ compiler.cfg
 compiler.cfg.builder
 compiler.cfg.optimizer
 compiler.cfg.finalization
-compiler.cfg.mr
 
-compiler.codegen ;
+compiler.codegen
+compiler.codegen.alien ;
 IN: compiler
 
 SYMBOL: compiled
@@ -126,8 +126,10 @@ M: word combinator? inline? ;
 
 : backend ( tree word -- )
     build-cfg [
-        [ optimize-cfg finalize-cfg build-mr ] with-cfg
-        [ generate ] [ label>> ] bi compiled get set-at
+        [
+            optimize-cfg finalize-cfg
+            [ generate ] [ label>> ] bi compiled get set-at
+        ] with-cfg
     ] each ;
 
 : compile-word ( word -- )
diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor
index 60c68072ec..4d0ae08127 100644
--- a/basis/compiler/tests/low-level-ir.factor
+++ b/basis/compiler/tests/low-level-ir.factor
@@ -1,15 +1,15 @@
 USING: accessors assocs compiler compiler.cfg
-compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr
+compiler.cfg.debugger compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.linear-scan
-compiler.cfg.ssa.destruction compiler.codegen compiler.units
-cpu.architecture hashtables kernel namespaces sequences
-tools.test vectors words layouts literals math arrays
-alien.c-types alien.syntax math.private ;
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
+compiler.codegen compiler.units cpu.architecture hashtables
+kernel namespaces sequences tools.test vectors words layouts
+literals math arrays alien.c-types alien.syntax math.private ;
 IN: compiler.tests.low-level-ir
 
 : compile-cfg ( cfg -- word )
     gensym
-    [ linear-scan build-mr generate ] dip
+    [ linear-scan build-stack-frame generate ] dip
     [ associate >alist t t modify-code-heap ] keep ;
 
 : compile-test-cfg ( -- word )
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 6a7ecd9d14..a414a934f7 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -5,10 +5,11 @@ arrays kernel fry math namespaces sequences system layouts io
 vocabs.loader accessors init classes.struct combinators
 command-line make words compiler compiler.units
 compiler.constants compiler.alien compiler.codegen
-compiler.codegen.fixup compiler.cfg.instructions
-compiler.cfg.builder compiler.cfg.intrinsics
-compiler.cfg.stack-frame cpu.x86.assembler
-cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
+compiler.codegen.alien compiler.codegen.fixup
+compiler.cfg.instructions compiler.cfg.builder
+compiler.cfg.intrinsics compiler.cfg.stack-frame
+cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
+cpu.architecture vm ;
 FROM: layouts => cell ;
 IN: cpu.x86.32
 

From 64ab5982252e72b67bd110971b3975be88b918f0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 May 2010 20:06:45 -0400
Subject: [PATCH 155/158] io.launcher.unix: add timeout to a test

---
 basis/io/launcher/unix/unix-tests.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor
index bb7569516a..fef6b076ba 100644
--- a/basis/io/launcher/unix/unix-tests.factor
+++ b/basis/io/launcher/unix/unix-tests.factor
@@ -135,6 +135,6 @@ concurrency.promises threads unix.process calendar unix ;
         ] in-thread
 
         p 1 seconds ?promise-timeout handle>> kill-process*
-        s ?promise 0 =
+        s 3 seconds ?promise-timeout 0 =
     ]
 ] unit-test

From 86548320eb18b9a53a87d0805e7e0959f479e676 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 May 2010 20:38:02 -0400
Subject: [PATCH 156/158] compiler.cfg.value-numbering: fix unit test for
 64-bit

---
 .../compiler/cfg/value-numbering/value-numbering-tests.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index c9c4327be6..7613a5948a 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -2416,14 +2416,14 @@ cpu x86? [
             T{ ##peek f 0 D 0 }
             T{ ##peek f 1 D 1 }
             T{ ##add-imm f 2 1 2 }
-            T{ ##slot f 3 0 1 2 $[ 7 2 cells - ] }
+            T{ ##slot f 3 0 1 $[ cell log2 ] $[ 7 2 cells - ] }
         }
     ] [
         V{
             T{ ##peek f 0 D 0 }
             T{ ##peek f 1 D 1 }
             T{ ##add-imm f 2 1 2 }
-            T{ ##slot f 3 0 2 2 7 }
+            T{ ##slot f 3 0 2 $[ cell log2 ] 7 }
         } value-numbering-step
     ] unit-test
 ] when

From 9b4135713e5b887b455f83943ff5d4acbfa63bc3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 May 2010 00:38:10 -0400
Subject: [PATCH 157/158] compiler.cfg.representations: make sure that
 immediate operands fit

---
 .../representations/peephole/peephole.factor  | 108 +++++++-----------
 .../representations-tests.factor              |  36 ++++++
 .../selection/selection.factor                |   9 +-
 3 files changed, 83 insertions(+), 70 deletions(-)

diff --git a/basis/compiler/cfg/representations/peephole/peephole.factor b/basis/compiler/cfg/representations/peephole/peephole.factor
index 4080e8077c..1c590f88ff 100644
--- a/basis/compiler/cfg/representations/peephole/peephole.factor
+++ b/basis/compiler/cfg/representations/peephole/peephole.factor
@@ -106,38 +106,29 @@ M: ##load-reference optimize-insn
         [ 2drop int-rep ##copy here ]
     } cond ;
 
-: inert-tag-imm? ( insn -- ? )
-    src1>> rep-of tagged-rep? ;
+: dst-tagged? ( insn -- ? ) dst>> rep-of tagged-rep? ;
+: src1-tagged? ( insn -- ? ) src1>> rep-of tagged-rep? ;
+: src2-tagged? ( insn -- ? ) src2>> rep-of tagged-rep? ;
 
-: inert-tag/untag-imm? ( insn -- ? )
-    {
-        [ dst>> rep-of tagged-rep? ]
-        [ inert-tag-imm? ]
-    } 1&& ;
+: src2-tagged-arithmetic? ( insn -- ? ) src2>> tag-fixnum immediate-arithmetic? ;
+: src2-tagged-bitwise? ( insn -- ? ) src2>> tag-fixnum immediate-bitwise? ;
+: src2-tagged-shift-count? ( insn -- ? ) src2>> tag-bits get + immediate-shift-count? ;
+
+: >tagged-shift ( insn -- ) [ tag-bits get + ] change-src2 finish ; inline
 
 M: ##shl-imm optimize-insn
     {
         {
-            [ dup inert-tag/untag-imm? ]
+            [ dup { [ dst-tagged? ] [ src1-tagged? ] } 1&& ]
             [ unchanged ]
         }
         {
-            [ dup dst>> rep-of tagged-rep? ]
-            [
-                [ emit-use-conversion ]
-                [ [ tag-bits get + ] change-src2 finish ]
-                [ no-def-conversion ]
-                tri
-            ]
+            [ dup { [ dst-tagged? ] [ src2-tagged-shift-count? ] } 1&& ]
+            [ [ emit-use-conversion ] [ >tagged-shift ] [ no-def-conversion ] tri ]
         }
         {
-            [ dup src1>> rep-of tagged-rep? ]
-            [
-                [ no-use-conversion ]
-                [ combine-shl-imm-input ]
-                [ emit-def-conversion ]
-                tri
-            ]
+            [ dup src1-tagged? ]
+            [ [ no-use-conversion ] [ combine-shl-imm-input ] [ emit-def-conversion ] tri ]
         }
         [ call-next-method ]
     } cond ;
@@ -148,25 +139,11 @@ M: ##shl-imm optimize-insn
 ! Into
 ! ##sar-imm by X + tag-bits
 ! assuming X + tag-bits is a valid shift count.
-: combine-sar-imm? ( insn -- ? )
-    {
-        [ src1>> rep-of tagged-rep? ]
-        [ src2>> tag-bits get + immediate-shift-count? ]
-    } 1&& ;
-
-: combine-sar-imm ( insn -- )
-    [ dst>> ] [ src1>> ] [ src2>> tag-bits get + ] tri ##sar-imm here ;
-
 M: ##sar-imm optimize-insn
     {
         {
-            [ dup combine-sar-imm? ]
-            [
-                [ no-use-conversion ]
-                [ combine-sar-imm ]
-                [ emit-def-conversion ]
-                tri
-            ]
+            [ dup { [ src1-tagged? ] [ src2-tagged-shift-count? ] } 1&& ]
+            [ [ no-use-conversion ] [ >tagged-shift ] [ emit-def-conversion ] tri ]
         }
         [ call-next-method ]
     } cond ;
@@ -177,18 +154,12 @@ M: ##sar-imm optimize-insn
 !
 ! so if all inputs and outputs of ##X or ##X-imm are tagged,
 ! don't have to insert any conversions
-: inert-tag? ( insn -- ? )
-    {
-        [ src1>> rep-of tagged-rep? ]
-        [ src2>> rep-of tagged-rep? ]
-    } 1&& ;
-
-: inert-tag/untag? ( insn -- ? )
-    { [ dst>> rep-of tagged-rep? ] [ inert-tag? ] } 1&& ;
-
 M: inert-tag-untag-insn optimize-insn
     {
-        { [ dup inert-tag/untag? ] [ unchanged ] }
+        {
+            [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged? ] } 1&& ]
+            [ unchanged ]
+        }
         [ call-next-method ]
     } cond ;
 
@@ -196,41 +167,53 @@ M: inert-tag-untag-insn optimize-insn
 : >tagged-imm ( insn -- )
     [ tag-fixnum ] change-src2 unchanged ; inline
 
-M: inert-tag-untag-imm-insn optimize-insn
+M: inert-arithmetic-tag-untag-insn optimize-insn
     {
-        { [ dup inert-tag/untag-imm? ] [ >tagged-imm ] }
+        {
+            [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ]
+            [ >tagged-imm ]
+        }
+        [ call-next-method ]
+    } cond ;
+
+M: inert-bitwise-tag-untag-insn optimize-insn
+    {
+        {
+            [ dup { [ dst-tagged? ] [ src1-tagged? ] [ src2-tagged-bitwise? ] } 1&& ]
+            [ >tagged-imm ]
+        }
         [ call-next-method ]
     } cond ;
 
 M: ##mul-imm optimize-insn
     {
-        { [ dup inert-tag/untag-imm? ] [ unchanged ] }
-        { [ dup dst>> rep-of tagged-rep? ] [ >tagged-imm ] }
+        { [ dup { [ dst-tagged? ] [ src1-tagged? ] } 1&& ] [ unchanged ] }
+        { [ dup { [ dst-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
         [ call-next-method ]
     } cond ;
 
 ! Similar optimization for comparison operators
 M: ##compare-integer-imm optimize-insn
     {
-        { [ dup inert-tag-imm? ] [ >tagged-imm ] }
+        { [ dup { [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
         [ call-next-method ]
     } cond ;
 
 M: ##compare-integer-imm-branch optimize-insn
     {
-        { [ dup inert-tag-imm? ] [ >tagged-imm ] }
+        { [ dup { [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
         [ call-next-method ]
     } cond ;
 
 M: ##compare-integer optimize-insn
     {
-        { [ dup inert-tag? ] [ unchanged ] }
+        { [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
         [ call-next-method ]
     } cond ;
 
 M: ##compare-integer-branch optimize-insn
     {
-        { [ dup inert-tag? ] [ unchanged ] }
+        { [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
         [ call-next-method ]
     } cond ;
 
@@ -248,11 +231,7 @@ M: ##neg optimize-insn
         { [ dup inert-tag/untag-unary? ] [ unchanged ] }
         {
             [ dup dst>> rep-of tagged-rep? ]
-            [
-                [ emit-use-conversion ]
-                [ combine-neg-tag ]
-                [ no-def-conversion ] tri
-            ]
+            [ [ emit-use-conversion ] [ combine-neg-tag ] [ no-def-conversion ] tri ]
         }
         [ call-next-method ]
     } cond ;
@@ -268,12 +247,7 @@ M: ##not optimize-insn
     {
         {
             [ dup inert-tag/untag-unary? ]
-            [
-                [ no-use-conversion ]
-                [ emit-tagged-not ]
-                [ no-def-conversion ]
-                tri
-            ]
+            [ [ no-use-conversion ] [ emit-tagged-not ] [ no-def-conversion ] tri ]
         }
         [ call-next-method ]
     } cond ;
diff --git a/basis/compiler/cfg/representations/representations-tests.factor b/basis/compiler/cfg/representations/representations-tests.factor
index f4728bc7e7..ef64908f78 100644
--- a/basis/compiler/cfg/representations/representations-tests.factor
+++ b/basis/compiler/cfg/representations/representations-tests.factor
@@ -560,6 +560,42 @@ cpu x86.32? [
     } test-peephole
 ] unit-test
 
+! Make sure we don't exceed immediate bounds
+cpu x86.64? [
+    4 \ vreg-counter set-global
+
+    [
+        V{
+            T{ ##peek f 0 D 0 }
+            T{ ##sar-imm f 5 0 $[ tag-bits get ] }
+            T{ ##add-imm f 6 5 $[ 30 2^ ] }
+            T{ ##shl-imm f 2 6 $[ tag-bits get ] }
+            T{ ##replace f 2 D 0 }
+        }
+    ] [
+        V{
+            T{ ##peek f 0 D 0 }
+            T{ ##add-imm f 2 0 $[ 30 2^ ] }
+            T{ ##replace f 2 D 0 }
+        } test-peephole
+    ] unit-test
+
+    [
+        V{
+            T{ ##load-integer f 0 100 }
+            T{ ##mul-imm f 7 0 $[ 30 2^ ] }
+            T{ ##shl-imm f 1 7 $[ tag-bits get ] }
+            T{ ##replace f 1 D 0 }
+        }
+    ] [
+        V{
+            T{ ##load-integer f 0 100 }
+            T{ ##mul-imm f 1 0 $[ 30 2^ ] }
+            T{ ##replace f 1 D 0 }
+        } test-peephole
+    ] unit-test
+] when
+
 ! Tag/untag elimination for ##mul-imm
 [
     V{
diff --git a/basis/compiler/cfg/representations/selection/selection.factor b/basis/compiler/cfg/representations/selection/selection.factor
index 73e536ebee..6cabe27e85 100644
--- a/basis/compiler/cfg/representations/selection/selection.factor
+++ b/basis/compiler/cfg/representations/selection/selection.factor
@@ -96,9 +96,11 @@ UNION: inert-tag-untag-insn
 ##min
 ##max ;
 
-UNION: inert-tag-untag-imm-insn
+UNION: inert-arithmetic-tag-untag-insn
 ##add-imm
-##sub-imm
+##sub-imm ;
+
+UNION: inert-bitwise-tag-untag-insn
 ##and-imm
 ##or-imm
 ##xor-imm ;
@@ -111,7 +113,8 @@ M: ##load-reference has-peephole-opts? drop t ;
 M: ##neg has-peephole-opts? drop t ;
 M: ##not has-peephole-opts? drop t ;
 M: inert-tag-untag-insn has-peephole-opts? drop t ;
-M: inert-tag-untag-imm-insn has-peephole-opts? drop t ;
+M: inert-arithmetic-tag-untag-insn has-peephole-opts? drop t ;
+M: inert-bitwise-tag-untag-insn has-peephole-opts? drop t ;
 M: ##mul-imm has-peephole-opts? drop t ;
 M: ##shl-imm has-peephole-opts? drop t ;
 M: ##shr-imm has-peephole-opts? drop t ;

From 58e4381eb1f757d2cf520ca8a6ce69ba3f43c0d2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 May 2010 17:23:03 -0400
Subject: [PATCH 158/158] compiler: new "binary literal area" at the end of a
 word's machine code stores constant floats and SIMD vectors; this allows
 ##load-reference/##load-memory fusion to be performed on x86-64, with a
 RIP-relative address reaching the data; also simplifies VM since custom
 relocation types used by the previous 32-bit-only optimization are no longer
 needed

---
 .../representations/peephole/peephole.factor  |  4 +-
 .../cfg/value-numbering/misc/misc.factor      | 15 ++--
 .../value-numbering-tests.factor              | 68 +++++++++++++++++
 basis/compiler/codegen/fixup/fixup.factor     | 76 ++++++++++++++-----
 basis/compiler/constants/constants.factor     |  2 -
 basis/cpu/architecture/architecture.factor    |  9 ++-
 basis/cpu/x86/32/32.factor                    | 18 +----
 basis/cpu/x86/64/64.factor                    | 12 ++-
 basis/cpu/x86/64/unix/unix.factor             | 10 +--
 basis/cpu/x86/x86.factor                      | 26 ++++---
 vm/code_blocks.cpp                            |  6 --
 vm/compaction.cpp                             |  6 --
 vm/image.cpp                                  |  6 --
 vm/instruction_operands.cpp                   | 30 --------
 vm/instruction_operands.hpp                   | 12 ---
 vm/layouts.hpp                                |  4 -
 vm/slot_visitor.hpp                           | 14 +---
 17 files changed, 175 insertions(+), 143 deletions(-)

diff --git a/basis/compiler/cfg/representations/peephole/peephole.factor b/basis/compiler/cfg/representations/peephole/peephole.factor
index 1c590f88ff..22366f5714 100644
--- a/basis/compiler/cfg/representations/peephole/peephole.factor
+++ b/basis/compiler/cfg/representations/peephole/peephole.factor
@@ -46,14 +46,14 @@ M: ##load-integer optimize-insn
 ! if the architecture supports it
 : convert-to-load-double? ( insn -- ? )
     {
-        [ drop object-immediates? ]
+        [ drop fused-unboxing? ]
         [ dst>> rep-of double-rep? ]
         [ obj>> float? ]
     } 1&& ;
 
 : convert-to-load-vector? ( insn -- ? )
     {
-        [ drop object-immediates? ]
+        [ drop fused-unboxing? ]
         [ dst>> rep-of vector-rep? ]
         [ obj>> byte-array? ]
     } 1&& ;
diff --git a/basis/compiler/cfg/value-numbering/misc/misc.factor b/basis/compiler/cfg/value-numbering/misc/misc.factor
index e608c6e4ce..2624b29b61 100644
--- a/basis/compiler/cfg/value-numbering/misc/misc.factor
+++ b/basis/compiler/cfg/value-numbering/misc/misc.factor
@@ -1,13 +1,14 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors compiler.cfg.instructions
+USING: accessors cpu.architecture kernel
+compiler.cfg.instructions
 compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.rewrite cpu.architecture kernel ;
+compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering.misc
 
 M: ##replace rewrite
-    object-immediates? [
-        [ loc>> ] [ src>> vreg>insn ] bi dup literal-insn?
-        [ insn>literal swap \ ##replace-imm new-insn ]
-        [ 2drop f ] if
-    ] [ drop f ] if ;
+    [ loc>> ] [ src>> vreg>insn ] bi
+    dup literal-insn? [
+        insn>literal dup immediate-store?
+        [ swap \ ##replace-imm new-insn ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 7613a5948a..7c281d0fe7 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -60,6 +60,74 @@ IN: compiler.cfg.value-numbering.tests
     } value-numbering-step
 ] unit-test
 
+! ##load-reference/##replace fusion
+cpu x86? [
+    [
+        {
+            T{ ##load-integer f 0 10 }
+            T{ ##replace-imm f 10 D 0 }
+        }
+    ] [
+        {
+            T{ ##load-integer f 0 10 }
+            T{ ##replace f 0 D 0 }
+        } value-numbering-step
+    ] unit-test
+
+    [
+        {
+            T{ ##load-reference f 0 f }
+            T{ ##replace-imm f f D 0 }
+        }
+    ] [
+        {
+            T{ ##load-reference f 0 f }
+            T{ ##replace f 0 D 0 }
+        } value-numbering-step
+    ] unit-test
+] when
+
+cpu x86.32? [
+    [
+        {
+            T{ ##load-reference f 0 + }
+            T{ ##replace-imm f 10 D + }
+        }
+    ] [
+        {
+            T{ ##load-reference f 0 + }
+            T{ ##replace f 0 D 0 }
+        } value-numbering-step
+    ] unit-test
+] when
+
+cpu x86.64? [
+    [
+        {
+            T{ ##load-integer f 0 10,000,000,000 }
+            T{ ##replace f 0 D 0 }
+        }
+    ] [
+        {
+            T{ ##load-integer f 0 10,000,000,000 }
+            T{ ##replace f 0 D 0 }
+        } value-numbering-step
+    ] unit-test
+
+    ! Boundary case
+    [
+        {
+            T{ ##load-integer f 0 HEX: 7fffffff }
+            T{ ##replace f 0 D 0 }
+        }
+    ] [
+        {
+            T{ ##load-integer f 0 HEX: 7fffffff }
+            T{ ##replace f 0 D 0 }
+        } value-numbering-step
+    ] unit-test
+] when
+
 ! Double compare elimination
 [
     {
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index ebc9c7b476..427c7ff94c 100644
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -7,6 +7,15 @@ system combinators math.bitwise math.order generalizations
 accessors growable fry compiler.constants memoize ;
 IN: compiler.codegen.fixup
 
+! Utilities
+: push-uint ( value vector -- )
+    [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+    swap set-alien-unsigned-4 ;
+
+: push-double ( value vector -- )
+    [ length ] [ B{ 0 0 0 0 0 0 0 0 } swap push-all ] [ underlying>> ] tri
+    swap set-alien-double ;
+
 ! Owner
 SYMBOL: compiling-word
 
@@ -42,16 +51,18 @@ TUPLE: label-fixup { label label } { class integer } { offset integer } ;
 ! Relocation table
 SYMBOL: relocation-table
 
-: push-4 ( value vector -- )
-    [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
-    swap set-alien-unsigned-4 ;
-
 : add-relocation-entry ( type class offset -- )
-    { 0 24 28 } bitfield relocation-table get push-4 ;
+    { 0 24 28 } bitfield relocation-table get push-uint ;
 
 : rel-fixup ( class type -- )
     swap compiled-offset add-relocation-entry ;
 
+! Binary literal table
+SYMBOL: binary-literal-table
+
+: add-binary-literal ( obj -- label )
+    <label> [ 2array binary-literal-table get push ] keep ;
+
 ! Caching common symbol names reduces image size a bit
 MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
 
@@ -73,11 +84,8 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
 : rel-literal ( literal class -- )
     [ add-literal ] dip rt-literal rel-fixup ;
 
-: rel-float ( literal class -- )
-    [ add-literal ] dip rt-float rel-fixup ;
-
-: rel-byte-array ( literal class -- )
-    [ add-literal ] dip rt-byte-array rel-fixup ;
+: rel-binary-literal ( literal class -- )
+    [ add-binary-literal ] dip label-fixup ;
 
 : rel-this ( class -- )
     rt-this rel-fixup ;
@@ -95,20 +103,20 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
     rt-decks-offset rel-fixup ;
 
 ! And the rest
-: resolve-offset ( label-fixup -- offset )
+: compute-target ( label-fixup -- offset )
     label>> offset>> [ "Unresolved label" throw ] unless* ;
 
-: resolve-absolute-label ( label-fixup -- )
-    dup resolve-offset neg add-literal
-    [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
+: compute-relative-label ( label-fixup -- label )
+    [ class>> ] [ offset>> ] [ compute-target ] tri 3array ;
 
-: resolve-relative-label ( label-fixup -- label )
-    [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
+: compute-absolute-label ( label-fixup -- )
+    [ compute-target neg add-literal ]
+    [ [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ] bi ;
 
-: resolve-labels ( label-fixups -- labels' )
+: compute-labels ( label-fixups -- labels' )
     [ class>> rc-absolute? ] partition
-    [ [ resolve-absolute-label ] each ]
-    [ [ resolve-relative-label ] map concat ]
+    [ [ compute-absolute-label ] each ]
+    [ [ compute-relative-label ] map concat ]
     bi* ;
 
 : init-fixup ( word -- )
@@ -116,13 +124,39 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
     V{ } clone parameter-table set
     V{ } clone literal-table set
     V{ } clone label-table set
-    BV{ } clone relocation-table set ;
+    BV{ } clone relocation-table set
+    V{ } clone binary-literal-table set ;
+
+: alignment ( align -- n )
+    [ compiled-offset dup ] dip align swap - ;
+
+: (align-code) ( n -- )
+    0 <repetition> % ;
+
+: align-code ( n -- )
+    alignment (align-code) ;
+
+GENERIC# emit-data 1 ( obj label -- )
+
+M: float emit-data
+    8 align-code
+    resolve-label
+    building get push-double ;
+
+M: byte-array emit-data
+    16 align-code
+    resolve-label
+    building get push-all ;
+
+: emit-binary-literals ( -- )
+    binary-literal-table get [ emit-data ] assoc-each ;
 
 : with-fixup ( word quot -- code )
     '[
         init-fixup
         @
-        label-table [ resolve-labels ] change
+        emit-binary-literals
+        label-table [ compute-labels ] change
         parameter-table get >array
         literal-table get >array
         relocation-table get >byte-array
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index ca9dc5136d..f72a2c4ec5 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -67,8 +67,6 @@ CONSTANT: rt-vm 9
 CONSTANT: rt-cards-offset 10
 CONSTANT: rt-decks-offset 11
 CONSTANT: rt-exception-handler 12
-CONSTANT: rt-float 13
-CONSTANT: rt-byte-array 14
 
 : rc-absolute? ( n -- ? )
     ${
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index cac7ea4d7a..d156b2f39d 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -506,9 +506,9 @@ M: stack-params param-reg 2drop ;
 
 ! Does this architecture support %load-double, %load-vector and
 ! objects in %compare-imm?
-HOOK: object-immediates? cpu ( -- ? )
+HOOK: fused-unboxing? cpu ( -- ? )
 
-M: object object-immediates? f ;
+M: object fused-unboxing? f ;
 
 ! Can this value be an immediate operand for %add-imm, %sub-imm,
 ! or %mul-imm?
@@ -522,9 +522,12 @@ HOOK: immediate-bitwise? cpu ( n -- ? )
 ! %compare-imm-branch?
 HOOK: immediate-comparand? cpu ( n -- ? )
 
+! Can this value be an immediate operand for %replace-imm?
+HOOK: immediate-store? cpu ( obj -- ? )
+
 M: object immediate-comparand? ( n -- ? )
     {
-        { [ dup integer? ] [ immediate-arithmetic? ] }
+        { [ dup fixnum? ] [ tag-fixnum immediate-arithmetic? ] }
         { [ dup not ] [ drop t ] }
         [ drop f ]
     } cond ;
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index a414a934f7..cd0fa4faff 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -25,23 +25,13 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 frame-reg EBP ;
 M: x86.32 temp-reg ECX ;
 
-M: x86.32 object-immediates? ( -- ? ) t ;
-
 M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
 
-M: x86.32 %replace-imm ( src loc -- )
-    loc>operand swap
-    {
-        { [ dup not ] [ drop \ f type-number MOV ] }
-        { [ dup fixnum? ] [ tag-fixnum MOV ] }
-        [ [ HEX: ffffffff MOV ] dip rc-absolute rel-literal ]
-    } cond ;
-
 M: x86.32 %load-double ( dst val -- )
-    [ 0 [] MOVSD ] dip rc-absolute rel-float ;
+    [ 0 [] MOVSD ] dip rc-absolute rel-binary-literal ;
 
 M:: x86.32 %load-vector ( dst val rep -- )
-    dst 0 [] rep copy-memory* val rc-absolute rel-byte-array ;
+    dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ;
 
 M: x86.32 %mov-vm-ptr ( reg -- )
     0 MOV 0 rc-absolute-cell rel-vm ;
@@ -81,9 +71,9 @@ M:: x86.32 %dispatch ( src temp -- )
     temp HEX: 7f [+] JMP
     building get length :> end
     ! Fix up the displacement above
-    cell code-alignment
+    cell alignment
     [ end start - + building get dup pop* push ]
-    [ align-code ]
+    [ (align-code) ]
     bi ;
 
 M: x86.32 pic-tail-reg EDX ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 01f3c4677b..93f7c6d22f 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -3,7 +3,7 @@
 USING: accessors arrays kernel math namespaces make sequences
 system layouts alien alien.c-types alien.accessors alien.libraries
 slots splitting assocs combinators locals compiler.constants
-compiler.codegen compiler.codegen.fixup
+compiler.codegen compiler.codegen.alien compiler.codegen.fixup
 compiler.cfg.instructions compiler.cfg.builder
 compiler.cfg.intrinsics compiler.cfg.stack-frame
 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
@@ -46,6 +46,12 @@ M: x86.64 %mov-vm-ptr ( reg -- )
 M: x86.64 %vm-field ( dst offset -- )
     [ vm-reg ] dip [+] MOV ;
 
+M: x86.64 %load-double ( dst val -- )
+    [ 0 [RIP+] MOVSD ] dip rc-relative rel-binary-literal ;
+
+M:: x86.64 %load-vector ( dst val rep -- )
+    dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ;
+
 M: x86.64 %set-vm-field ( src offset -- )
     [ vm-reg ] dip [+] swap MOV ;
 
@@ -85,9 +91,9 @@ M:: x86.64 %dispatch ( src temp -- )
     temp HEX: 7f [+] JMP
     building get length :> end
     ! Fix up the displacement above
-    cell code-alignment
+    cell alignment
     [ end start - + building get dup pop* push ]
-    [ align-code ]
+    [ (align-code) ]
     bi ;
 
 M: stack-params copy-register*
diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor
index a1868a3bc8..fd696b7fda 100644
--- a/basis/cpu/x86/64/unix/unix.factor
+++ b/basis/cpu/x86/64/unix/unix.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays sequences math splitting make assocs kernel
-layouts system alien.c-types classes.struct cpu.architecture 
-cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 compiler.codegen
-compiler.cfg.registers ;
+USING: accessors arrays sequences math splitting make assocs
+kernel layouts system alien.c-types classes.struct
+cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
+cpu.x86 compiler.codegen.alien compiler.cfg.registers ;
 IN: cpu.x86.64.unix
 
 M: int-regs param-regs
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 6c485e1630..b0d4f05a0e 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -70,6 +70,10 @@ HOOK: pic-tail-reg cpu ( -- reg )
 
 M: x86 complex-addressing? t ;
 
+M: x86 fused-unboxing? ( -- ? ) t ;
+
+M: x86 immediate-store? ( obj -- ? ) immediate-comparand? ;
+
 M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
 
 M: x86 %load-reference
@@ -88,7 +92,17 @@ M: ds-loc loc>operand n>> ds-reg reg-stack ;
 M: rs-loc loc>operand n>> rs-reg reg-stack ;
 
 M: x86 %peek loc>operand MOV ;
+
 M: x86 %replace loc>operand swap MOV ;
+
+M: x86 %replace-imm
+    loc>operand swap
+    {
+        { [ dup not ] [ drop \ f type-number MOV ] }
+        { [ dup fixnum? ] [ tag-fixnum MOV ] }
+        [ [ HEX: ffffffff MOV ] dip rc-absolute rel-literal ]
+    } cond ;
+
 : (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; inline
 M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
 M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
@@ -109,12 +123,6 @@ M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
 
 M: x86 %return ( -- ) 0 RET ;
 
-: code-alignment ( align -- n )
-    [ building get length dup ] dip align swap - ;
-
-: align-code ( n -- )
-    0 <repetition> % ;
-
 : (%slot) ( obj slot scale tag -- op ) neg <indirect> ; inline
 : (%slot-imm) ( obj slot tag -- op ) slot-offset [+] ; inline
 
@@ -388,8 +396,8 @@ M: x86.64 has-small-reg? 2drop t ;
             { c:uchar  [ 8 %alien-unsigned-getter ] }
             { c:short  [ 16 %alien-signed-getter ] }
             { c:ushort [ 16 %alien-unsigned-getter ] }
-            { c:int    [ 32 [ 2drop ] %alien-integer-getter ] }
-            { c:uint   [ 32 %alien-signed-getter ] }
+            { c:int    [ 32 %alien-signed-getter ] }
+            { c:uint   [ 32 [ 2drop ] %alien-integer-getter ] }
         } case
     ] [ [ drop ] 2dip %copy ] ?if ;
 
@@ -1448,7 +1456,7 @@ M: x86 %scalar>vector %copy ;
 M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
 M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
 
-M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
+M: x86 %loop-entry 16 alignment [ NOP ] times ;
 
 M:: x86 %restore-context ( temp1 temp2 -- )
     #! Load Factor stack pointers on entry from C to Factor.
diff --git a/vm/code_blocks.cpp b/vm/code_blocks.cpp
index 351ce5a95e..e8c6216d8d 100755
--- a/vm/code_blocks.cpp
+++ b/vm/code_blocks.cpp
@@ -265,12 +265,6 @@ struct initial_code_block_visitor {
 		case RT_LITERAL:
 			op.store_value(next_literal());
 			break;
-		case RT_FLOAT:
-			op.store_float(next_literal());
-			break;
-		case RT_BYTE_ARRAY:
-			op.store_byte_array(next_literal());
-			break;
 		case RT_ENTRY_POINT:
 			op.store_value(parent->compute_entry_point_address(next_literal()));
 			break;
diff --git a/vm/compaction.cpp b/vm/compaction.cpp
index f596c3040f..5e52c70b0c 100644
--- a/vm/compaction.cpp
+++ b/vm/compaction.cpp
@@ -111,12 +111,6 @@ struct code_block_compaction_relocation_visitor {
 		case RT_LITERAL:
 			op.store_value(slot_forwarder.visit_pointer(op.load_value(old_offset)));
 			break;
-		case RT_FLOAT:
-			op.store_float(slot_forwarder.visit_pointer(op.load_float(old_offset)));
-			break;
-		case RT_BYTE_ARRAY:
-			op.store_byte_array(slot_forwarder.visit_pointer(op.load_byte_array(old_offset)));
-			break;
 		case RT_ENTRY_POINT:
 		case RT_ENTRY_POINT_PIC:
 		case RT_ENTRY_POINT_PIC_TAIL:
diff --git a/vm/image.cpp b/vm/image.cpp
index b64d828947..ccce96a952 100755
--- a/vm/image.cpp
+++ b/vm/image.cpp
@@ -185,12 +185,6 @@ struct code_block_fixup_relocation_visitor {
 		case RT_LITERAL:
 			op.store_value(data_visitor.visit_pointer(op.load_value(old_offset)));
 			break;
-		case RT_FLOAT:
-			op.store_float(data_visitor.visit_pointer(op.load_float(old_offset)));
-			break;
-		case RT_BYTE_ARRAY:
-			op.store_byte_array(data_visitor.visit_pointer(op.load_byte_array(old_offset)));
-			break;
 		case RT_ENTRY_POINT:
 		case RT_ENTRY_POINT_PIC:
 		case RT_ENTRY_POINT_PIC_TAIL:
diff --git a/vm/instruction_operands.cpp b/vm/instruction_operands.cpp
index 65a2f93b2d..b11db279a5 100644
--- a/vm/instruction_operands.cpp
+++ b/vm/instruction_operands.cpp
@@ -62,26 +62,6 @@ fixnum instruction_operand::load_value()
 	return load_value(pointer);
 }
 
-cell instruction_operand::load_float()
-{
-	return (cell)load_value() - boxed_float_offset;
-}
-
-cell instruction_operand::load_float(cell pointer)
-{
-	return (cell)load_value(pointer) - boxed_float_offset;
-}
-
-cell instruction_operand::load_byte_array()
-{
-	return (cell)load_value() - byte_array_offset;
-}
-
-cell instruction_operand::load_byte_array(cell pointer)
-{
-	return (cell)load_value(pointer) - byte_array_offset;
-}
-
 code_block *instruction_operand::load_code_block(cell relative_to)
 {
 	return ((code_block *)load_value(relative_to) - 1);
@@ -155,16 +135,6 @@ void instruction_operand::store_value(fixnum absolute_value)
 	}
 }
 
-void instruction_operand::store_float(cell value)
-{
-	store_value((fixnum)value + boxed_float_offset);
-}
-
-void instruction_operand::store_byte_array(cell value)
-{
-	store_value((fixnum)value + byte_array_offset);
-}
-
 void instruction_operand::store_code_block(code_block *compiled)
 {
 	store_value((cell)compiled->entry_point());
diff --git a/vm/instruction_operands.hpp b/vm/instruction_operands.hpp
index 7adb517f18..475e48d206 100644
--- a/vm/instruction_operands.hpp
+++ b/vm/instruction_operands.hpp
@@ -30,10 +30,6 @@ enum relocation_type {
 	type since its used in a situation where relocation arguments cannot
 	be passed in, and so RT_DLSYM is inappropriate (Windows only) */
 	RT_EXCEPTION_HANDLER,
-	/* pointer to a float's payload */
-	RT_FLOAT,
-	/* pointer to a byte array's payload */
-	RT_BYTE_ARRAY,
 
 };
 
@@ -117,8 +113,6 @@ struct relocation_entry {
 		case RT_CARDS_OFFSET:
 		case RT_DECKS_OFFSET:
 		case RT_EXCEPTION_HANDLER:
-		case RT_FLOAT:
-		case RT_BYTE_ARRAY:
 			return 0;
 		default:
 			critical_error("Bad rel type in number_of_parameters()",rel_type());
@@ -159,18 +153,12 @@ struct instruction_operand {
 	fixnum load_value_masked(cell mask, cell bits, cell shift);
 	fixnum load_value(cell relative_to);
 	fixnum load_value();
-	cell load_float(cell relative_to);
-	cell load_float();
-	cell load_byte_array(cell relative_to);
-	cell load_byte_array();
 	code_block *load_code_block(cell relative_to);
 	code_block *load_code_block();
 
 	void store_value_2_2(fixnum value);
 	void store_value_masked(fixnum value, cell mask, cell shift);
 	void store_value(fixnum value);
-	void store_float(cell value);
-	void store_byte_array(cell value);
 	void store_code_block(code_block *compiled);
 };
 
diff --git a/vm/layouts.hpp b/vm/layouts.hpp
index 35f04e7cc5..5e7ca0279f 100644
--- a/vm/layouts.hpp
+++ b/vm/layouts.hpp
@@ -178,8 +178,6 @@ struct bignum : public object {
 	cell *data() const { return (cell *)(this + 1); }
 };
 
-const cell byte_array_offset = 16 - BYTE_ARRAY_TYPE;
-
 struct byte_array : public object {
 	static const cell type_number = BYTE_ARRAY_TYPE;
 	static const cell element_size = 1;
@@ -244,8 +242,6 @@ struct wrapper : public object {
 	cell object;
 };
 
-const fixnum boxed_float_offset = 8 - FLOAT_TYPE;
-
 /* Assembly code makes assumptions about the layout of this struct */
 struct boxed_float : object {
 	static const cell type_number = FLOAT_TYPE;
diff --git a/vm/slot_visitor.hpp b/vm/slot_visitor.hpp
index d0507da93f..d4dd44bed1 100644
--- a/vm/slot_visitor.hpp
+++ b/vm/slot_visitor.hpp
@@ -192,20 +192,8 @@ struct literal_references_visitor {
 
 	void operator()(instruction_operand op)
 	{
-		switch(op.rel_type())
-		{
-		case RT_LITERAL:
+		if(op.rel_type() == RT_LITERAL)
 			op.store_value(visitor->visit_pointer(op.load_value()));
-			break;
-		case RT_FLOAT:
-			op.store_float(visitor->visit_pointer(op.load_float()));
-			break;
-		case RT_BYTE_ARRAY:
-			op.store_byte_array(visitor->visit_pointer(op.load_byte_array()));
-			break;
-		default:
-			break;
-		}
 	}
 };