From f436fd0c0f1645b69c0152eeb9d6f2a4f953f4aa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 7 Oct 2008 16:16:50 -0500
Subject: [PATCH 001/318] Merging in new codegen

---
 {unfinished => basis}/compiler/alien/alien.factor                 | 0
 {unfinished => basis}/compiler/cfg/builder/authors.txt            | 0
 {unfinished => basis}/compiler/cfg/builder/builder-tests.factor   | 0
 {unfinished => basis}/compiler/cfg/builder/builder.factor         | 0
 {unfinished => basis}/compiler/cfg/builder/summary.txt            | 0
 {unfinished => basis}/compiler/cfg/builder/tags.txt               | 0
 {unfinished => basis}/compiler/cfg/cfg.factor                     | 0
 {unfinished => basis}/compiler/cfg/debugger/debugger.factor       | 0
 .../compiler/cfg/instructions/instructions.factor                 | 0
 .../compiler/cfg/instructions/syntax/syntax.factor                | 0
 {unfinished => basis}/compiler/cfg/iterator/iterator.factor       | 0
 .../compiler/cfg/linear-scan/allocation/allocation.factor         | 0
 .../compiler/cfg/linear-scan/assignment/assignment-tests.factor   | 0
 .../compiler/cfg/linear-scan/assignment/assignment.factor         | 0
 .../compiler/cfg/linear-scan/debugger/debugger.factor             | 0
 .../compiler/cfg/linear-scan/linear-scan-tests.factor             | 0
 {unfinished => basis}/compiler/cfg/linear-scan/linear-scan.factor | 0
 .../compiler/cfg/linear-scan/live-intervals/live-intervals.factor | 0
 .../compiler/cfg/linearization/linearization.factor               | 0
 {unfinished => basis}/compiler/cfg/registers/registers.factor     | 0
 {unfinished => basis}/compiler/cfg/rpo/rpo.factor                 | 0
 {unfinished => basis}/compiler/cfg/stack-frame/stack-frame.factor | 0
 {unfinished => basis}/compiler/cfg/stacks/authors.txt             | 0
 {unfinished => basis}/compiler/cfg/stacks/stacks.factor           | 0
 {unfinished => basis}/compiler/cfg/templates/templates.factor     | 0
 {unfinished => basis}/compiler/codegen/codegen.factor             | 0
 {unfinished => basis}/compiler/codegen/fixup/authors.txt          | 0
 {unfinished => basis}/compiler/codegen/fixup/fixup.factor         | 0
 {unfinished => basis}/compiler/codegen/fixup/summary.txt          | 0
 29 files changed, 0 insertions(+), 0 deletions(-)
 rename {unfinished => basis}/compiler/alien/alien.factor (100%)
 rename {unfinished => basis}/compiler/cfg/builder/authors.txt (100%)
 rename {unfinished => basis}/compiler/cfg/builder/builder-tests.factor (100%)
 rename {unfinished => basis}/compiler/cfg/builder/builder.factor (100%)
 rename {unfinished => basis}/compiler/cfg/builder/summary.txt (100%)
 rename {unfinished => basis}/compiler/cfg/builder/tags.txt (100%)
 rename {unfinished => basis}/compiler/cfg/cfg.factor (100%)
 rename {unfinished => basis}/compiler/cfg/debugger/debugger.factor (100%)
 rename {unfinished => basis}/compiler/cfg/instructions/instructions.factor (100%)
 rename {unfinished => basis}/compiler/cfg/instructions/syntax/syntax.factor (100%)
 rename {unfinished => basis}/compiler/cfg/iterator/iterator.factor (100%)
 rename {unfinished => basis}/compiler/cfg/linear-scan/allocation/allocation.factor (100%)
 rename {unfinished => basis}/compiler/cfg/linear-scan/assignment/assignment-tests.factor (100%)
 rename {unfinished => basis}/compiler/cfg/linear-scan/assignment/assignment.factor (100%)
 rename {unfinished => basis}/compiler/cfg/linear-scan/debugger/debugger.factor (100%)
 rename {unfinished => basis}/compiler/cfg/linear-scan/linear-scan-tests.factor (100%)
 rename {unfinished => basis}/compiler/cfg/linear-scan/linear-scan.factor (100%)
 rename {unfinished => basis}/compiler/cfg/linear-scan/live-intervals/live-intervals.factor (100%)
 rename {unfinished => basis}/compiler/cfg/linearization/linearization.factor (100%)
 rename {unfinished => basis}/compiler/cfg/registers/registers.factor (100%)
 rename {unfinished => basis}/compiler/cfg/rpo/rpo.factor (100%)
 rename {unfinished => basis}/compiler/cfg/stack-frame/stack-frame.factor (100%)
 rename {unfinished => basis}/compiler/cfg/stacks/authors.txt (100%)
 rename {unfinished => basis}/compiler/cfg/stacks/stacks.factor (100%)
 rename {unfinished => basis}/compiler/cfg/templates/templates.factor (100%)
 rename {unfinished => basis}/compiler/codegen/codegen.factor (100%)
 rename {unfinished => basis}/compiler/codegen/fixup/authors.txt (100%)
 rename {unfinished => basis}/compiler/codegen/fixup/fixup.factor (100%)
 rename {unfinished => basis}/compiler/codegen/fixup/summary.txt (100%)

diff --git a/unfinished/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor
similarity index 100%
rename from unfinished/compiler/alien/alien.factor
rename to basis/compiler/alien/alien.factor
diff --git a/unfinished/compiler/cfg/builder/authors.txt b/basis/compiler/cfg/builder/authors.txt
similarity index 100%
rename from unfinished/compiler/cfg/builder/authors.txt
rename to basis/compiler/cfg/builder/authors.txt
diff --git a/unfinished/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
similarity index 100%
rename from unfinished/compiler/cfg/builder/builder-tests.factor
rename to basis/compiler/cfg/builder/builder-tests.factor
diff --git a/unfinished/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
similarity index 100%
rename from unfinished/compiler/cfg/builder/builder.factor
rename to basis/compiler/cfg/builder/builder.factor
diff --git a/unfinished/compiler/cfg/builder/summary.txt b/basis/compiler/cfg/builder/summary.txt
similarity index 100%
rename from unfinished/compiler/cfg/builder/summary.txt
rename to basis/compiler/cfg/builder/summary.txt
diff --git a/unfinished/compiler/cfg/builder/tags.txt b/basis/compiler/cfg/builder/tags.txt
similarity index 100%
rename from unfinished/compiler/cfg/builder/tags.txt
rename to basis/compiler/cfg/builder/tags.txt
diff --git a/unfinished/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
similarity index 100%
rename from unfinished/compiler/cfg/cfg.factor
rename to basis/compiler/cfg/cfg.factor
diff --git a/unfinished/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
similarity index 100%
rename from unfinished/compiler/cfg/debugger/debugger.factor
rename to basis/compiler/cfg/debugger/debugger.factor
diff --git a/unfinished/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
similarity index 100%
rename from unfinished/compiler/cfg/instructions/instructions.factor
rename to basis/compiler/cfg/instructions/instructions.factor
diff --git a/unfinished/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor
similarity index 100%
rename from unfinished/compiler/cfg/instructions/syntax/syntax.factor
rename to basis/compiler/cfg/instructions/syntax/syntax.factor
diff --git a/unfinished/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor
similarity index 100%
rename from unfinished/compiler/cfg/iterator/iterator.factor
rename to basis/compiler/cfg/iterator/iterator.factor
diff --git a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
similarity index 100%
rename from unfinished/compiler/cfg/linear-scan/allocation/allocation.factor
rename to basis/compiler/cfg/linear-scan/allocation/allocation.factor
diff --git a/unfinished/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
similarity index 100%
rename from unfinished/compiler/cfg/linear-scan/assignment/assignment-tests.factor
rename to basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
diff --git a/unfinished/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
similarity index 100%
rename from unfinished/compiler/cfg/linear-scan/assignment/assignment.factor
rename to basis/compiler/cfg/linear-scan/assignment/assignment.factor
diff --git a/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
similarity index 100%
rename from unfinished/compiler/cfg/linear-scan/debugger/debugger.factor
rename to basis/compiler/cfg/linear-scan/debugger/debugger.factor
diff --git a/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
similarity index 100%
rename from unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor
rename to basis/compiler/cfg/linear-scan/linear-scan-tests.factor
diff --git a/unfinished/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
similarity index 100%
rename from unfinished/compiler/cfg/linear-scan/linear-scan.factor
rename to basis/compiler/cfg/linear-scan/linear-scan.factor
diff --git a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
similarity index 100%
rename from unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
rename to basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
diff --git a/unfinished/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
similarity index 100%
rename from unfinished/compiler/cfg/linearization/linearization.factor
rename to basis/compiler/cfg/linearization/linearization.factor
diff --git a/unfinished/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor
similarity index 100%
rename from unfinished/compiler/cfg/registers/registers.factor
rename to basis/compiler/cfg/registers/registers.factor
diff --git a/unfinished/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
similarity index 100%
rename from unfinished/compiler/cfg/rpo/rpo.factor
rename to basis/compiler/cfg/rpo/rpo.factor
diff --git a/unfinished/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
similarity index 100%
rename from unfinished/compiler/cfg/stack-frame/stack-frame.factor
rename to basis/compiler/cfg/stack-frame/stack-frame.factor
diff --git a/unfinished/compiler/cfg/stacks/authors.txt b/basis/compiler/cfg/stacks/authors.txt
similarity index 100%
rename from unfinished/compiler/cfg/stacks/authors.txt
rename to basis/compiler/cfg/stacks/authors.txt
diff --git a/unfinished/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
similarity index 100%
rename from unfinished/compiler/cfg/stacks/stacks.factor
rename to basis/compiler/cfg/stacks/stacks.factor
diff --git a/unfinished/compiler/cfg/templates/templates.factor b/basis/compiler/cfg/templates/templates.factor
similarity index 100%
rename from unfinished/compiler/cfg/templates/templates.factor
rename to basis/compiler/cfg/templates/templates.factor
diff --git a/unfinished/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
similarity index 100%
rename from unfinished/compiler/codegen/codegen.factor
rename to basis/compiler/codegen/codegen.factor
diff --git a/unfinished/compiler/codegen/fixup/authors.txt b/basis/compiler/codegen/fixup/authors.txt
similarity index 100%
rename from unfinished/compiler/codegen/fixup/authors.txt
rename to basis/compiler/codegen/fixup/authors.txt
diff --git a/unfinished/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
similarity index 100%
rename from unfinished/compiler/codegen/fixup/fixup.factor
rename to basis/compiler/codegen/fixup/fixup.factor
diff --git a/unfinished/compiler/codegen/fixup/summary.txt b/basis/compiler/codegen/fixup/summary.txt
similarity index 100%
rename from unfinished/compiler/codegen/fixup/summary.txt
rename to basis/compiler/codegen/fixup/summary.txt

From e69278b8fc24a81f1d3ad983ca789e04436f49ac Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 7 Oct 2008 16:17:55 -0500
Subject: [PATCH 002/318] Merging in new codegen

---
 basis/compiler/compiler.factor                |  70 +-
 basis/compiler/generator/authors.txt          |   1 -
 basis/compiler/generator/fixup/authors.txt    |   1 -
 .../generator/fixup/fixup-docs.factor         |  19 -
 basis/compiler/generator/fixup/fixup.factor   | 154 ----
 basis/compiler/generator/fixup/summary.txt    |   1 -
 .../compiler/generator/generator-docs.factor  |  85 ---
 basis/compiler/generator/generator.factor     | 581 ---------------
 .../generator/iterator/iterator.factor        |  45 --
 .../compiler/generator/registers/authors.txt  |   1 -
 .../generator/registers/registers.factor      | 672 ------------------
 .../compiler/generator/registers/summary.txt  |   1 -
 basis/compiler/generator/summary.txt          |   1 -
 basis/compiler/generator/tags.txt             |   1 -
 basis/cpu/architecture/architecture.factor    |  12 +
 basis/cpu/x86/allot/allot.factor              |  37 +-
 .../cpu/x86/architecture/architecture.factor  |   5 +
 basis/cpu/x86/sse2/sse2.factor                |   5 +-
 .../compiler/cfg.bluesky/alias/alias.factor   | 293 --------
 unfinished/compiler/cfg.bluesky/authors.txt   |   1 -
 .../cfg.bluesky/builder/builder-tests.factor  |   4 -
 .../cfg.bluesky/builder/builder.factor        | 256 -------
 unfinished/compiler/cfg.bluesky/cfg.factor    |  47 --
 .../elaboration/elaboration.factor            |  49 --
 .../cfg.bluesky/kill-nops/kill-nops.factor    |   9 -
 .../live-ranges/live-ranges.factor            |  40 --
 .../predecessors/predecessors.factor          |  12 -
 .../cfg.bluesky/simplifier/simplifier.factor  |  25 -
 .../compiler/cfg.bluesky/stack/stack.factor   |  42 --
 unfinished/compiler/cfg.bluesky/summary.txt   |   1 -
 .../vn/conditions/conditions.factor           |  53 --
 .../vn/constant-fold/constant-fold.factor     |  17 -
 .../vn/expressions/expressions.factor         |  64 --
 .../cfg.bluesky/vn/graph/graph.factor         |  37 -
 .../cfg.bluesky/vn/liveness/liveness.factor   |  37 -
 .../cfg.bluesky/vn/propagate/propagate.factor |  43 --
 .../cfg.bluesky/vn/simplify/simplify.factor   | 220 ------
 unfinished/compiler/cfg.bluesky/vn/vn.factor  |  31 -
 .../write-barrier/write-barrier.factor        |  26 -
 .../compiler/lvops.bluesky/lvops.factor       |  21 -
 .../machine.bluesky/builder/builder.factor    |  50 --
 .../machine.bluesky/debugger/debugger.factor  |  45 --
 .../simplifier/simplifier.factor              |  18 -
 unfinished/compiler/new/new.factor            | 122 ----
 .../vops.bluesky/builder/builder.factor       | 202 ------
 unfinished/compiler/vops.bluesky/vops.factor  | 181 -----
 46 files changed, 108 insertions(+), 3530 deletions(-)
 delete mode 100644 basis/compiler/generator/authors.txt
 delete mode 100644 basis/compiler/generator/fixup/authors.txt
 delete mode 100644 basis/compiler/generator/fixup/fixup-docs.factor
 delete mode 100644 basis/compiler/generator/fixup/fixup.factor
 delete mode 100644 basis/compiler/generator/fixup/summary.txt
 delete mode 100644 basis/compiler/generator/generator-docs.factor
 delete mode 100644 basis/compiler/generator/generator.factor
 delete mode 100644 basis/compiler/generator/iterator/iterator.factor
 delete mode 100644 basis/compiler/generator/registers/authors.txt
 delete mode 100644 basis/compiler/generator/registers/registers.factor
 delete mode 100644 basis/compiler/generator/registers/summary.txt
 delete mode 100644 basis/compiler/generator/summary.txt
 delete mode 100644 basis/compiler/generator/tags.txt
 delete mode 100644 unfinished/compiler/cfg.bluesky/alias/alias.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/authors.txt
 delete mode 100644 unfinished/compiler/cfg.bluesky/builder/builder-tests.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/builder/builder.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/cfg.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/elaboration/elaboration.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/kill-nops/kill-nops.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/live-ranges/live-ranges.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/predecessors/predecessors.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/simplifier/simplifier.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/stack/stack.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/summary.txt
 delete mode 100644 unfinished/compiler/cfg.bluesky/vn/conditions/conditions.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/vn/constant-fold/constant-fold.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/vn/expressions/expressions.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/vn/graph/graph.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/vn/liveness/liveness.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/vn/propagate/propagate.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/vn/simplify/simplify.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/vn/vn.factor
 delete mode 100644 unfinished/compiler/cfg.bluesky/write-barrier/write-barrier.factor
 delete mode 100644 unfinished/compiler/lvops.bluesky/lvops.factor
 delete mode 100644 unfinished/compiler/machine.bluesky/builder/builder.factor
 delete mode 100644 unfinished/compiler/machine.bluesky/debugger/debugger.factor
 delete mode 100644 unfinished/compiler/machine.bluesky/simplifier/simplifier.factor
 delete mode 100644 unfinished/compiler/new/new.factor
 delete mode 100644 unfinished/compiler/vops.bluesky/builder/builder.factor
 delete mode 100644 unfinished/compiler/vops.bluesky/vops.factor

diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index 1558127293..5235f68eca 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -1,12 +1,30 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces arrays sequences io debugger words fry
-compiler.units continuations vocabs assocs dlists definitions
-math threads graphs generic combinators deques search-deques
-stack-checker stack-checker.state compiler.generator
-compiler.errors compiler.tree.builder compiler.tree.optimizer ;
+USING: accessors kernel namespaces arrays sequences io debugger
+words fry continuations vocabs assocs dlists definitions math
+threads graphs generic combinators deques search-deques
+stack-checker stack-checker.state stack-checker.inlining
+compiler.errors compiler.units compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder
+compiler.cfg.linearization compiler.cfg.linear-scan
+compiler.cfg.stack-frame compiler.codegen ;
 IN: compiler
 
+SYMBOL: compile-queue
+SYMBOL: compiled
+
+: queue-compile ( word -- )
+    {
+        { [ dup "forgotten" word-prop ] [ ] }
+        { [ dup compiled get key? ] [ ] }
+        { [ dup inlined-block? ] [ ] }
+        { [ dup primitive? ] [ ] }
+        [ dup compile-queue get push-front ]
+    } cond drop ;
+
+: maybe-compile ( word -- )
+    dup compiled>> [ drop ] [ queue-compile ] if ;
+
 SYMBOL: +failed+
 
 : ripple-up ( words -- )
@@ -24,10 +42,12 @@ SYMBOL: +failed+
     [ "compiled-effect" set-word-prop ]
     2bi ;
 
-: compile-begins ( word -- )
+: start ( word -- )
+    H{ } clone dependencies set
+    H{ } clone generic-dependencies set
     f swap compiler-error ;
 
-: compile-failed ( word error -- )
+: fail ( word error -- )
     [ swap compiler-error ]
     [
         drop
@@ -35,9 +55,13 @@ SYMBOL: +failed+
         [ f swap compiled get set-at ]
         [ +failed+ save-effect ]
         tri
-    ] 2bi ;
+    ] 2bi
+    return ;
 
-: compile-succeeded ( effect word -- )
+: frontend ( word -- effect nodes )
+    [ build-tree-from-word ] [ fail ] recover optimize-tree ;
+
+: finish ( effect word -- )
     [ swap save-effect ]
     [ compiled-unxref ]
     [
@@ -49,19 +73,27 @@ SYMBOL: +failed+
         ] [ drop ] if
     ] tri ;
 
+: save-asm ( asm -- )
+    [ [ code>> ] [ label>> ] bi compiled get set-at ]
+    [ calls>> [ queue-compile ] each ]
+    bi ;
+
+: backend ( nodes word -- )
+    build-cfg [
+        build-mr
+        linear-scan
+        build-stack-frame
+        generate
+        save-asm
+    ] each ;
+
 : (compile) ( word -- )
     '[
-        H{ } clone dependencies set
-        H{ } clone generic-dependencies set
-
         _ {
-            [ compile-begins ]
-            [
-                [ build-tree-from-word ] [ compile-failed return ] recover
-                optimize-tree
-            ]
-            [ dup generate ]
-            [ compile-succeeded ]
+            [ start ]
+            [ frontend ]
+            [ backend ]
+            [ finish ]
         } cleave
     ] with-return ;
 
diff --git a/basis/compiler/generator/authors.txt b/basis/compiler/generator/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/basis/compiler/generator/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/compiler/generator/fixup/authors.txt b/basis/compiler/generator/fixup/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/basis/compiler/generator/fixup/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/compiler/generator/fixup/fixup-docs.factor b/basis/compiler/generator/fixup/fixup-docs.factor
deleted file mode 100644
index a119d153e6..0000000000
--- a/basis/compiler/generator/fixup/fixup-docs.factor
+++ /dev/null
@@ -1,19 +0,0 @@
-USING: help.syntax help.markup math kernel
-words strings alien compiler.generator ;
-IN: compiler.generator.fixup
-
-HELP: frame-required
-{ $values { "n" "a non-negative integer" } }
-{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
-
-HELP: add-literal
-{ $values { "obj" object } { "n" integer } }
-{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
-
-HELP: rel-dlsym
-{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
-{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
-} ;
-
-HELP: literal-table
-{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;
diff --git a/basis/compiler/generator/fixup/fixup.factor b/basis/compiler/generator/fixup/fixup.factor
deleted file mode 100644
index e8bdc561b7..0000000000
--- a/basis/compiler/generator/fixup/fixup.factor
+++ /dev/null
@@ -1,154 +0,0 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays generic assocs hashtables io.binary
-kernel kernel.private math namespaces make sequences words
-quotations strings alien.accessors alien.strings layouts system
-combinators math.bitwise words.private cpu.architecture
-math.order accessors growable ;
-IN: compiler.generator.fixup
-
-: no-stack-frame -1 ; inline
-
-TUPLE: frame-required n ;
-
-: frame-required ( n -- ) \ frame-required boa , ;
-
-: compute-stack-frame-size ( code -- n )
-    no-stack-frame [
-        dup frame-required? [ n>> max ] [ drop ] if
-    ] reduce ;
-
-GENERIC: fixup* ( frame-size obj -- frame-size )
-
-: code-format 22 getenv ;
-
-: compiled-offset ( -- n ) building get length code-format * ;
-
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-
-M: label fixup*
-    compiled-offset >>offset drop ;
-
-: define-label ( name -- ) <label> swap set ;
-
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
-: if-stack-frame ( frame-size quot -- )
-    swap dup no-stack-frame =
-    [ 2drop ] [ stack-frame-size swap call ] if ; inline
-
-M: word fixup*
-    {
-        { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
-        { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
-    } case ;
-
-SYMBOL: relocation-table
-SYMBOL: label-table
-
-! Relocation classes
-: rc-absolute-cell     0 ;
-: rc-absolute          1 ;
-: rc-relative          2 ;
-: rc-absolute-ppc-2/2  3 ;
-: rc-relative-ppc-2    4 ;
-: rc-relative-ppc-3    5 ;
-: rc-relative-arm-3    6 ;
-: rc-indirect-arm      7 ;
-: rc-indirect-arm-pc   8 ;
-
-: rc-absolute? ( n -- ? )
-    dup rc-absolute-cell =
-    over rc-absolute =
-    rot rc-absolute-ppc-2/2 = or or ;
-
-! Relocation types
-: rt-primitive 0 ;
-: rt-dlsym     1 ;
-: rt-literal   2 ;
-: rt-dispatch  3 ;
-: rt-xt        4 ;
-: rt-here      5 ;
-: rt-label     6 ;
-: rt-immediate 7 ;
-
-TUPLE: label-fixup label class ;
-
-: label-fixup ( label class -- ) \ label-fixup boa , ;
-
-M: label-fixup fixup*
-    dup class>> rc-absolute?
-    [ "Absolute labels not supported" throw ] when
-    dup label>> swap class>> compiled-offset 4 - rot
-    3array label-table get push ;
-
-TUPLE: rel-fixup arg class type ;
-
-: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
-
-: push-4 ( value vector -- )
-    [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
-    swap set-alien-unsigned-4 ;
-
-M: rel-fixup fixup*
-    [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
-    [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
-    [ relocation-table get push-4 ] bi@ ;
-
-M: frame-required fixup* drop ;
-
-M: integer fixup* , ;
-
-: adjoin* ( obj table -- n )
-    2dup swap [ eq? ] curry find drop
-    [ 2nip ] [ dup length >r push r> ] if* ;
-
-SYMBOL: literal-table
-
-: add-literal ( obj -- n ) literal-table get adjoin* ;
-
-: add-dlsym-literals ( symbol dll -- )
-    >r string>symbol r> 2array literal-table get push-all ;
-
-: rel-dlsym ( name dll class -- )
-    >r literal-table get length >r
-    add-dlsym-literals
-    r> r> rt-dlsym rel-fixup ;
-
-: rel-word ( word class -- )
-    >r add-literal r> rt-xt rel-fixup ;
-
-: rel-primitive ( word class -- )
-    >r def>> first r> rt-primitive rel-fixup ;
-
-: rel-literal ( literal class -- )
-    >r add-literal r> rt-literal rel-fixup ;
-
-: rel-this ( class -- )
-    0 swap rt-label rel-fixup ;
-
-: rel-here ( class -- )
-    0 swap rt-here rel-fixup ;
-
-: init-fixup ( -- )
-    BV{ } clone relocation-table set
-    V{ } clone label-table set ;
-
-: resolve-labels ( labels -- labels' )
-    [
-        first3 offset>>
-        [ "Unresolved label" throw ] unless*
-        3array
-    ] map concat ;
-
-: fixup ( code -- literals relocation labels code )
-    [
-        init-fixup
-        dup compute-stack-frame-size swap [ fixup* ] each drop
-
-        literal-table get >array
-        relocation-table get >byte-array
-        label-table get resolve-labels
-    ] { } make ;
diff --git a/basis/compiler/generator/fixup/summary.txt b/basis/compiler/generator/fixup/summary.txt
deleted file mode 100644
index ce83e6d253..0000000000
--- a/basis/compiler/generator/fixup/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Support for generation of relocatable code
diff --git a/basis/compiler/generator/generator-docs.factor b/basis/compiler/generator/generator-docs.factor
deleted file mode 100644
index 5d485b13d4..0000000000
--- a/basis/compiler/generator/generator-docs.factor
+++ /dev/null
@@ -1,85 +0,0 @@
-USING: help.markup help.syntax words debugger
-compiler.generator.fixup compiler.generator.registers quotations
-kernel vectors arrays effects sequences ;
-IN: compiler.generator
-
-ARTICLE: "generator" "Compiled code generator"
-"Most of the words in the " { $vocab-link "compiler.generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
-$nl
-"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
-{ $subsection compiled-stack-traces? }
-"Assembler intrinsics can be defined for low-level optimization:"
-{ $subsection define-intrinsic }
-{ $subsection define-intrinsics }
-{ $subsection define-if-intrinsic }
-{ $subsection define-if-intrinsics }
-"The main entry point into the code generator:"
-{ $subsection generate } ;
-
-ABOUT: "generator"
-
-HELP: compiled
-{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
-
-HELP: compiling-word
-{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
-
-HELP: compiling-label
-{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
-
-HELP: compiled-stack-traces?
-{ $values { "?" "a boolean" } }
-{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
-
-HELP: begin-compiling
-{ $values { "word" word } { "label" word } }
-{ $description "Prepares to generate machine code for a word." } ;
-
-HELP: with-generator
-{ $values { "nodes" "a sequence of nodes" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
-{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the sequence of nodes." } ;
-
-HELP: generate-node
-{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
-{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
-
-HELP: generate-nodes
-{ $values { "nodes" "a sequence of nodes" } } 
-{ $description "Recursively generate machine code for a dataflow graph." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
-
-HELP: generate
-{ $values { "word" word } { "label" word } { "nodes" "a sequence of nodes" } }
-{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "nodes" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
-
-HELP: define-intrinsics
-{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
-{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
-$nl
-"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
-
-HELP: define-intrinsic
-{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
-{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
-$nl
-"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
-
-HELP: if>boolean-intrinsic
-{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
-{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
-
-HELP: define-if-intrinsics
-{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
-{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
-$nl
-"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
-$nl
-"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
-{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
-
-HELP: define-if-intrinsic
-{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
-{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
-$nl
-"See " { $link define-if-intrinsics } " for a description of the parameters." } ;
diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor
deleted file mode 100644
index 22de9d3587..0000000000
--- a/basis/compiler/generator/generator.factor
+++ /dev/null
@@ -1,581 +0,0 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes combinators
-cpu.architecture effects generic hashtables io kernel
-kernel.private layouts math math.parser namespaces make
-prettyprint quotations sequences system threads words vectors
-sets deques continuations.private summary alien alien.c-types
-alien.structs alien.strings alien.arrays libc compiler.errors
-stack-checker.inlining compiler.tree compiler.tree.builder
-compiler.tree.combinators compiler.tree.propagation.info
-compiler.generator.fixup compiler.generator.registers
-compiler.generator.iterator ;
-IN: compiler.generator
-
-SYMBOL: compile-queue
-SYMBOL: compiled
-
-: queue-compile ( word -- )
-    {
-        { [ dup "forgotten" word-prop ] [ ] }
-        { [ dup compiled get key? ] [ ] }
-        { [ dup inlined-block? ] [ ] }
-        { [ dup primitive? ] [ ] }
-        [ dup compile-queue get push-front ]
-    } cond drop ;
-
-: maybe-compile ( word -- )
-    dup compiled>> [ drop ] [ queue-compile ] if ;
-
-SYMBOL: compiling-word
-
-SYMBOL: compiling-label
-
-SYMBOL: compiling-loops
-
-! Label of current word, after prologue, makes recursion faster
-SYMBOL: current-label-start
-
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
-
-: begin-compiling ( word label -- )
-    H{ } clone compiling-loops set
-    compiling-label set
-    compiling-word set
-    compiled-stack-traces?
-    compiling-word get f ?
-    1vector literal-table set
-    f compiling-label get compiled get set-at ;
-
-: save-machine-code ( literals relocation labels code -- )
-    4array compiling-label get compiled get set-at ;
-
-: with-generator ( nodes word label quot -- )
-    [
-        >r begin-compiling r>
-        { } make fixup
-        save-machine-code
-    ] with-scope ; inline
-
-GENERIC: generate-node ( node -- next )
-
-: generate-nodes ( nodes -- )
-    [ current-node generate-node ] iterate-nodes
-    end-basic-block ;
-
-: init-generate-nodes ( -- )
-    init-templates
-    %save-word-xt
-    %prologue-later
-    current-label-start define-label
-    current-label-start resolve-label ;
-
-: generate ( nodes word label -- )
-    [
-        init-generate-nodes
-        [ generate-nodes ] with-node-iterator
-    ] with-generator ;
-
-: intrinsics ( #call -- quot )
-    word>> "intrinsics" word-prop ;
-
-: if-intrinsics ( #call -- quot )
-    word>> "if-intrinsics" word-prop ;
-
-! node
-M: node generate-node drop iterate-next ;
-
-: %jump ( word -- )
-    dup compiling-label get eq?
-    [ drop current-label-start get ] [ %epilogue-later ] if
-    %jump-label ;
-
-: generate-call ( label -- next )
-    dup maybe-compile
-    end-basic-block
-    dup compiling-loops get at [
-        %jump-label f
-    ] [
-        tail-call? [
-            %jump f
-        ] [
-            0 frame-required
-            %call
-            iterate-next
-        ] if
-    ] ?if ;
-
-! #recursive
-: compile-recursive ( node -- next )
-    dup label>> id>> generate-call >r
-    [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
-    r> ;
-
-: compiling-loop ( word -- )
-    <label> dup resolve-label swap compiling-loops get set-at ;
-
-: compile-loop ( node -- next )
-    end-basic-block
-    [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
-    iterate-next ;
-
-M: #recursive generate-node
-    dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
-
-! #if
-: end-false-branch ( label -- )
-    tail-call? [ %return drop ] [ %jump-label ] if ;
-
-: generate-branch ( nodes -- )
-    [ copy-templates generate-nodes ] with-scope ;
-
-: generate-if ( node label -- next )
-    <label> [
-        >r >r children>> first2 swap generate-branch
-        r> r> end-false-branch resolve-label
-        generate-branch
-        init-templates
-    ] keep resolve-label iterate-next ;
-
-M: #if generate-node
-    [ <label> dup %jump-f ]
-    H{ { +input+ { { f "flag" } } } }
-    with-template
-    generate-if ;
-
-! #dispatch
-: dispatch-branch ( nodes word -- label )
-    gensym [
-        [
-            copy-templates
-            %save-dispatch-xt
-            %prologue-later
-            [ generate-nodes ] with-node-iterator
-            %return
-        ] with-generator
-    ] keep ;
-
-: dispatch-branches ( node -- )
-    children>> [
-        compiling-word get dispatch-branch
-        %dispatch-label
-    ] each ;
-
-: generate-dispatch ( node -- )
-    %dispatch dispatch-branches init-templates ;
-
-M: #dispatch generate-node
-    #! The order here is important, dispatch-branches must
-    #! run after %dispatch, so that each branch gets the
-    #! correct register state
-    tail-call? [
-        generate-dispatch iterate-next
-    ] [
-        compiling-word get gensym [
-            [
-                init-generate-nodes
-                generate-dispatch
-            ] with-generator
-        ] keep generate-call
-    ] if ;
-
-! #call
-: define-intrinsics ( word intrinsics -- )
-    "intrinsics" set-word-prop ;
-
-: define-intrinsic ( word quot assoc -- )
-    2array 1array define-intrinsics ;
-
-: define-if>branch-intrinsics ( word intrinsics -- )
-    "if-intrinsics" set-word-prop ;
-
-: if>boolean-intrinsic ( quot -- )
-    "false" define-label
-    "end" define-label
-    "false" get swap call
-    t "if-scratch" get load-literal
-    "end" get %jump-label
-    "false" resolve-label
-    f "if-scratch" get load-literal
-    "end" resolve-label
-    "if-scratch" get phantom-push ; inline
-
-: define-if>boolean-intrinsics ( word intrinsics -- )
-    [
-        >r [ if>boolean-intrinsic ] curry r>
-        { { f "if-scratch" } } +scratch+ associate assoc-union
-    ] assoc-map "intrinsics" set-word-prop ;
-
-: define-if-intrinsics ( word intrinsics -- )
-    [ +input+ associate ] assoc-map
-    2dup define-if>branch-intrinsics
-    define-if>boolean-intrinsics ;
-
-: define-if-intrinsic ( word quot inputs -- )
-    2array 1array define-if-intrinsics ;
-
-: do-if-intrinsic ( pair -- next )
-    <label> [ swap do-template skip-next ] keep generate-if ;
-
-: find-intrinsic ( #call -- pair/f )
-    intrinsics find-template ;
-
-: find-if-intrinsic ( #call -- pair/f )
-    node@ {
-        { [ dup length 2 < ] [ 2drop f ] }
-        { [ dup second #if? ] [ drop if-intrinsics find-template ] }
-        [ 2drop f ]
-    } cond ;
-
-M: #call generate-node
-    dup node-input-infos [ class>> ] map set-operand-classes
-    dup find-if-intrinsic [
-        do-if-intrinsic
-    ] [
-        dup find-intrinsic [
-            do-template iterate-next
-        ] [
-            word>> generate-call
-        ] ?if
-    ] ?if ;
-
-! #call-recursive
-M: #call-recursive generate-node label>> id>> generate-call ;
-
-! #push
-M: #push generate-node
-    literal>> <constant> phantom-push iterate-next ;
-
-! #shuffle
-M: #shuffle generate-node
-    shuffle-effect phantom-shuffle iterate-next ;
-
-M: #>r generate-node
-    [ in-d>> length ] [ out-r>> empty? ] bi
-    [ phantom-drop ] [ phantom->r ] if
-    iterate-next ;
-
-M: #r> generate-node
-    [ in-r>> length ] [ out-d>> empty? ] bi
-    [ phantom-rdrop ] [ phantom-r> ] if
-    iterate-next ;
-
-! #return
-M: #return generate-node
-    drop end-basic-block %return f ;
-
-M: #return-recursive generate-node
-    end-basic-block
-    label>> id>> compiling-loops get key?
-    [ %return ] unless f ;
-
-! #alien-invoke
-: large-struct? ( ctype -- ? )
-    dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
-
-: alien-parameters ( params -- seq )
-    dup parameters>>
-    swap return>> large-struct? [ "void*" prefix ] when ;
-
-: alien-return ( params -- ctype )
-    return>> dup large-struct? [ drop "void" ] when ;
-
-: c-type-stack-align ( type -- align )
-    dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
-
-: parameter-align ( n type -- n delta )
-    over >r c-type-stack-align align dup r> - ;
-
-: parameter-sizes ( types -- total offsets )
-    #! Compute stack frame locations.
-    [
-        0 [
-            [ parameter-align drop dup , ] keep stack-size +
-        ] reduce cell align
-    ] { } make ;
-
-: return-size ( ctype -- n )
-    #! Amount of space we reserve for a return value.
-    dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
-
-: alien-stack-frame ( params -- n )
-    stack-frame new
-        swap
-        [ return>> return-size >>return ]
-        [ alien-parameters parameter-sizes drop >>params ] bi
-        dup [ params>> ] [ return>> ] bi + >>size
-        dup size>> stack-frame-size >>total-size ;
-
-: with-stack-frame ( params quot -- )
-    swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
-    call
-    stack-frame off ; inline
-
-GENERIC: reg-size ( register-class -- n )
-
-M: int-regs reg-size drop cell ;
-
-M: single-float-regs reg-size drop 4 ;
-
-M: double-float-regs reg-size drop 8 ;
-
-M: stack-params reg-size drop "void*" heap-size ;
-
-GENERIC: reg-class-variable ( register-class -- symbol )
-
-M: reg-class reg-class-variable ;
-
-M: float-regs reg-class-variable drop float-regs ;
-
-M: stack-params reg-class-variable drop stack-params ;
-
-GENERIC: inc-reg-class ( register-class -- )
-
-M: reg-class inc-reg-class
-    dup reg-class-variable inc
-    fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
-
-M: float-regs inc-reg-class
-    dup call-next-method
-    fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
-
-: reg-class-full? ( class -- ? )
-    [ reg-class-variable get ] [ param-regs length ] bi >= ;
-
-: spill-param ( reg-class -- n reg-class )
-    stack-params get
-    >r reg-size stack-params +@ r>
-    stack-params ;
-
-: fastcall-param ( reg-class -- n reg-class )
-    [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
-
-: alloc-parameter ( parameter -- reg reg-class )
-    c-type-reg-class dup reg-class-full?
-    [ spill-param ] [ fastcall-param ] if
-    [ param-reg ] keep ;
-
-: (flatten-int-type) ( size -- types )
-    cell /i "void*" c-type <repetition> ;
-
-GENERIC: flatten-value-type ( type -- types )
-
-M: object flatten-value-type 1array ;
-
-M: struct-type flatten-value-type ( type -- types )
-    stack-size cell align (flatten-int-type) ;
-
-M: long-long-type flatten-value-type ( type -- types )
-    stack-size cell align (flatten-int-type) ;
-
-: flatten-value-types ( params -- params )
-    #! Convert value type structs to consecutive void*s.
-    [
-        0 [
-            c-type
-            [ parameter-align (flatten-int-type) % ] keep
-            [ stack-size cell align + ] keep
-            flatten-value-type %
-        ] reduce drop
-    ] { } make ;
-
-: each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2each ; inline
-
-: reverse-each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
-
-: reset-freg-counts ( -- )
-    { int-regs float-regs stack-params } [ 0 swap set ] each ;
-
-: with-param-regs ( quot -- )
-    #! In quot you can call alloc-parameter
-    [ reset-freg-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).
-    >r
-    alien-parameters
-    flatten-value-types
-    r> [ >r alloc-parameter r> execute ] curry each-parameter ;
-    inline
-
-: unbox-parameters ( offset node -- )
-    parameters>> [
-        %prepare-unbox >r over + r> unbox-parameter
-    ] reverse-each-parameter drop ;
-
-: 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 register 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 ] if-void ;
-
-TUPLE: no-such-library name ;
-
-M: no-such-library summary
-    drop "Library not found" ;
-
-M: no-such-library compiler-error-type
-    drop +linkage+ ;
-
-: no-such-library ( name -- )
-    \ no-such-library boa
-    compiling-word get compiler-error ;
-
-TUPLE: no-such-symbol name ;
-
-M: no-such-symbol summary
-    drop "Symbol not found" ;
-
-M: no-such-symbol compiler-error-type
-    drop +linkage+ ;
-
-: no-such-symbol ( name -- )
-    \ no-such-symbol boa
-    compiling-word get compiler-error ;
-
-: check-dlsym ( symbols dll -- )
-    dup dll-valid? [
-        dupd [ dlsym ] curry contains?
-        [ drop ] [ no-such-symbol ] if
-    ] [
-        dll-path no-such-library drop
-    ] if ;
-
-: stdcall-mangle ( symbol node -- symbol )
-    "@"
-    swap parameters>> parameter-sizes drop
-    number>string 3append ;
-
-: alien-invoke-dlsym ( params -- symbols dll )
-    dup function>> dup pick stdcall-mangle 2array
-    swap library>> library dup [ dll>> ] when
-    2dup check-dlsym ;
-
-M: #alien-invoke generate-node
-    params>>
-    dup [
-        end-basic-block
-        %prepare-alien-invoke
-        dup objects>registers
-        %prepare-var-args
-        dup alien-invoke-dlsym %alien-invoke
-        dup %cleanup
-        box-return*
-        iterate-next
-    ] with-stack-frame ;
-
-! #alien-indirect
-M: #alien-indirect generate-node
-    params>>
-    dup [
-        ! Flush registers
-        end-basic-block
-        ! Save registers for GC
-        %prepare-alien-invoke
-        ! Save alien at top of stack to temporary storage
-        %prepare-alien-indirect
-        dup objects>registers
-        %prepare-var-args
-        ! Call alien in temporary storage
-        %alien-indirect
-        dup %cleanup
-        box-return*
-        iterate-next
-    ] with-stack-frame ;
-
-! #alien-callback
-: box-parameters ( params -- )
-    alien-parameters [ box-parameter ] each-parameter ;
-
-: registers>objects ( node -- )
-    [
-        dup \ %save-param-reg move-parameters
-        "nest_stacks" f %alien-invoke
-        box-parameters
-    ] with-param-regs ;
-
-TUPLE: callback-context ;
-
-: current-callback 2 getenv ;
-
-: wait-to-return ( token -- )
-    dup current-callback eq? [
-        drop
-    ] [
-        yield wait-to-return
-    ] if ;
-
-: do-callback ( quot token -- )
-    init-catchstack
-    dup 2 setenv
-    slip
-    wait-to-return ; inline
-
-: callback-return-quot ( ctype -- quot )
-    return>> {
-        { [ dup "void" = ] [ drop [ ] ] }
-        { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
-        [ 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 ,
-        [ callback-context new do-callback ] %
-    ] [ ] make ;
-
-: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
-
-: callback-unwind ( params -- n )
-    {
-        { [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] }
-        { [ dup return>> large-struct? ] [ drop 4 ] }
-        [ drop 0 ]
-    } cond ;
-
-: %callback-return ( params -- )
-    #! All the extra book-keeping for %unwind is only for x86.
-    #! On other platforms its an alias for %return.
-    dup alien-return
-    [ %unnest-stacks ] [ %callback-value ] if-void
-    callback-unwind %unwind ;
-
-: generate-callback ( params -- )
-    dup xt>> dup [
-        init-templates
-        %prologue-later
-        dup [
-            [ registers>objects ]
-            [ wrap-callback-quot %alien-callback ]
-            [ %callback-return ]
-            tri
-        ] with-stack-frame
-    ] with-generator ;
-
-M: #alien-callback generate-node
-    end-basic-block
-    params>> generate-callback iterate-next ;
diff --git a/basis/compiler/generator/iterator/iterator.factor b/basis/compiler/generator/iterator/iterator.factor
deleted file mode 100644
index 203216b1c0..0000000000
--- a/basis/compiler/generator/iterator/iterator.factor
+++ /dev/null
@@ -1,45 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences kernel compiler.tree ;
-IN: compiler.generator.iterator
-
-SYMBOL: node-stack
-
-: >node ( cursor -- ) node-stack get push ;
-: node> ( -- cursor ) node-stack get pop ;
-: node@ ( -- cursor ) node-stack get peek ;
-: current-node ( -- node ) node@ first ;
-: iterate-next ( -- cursor ) node@ rest-slice ;
-: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
-
-: iterate-nodes ( cursor quot: ( -- ) -- )
-    over empty? [
-        2drop
-    ] [
-        [ swap >node call node> drop ] keep iterate-nodes
-    ] if ; inline recursive
-
-: with-node-iterator ( quot -- )
-    >r V{ } clone node-stack r> with-variable ; inline
-
-DEFER: (tail-call?)
-
-: tail-phi? ( cursor -- ? )
-    [ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
-
-: (tail-call?) ( cursor -- ? )
-    [ t ] [
-        [ first [ #return? ] [ #terminate? ] bi or ]
-        [ tail-phi? ]
-        bi or
-    ] if-empty ;
-
-: tail-call? ( -- ? )
-    node-stack get [
-        rest-slice
-        [ t ] [
-            [ (tail-call?) ]
-            [ first #terminate? not ]
-            bi and
-        ] if-empty
-    ] all? ;
diff --git a/basis/compiler/generator/registers/authors.txt b/basis/compiler/generator/registers/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/basis/compiler/generator/registers/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor
deleted file mode 100644
index 6fdb8d9886..0000000000
--- a/basis/compiler/generator/registers/registers.factor
+++ /dev/null
@@ -1,672 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes classes.private classes.algebra
-combinators hashtables kernel layouts math namespaces make
-quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order cpu.architecture
-compiler.generator.fixup ;
-IN: compiler.generator.registers
-
-SYMBOL: +input+
-SYMBOL: +output+
-SYMBOL: +scratch+
-SYMBOL: +clobber+
-SYMBOL: known-tag
-
-<PRIVATE
-
-! Value protocol
-GENERIC: set-operand-class ( class obj -- )
-GENERIC: operand-class* ( operand -- class )
-GENERIC: move-spec ( obj -- spec )
-GENERIC: live-vregs* ( obj -- )
-GENERIC: live-loc? ( actual current -- ? )
-GENERIC# (lazy-load) 1 ( value spec -- value )
-GENERIC: lazy-store ( dst src -- )
-GENERIC: minimal-ds-loc* ( min obj -- min )
-
-! This will be a multimethod soon
-DEFER: %move
-
-MIXIN: value
-
-PRIVATE>
-
-: operand-class ( operand -- class )
-    operand-class* object or ;
-
-! Default implementation
-M: value set-operand-class 2drop ;
-M: value operand-class* drop f ;
-M: value live-vregs* drop ;
-M: value live-loc? 2drop f ;
-M: value minimal-ds-loc* drop ;
-M: value lazy-store 2drop ;
-
-! A scratch register for computations
-TUPLE: vreg n reg-class ;
-
-C: <vreg> vreg ( n reg-class -- vreg )
-
-M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
-M: vreg live-vregs* , ;
-
-M: vreg move-spec
-    reg-class>> {
-        { [ dup int-regs? ] [ f ] }
-        { [ dup float-regs? ] [ float ] }
-    } cond nip ;
-
-M: vreg operand-class*
-    reg-class>> {
-        { [ dup int-regs? ] [ f ] }
-        { [ dup float-regs? ] [ float ] }
-    } cond nip ;
-
-INSTANCE: vreg value
-
-! Temporary register for stack shuffling
-SINGLETON: temp-reg
-
-M: temp-reg move-spec drop f ;
-
-INSTANCE: temp-reg value
-
-! A data stack location.
-TUPLE: ds-loc n class ;
-
-: <ds-loc> ( n -- loc ) f ds-loc boa ;
-
-M: ds-loc minimal-ds-loc* n>> min ;
-M: ds-loc live-loc?
-    over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-! A retain stack location.
-TUPLE: rs-loc n class ;
-
-: <rs-loc> ( n -- loc ) f rs-loc boa ;
-M: rs-loc live-loc?
-    over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-UNION: loc ds-loc rs-loc ;
-
-M: loc operand-class* class>> ;
-M: loc set-operand-class (>>class) ;
-M: loc move-spec drop loc ;
-
-INSTANCE: loc value
-
-M: f move-spec drop loc ;
-M: f operand-class* ;
-
-! A stack location which has been loaded into a register. To
-! read the location, we just read the register, but when time
-! comes to save it back to the stack, we know the register just
-! contains a stack value so we don't have to redundantly write
-! it back.
-TUPLE: cached loc vreg ;
-
-C: <cached> cached
-
-M: cached set-operand-class vreg>> set-operand-class ;
-M: cached operand-class* vreg>> operand-class* ;
-M: cached move-spec drop cached ;
-M: cached live-vregs* vreg>> live-vregs* ;
-M: cached live-loc? loc>> live-loc? ;
-M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
-M: cached lazy-store
-    2dup loc>> live-loc?
-    [ "live-locs" get at %move ] [ 2drop ] if ;
-M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
-
-INSTANCE: cached value
-
-! A tagged pointer
-TUPLE: tagged vreg class ;
-
-: <tagged> ( vreg -- tagged )
-    f tagged boa ;
-
-M: tagged v>operand vreg>> v>operand ;
-M: tagged set-operand-class (>>class) ;
-M: tagged operand-class* class>> ;
-M: tagged move-spec drop f ;
-M: tagged live-vregs* vreg>> , ;
-
-INSTANCE: tagged value
-
-! Unboxed alien pointers
-TUPLE: unboxed-alien vreg ;
-C: <unboxed-alien> unboxed-alien
-M: unboxed-alien v>operand vreg>> v>operand ;
-M: unboxed-alien operand-class* drop simple-alien ;
-M: unboxed-alien move-spec class ;
-M: unboxed-alien live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-alien value
-
-TUPLE: unboxed-byte-array vreg ;
-C: <unboxed-byte-array> unboxed-byte-array
-M: unboxed-byte-array v>operand vreg>> v>operand ;
-M: unboxed-byte-array operand-class* drop c-ptr ;
-M: unboxed-byte-array move-spec class ;
-M: unboxed-byte-array live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-byte-array value
-
-TUPLE: unboxed-f vreg ;
-C: <unboxed-f> unboxed-f
-M: unboxed-f v>operand vreg>> v>operand ;
-M: unboxed-f operand-class* drop \ f ;
-M: unboxed-f move-spec class ;
-M: unboxed-f live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-f value
-
-TUPLE: unboxed-c-ptr vreg ;
-C: <unboxed-c-ptr> unboxed-c-ptr
-M: unboxed-c-ptr v>operand vreg>> v>operand ;
-M: unboxed-c-ptr operand-class* drop c-ptr ;
-M: unboxed-c-ptr move-spec class ;
-M: unboxed-c-ptr live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-c-ptr value
-
-! A constant value
-TUPLE: constant value ;
-C: <constant> constant
-M: constant operand-class* value>> class ;
-M: constant move-spec class ;
-
-INSTANCE: constant value
-
-<PRIVATE
-
-! Moving values between locations and registers
-: %move-bug ( -- * ) "Bug in generator.registers" throw ;
-
-: %unbox-c-ptr ( dst src -- )
-    dup operand-class {
-        { [ dup \ f class<= ] [ drop %unbox-f ] }
-        { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
-        { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
-        [ drop %unbox-any-c-ptr ]
-    } cond ; inline
-
-: %move-via-temp ( dst src -- )
-    #! For many transfers, such as loc to unboxed-alien, we
-    #! don't have an intrinsic, so we transfer the source to
-    #! temp then temp to the destination.
-    temp-reg over %move
-    operand-class temp-reg
-    tagged new
-        swap >>vreg
-        swap >>class
-    %move ;
-
-: %move ( dst src -- )
-    2dup [ move-spec ] bi@ 2array {
-        { { f f } [ %move-bug ] }
-        { { f unboxed-c-ptr } [ %move-bug ] }
-        { { f unboxed-byte-array } [ %move-bug ] }
-
-        { { f constant } [ value>> swap load-literal ] }
-
-        { { f float } [ %box-float ] }
-        { { f unboxed-alien } [ %box-alien ] }
-        { { f loc } [ %peek ] }
-
-        { { float f } [ %unbox-float ] }
-        { { unboxed-alien f } [ %unbox-alien ] }
-        { { unboxed-byte-array f } [ %unbox-byte-array ] }
-        { { unboxed-f f } [ %unbox-f ] }
-        { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
-        { { loc f } [ swap %replace ] }
-
-        [ drop %move-via-temp ]
-    } case ;
-
-! A compile-time stack
-TUPLE: phantom-stack height stack ;
-
-M: phantom-stack clone
-    call-next-method [ clone ] change-stack ;
-
-GENERIC: finalize-height ( stack -- )
-
-: new-phantom-stack ( class -- stack )
-    >r 0 V{ } clone r> boa ; inline
-
-: (loc) ( m stack -- n )
-    #! Utility for methods on <loc>
-    height>> - ;
-
-: (finalize-height) ( stack word -- )
-    #! We consolidate multiple stack height changes until the
-    #! last moment, and we emit the final height changing
-    #! instruction here.
-    [
-        over zero? [ 2drop ] [ execute ] if 0
-    ] curry change-height drop ; inline
-
-GENERIC: <loc> ( n stack -- loc )
-
-TUPLE: phantom-datastack < phantom-stack ;
-
-: <phantom-datastack> ( -- stack )
-    phantom-datastack new-phantom-stack ;
-
-M: phantom-datastack <loc> (loc) <ds-loc> ;
-
-M: phantom-datastack finalize-height
-    \ %inc-d (finalize-height) ;
-
-TUPLE: phantom-retainstack < phantom-stack ;
-
-: <phantom-retainstack> ( -- stack )
-    phantom-retainstack new-phantom-stack ;
-
-M: phantom-retainstack <loc> (loc) <rs-loc> ;
-
-M: phantom-retainstack finalize-height
-    \ %inc-r (finalize-height) ;
-
-: phantom-locs ( n phantom -- locs )
-    #! A sequence of n ds-locs or rs-locs indexing the stack.
-    >r <reversed> r> [ <loc> ] curry map ;
-
-: phantom-locs* ( phantom -- locs )
-    [ stack>> length ] keep phantom-locs ;
-
-: phantoms ( -- phantom phantom )
-    phantom-datastack get phantom-retainstack get ;
-
-: (each-loc) ( phantom quot -- )
-    >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
-
-: each-loc ( quot -- )
-    phantoms 2array swap [ (each-loc) ] curry each ; inline
-
-: adjust-phantom ( n phantom -- )
-    swap [ + ] curry change-height drop ;
-
-: cut-phantom ( n phantom -- seq )
-    swap [ cut* swap ] curry change-stack drop ;
-
-: phantom-append ( seq stack -- )
-    over length over adjust-phantom stack>> push-all ;
-
-: add-locs ( n phantom -- )
-    2dup stack>> length <= [
-        2drop
-    ] [
-        [ phantom-locs ] keep
-        [ stack>> length head-slice* ] keep
-        [ append >vector ] change-stack drop
-    ] if ;
-
-: phantom-input ( n phantom -- seq )
-    2dup add-locs
-    2dup cut-phantom
-    >r >r neg r> adjust-phantom r> ;
-
-: each-phantom ( quot -- ) phantoms rot bi@ ; inline
-
-: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
-
-: live-vregs ( -- seq )
-    [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
-
-: (live-locs) ( phantom -- seq )
-    #! Discard locs which haven't moved
-    [ phantom-locs* ] [ stack>> ] bi zip
-    [ live-loc? ] assoc-filter
-    values ;
-
-: live-locs ( -- seq )
-    [ (live-locs) ] each-phantom append prune ;
-
-! Operands holding pointers to freshly-allocated objects which
-! are guaranteed to be in the nursery
-SYMBOL: fresh-objects
-
-! Computing free registers and initializing allocator
-: reg-spec>class ( spec -- class )
-    float eq? double-float-regs int-regs ? ;
-
-: free-vregs ( reg-class -- seq )
-    #! Free vregs in a given register class
-    \ free-vregs get at ;
-
-: alloc-vreg ( spec -- reg )
-    [ reg-spec>class free-vregs pop ] keep {
-        { f [ <tagged> ] }
-        { unboxed-alien [ <unboxed-alien> ] }
-        { unboxed-byte-array [ <unboxed-byte-array> ] }
-        { unboxed-f [ <unboxed-f> ] }
-        { unboxed-c-ptr [ <unboxed-c-ptr> ] }
-        [ drop ]
-    } case ;
-
-: compatible? ( value spec -- ? )
-    >r move-spec r> {
-        { [ 2dup = ] [ t ] }
-        { [ dup unboxed-c-ptr eq? ] [
-            over { unboxed-byte-array unboxed-alien } member?
-        ] }
-        [ f ]
-    } cond 2nip ;
-
-: allocation ( value spec -- reg-class )
-    {
-        { [ dup quotation? ] [ 2drop f ] }
-        { [ 2dup compatible? ] [ 2drop f ] }
-        [ nip reg-spec>class ]
-    } cond ;
-
-: alloc-vreg-for ( value spec -- vreg )
-    alloc-vreg swap operand-class
-    over tagged? [ >>class ] [ drop ] if ;
-
-M: value (lazy-load)
-    2dup allocation [
-        dupd alloc-vreg-for dup rot %move
-    ] [
-        drop
-    ] if ;
-
-: (compute-free-vregs) ( used class -- vector )
-    #! Find all vregs in 'class' which are not in 'used'.
-    [ vregs length reverse ] keep
-    [ <vreg> ] curry map swap diff
-    >vector ;
-
-: compute-free-vregs ( -- )
-    #! Create a new hashtable for thee free-vregs variable.
-    live-vregs
-    { int-regs double-float-regs }
-    [ 2dup (compute-free-vregs) ] H{ } map>assoc
-    \ free-vregs set
-    drop ;
-
-M: loc lazy-store
-    2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
-
-: do-shuffle ( hash -- )
-    dup assoc-empty? [
-        drop
-    ] [
-        "live-locs" set
-        [ lazy-store ] each-loc
-    ] if ;
-
-: fast-shuffle ( locs -- )
-    #! We have enough free registers to load all shuffle inputs
-    #! at once
-    [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
-
-: minimal-ds-loc ( phantom -- n )
-    #! When shuffling more values than can fit in registers, we
-    #! need to find an area on the data stack which isn't in
-    #! use.
-    [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
-
-: find-tmp-loc ( -- n )
-    #! Find an area of the data stack which is not referenced
-    #! from the phantom stacks. We can clobber there all we want
-    [ minimal-ds-loc ] each-phantom min 1- ;
-
-: slow-shuffle-mapping ( locs tmp -- pairs )
-    >r dup length r>
-    [ swap - <ds-loc> ] curry map zip ;
-
-: slow-shuffle ( locs -- )
-    #! We don't have enough free registers to load all shuffle
-    #! inputs, so we use a single temporary register, together
-    #! with the area of the data stack above the stack pointer
-    find-tmp-loc slow-shuffle-mapping [
-        [
-            swap dup cached? [ vreg>> ] when %move
-        ] assoc-each
-    ] keep >hashtable do-shuffle ;
-
-: fast-shuffle? ( live-locs -- ? )
-    #! Test if we have enough free registers to load all
-    #! shuffle inputs at once.
-    int-regs free-vregs [ length ] bi@ <= ;
-
-: finalize-locs ( -- )
-    #! Perform any deferred stack shuffling.
-    [
-        \ free-vregs [ [ clone ] assoc-map ] change
-        live-locs dup fast-shuffle?
-        [ fast-shuffle ] [ slow-shuffle ] if
-    ] with-scope ;
-
-: finalize-vregs ( -- )
-    #! Store any vregs to their final stack locations.
-    [
-        dup loc? over cached? or [ 2drop ] [ %move ] if
-    ] each-loc ;
-
-: reset-phantom ( phantom -- )
-    #! Kill register assignments but preserve constants and
-    #! class information.
-    dup phantom-locs*
-    over stack>> [
-        dup constant? [ nip ] [
-            operand-class over set-operand-class
-        ] if
-    ] 2map
-    over stack>> delete-all
-    swap stack>> push-all ;
-
-: reset-phantoms ( -- )
-    [ reset-phantom ] each-phantom ;
-
-: finalize-contents ( -- )
-    finalize-locs finalize-vregs reset-phantoms ;
-
-! Loading stacks to vregs
-: free-vregs? ( int# float# -- ? )
-    double-float-regs free-vregs length <=
-    >r int-regs free-vregs length <= r> and ;
-
-: phantom&spec ( phantom spec -- phantom' spec' )
-    >r stack>> r>
-    [ length f pad-left ] keep
-    [ <reversed> ] bi@ ; inline
-
-: phantom&spec-agree? ( phantom spec quot -- ? )
-    >r phantom&spec r> 2all? ; inline
-
-: vreg-substitution ( value vreg -- pair )
-    dupd <cached> 2array ;
-
-: substitute-vreg? ( old new -- ? )
-    #! We don't substitute locs for float or alien vregs,
-    #! since in those cases the boxing overhead might kill us.
-    vreg>> tagged? >r loc? r> and ;
-
-: substitute-vregs ( values vregs -- )
-    [ vreg-substitution ] 2map
-    [ substitute-vreg? ] assoc-filter >hashtable
-    [ >r stack>> r> substitute-here ] curry each-phantom ;
-
-: set-operand ( value var -- )
-    >r dup constant? [ value>> ] when r> set ;
-
-: lazy-load ( values template -- )
-    #! Set operand vars here.
-    2dup [ first (lazy-load) ] 2map
-    dup rot [ second set-operand ] 2each
-    substitute-vregs ;
-
-: load-inputs ( -- )
-    +input+ get
-    [ length phantom-datastack get phantom-input ] keep
-    lazy-load ;
-
-: output-vregs ( -- seq seq )
-    +output+ +clobber+ [ get [ get ] map ] bi@ ;
-
-: clash? ( seq -- ? )
-    phantoms [ stack>> ] bi@ append [
-        dup cached? [ vreg>> ] when swap member?
-    ] with contains? ;
-
-: outputs-clash? ( -- ? )
-    output-vregs append clash? ;
-
-: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
-
-: count-input-vregs ( phantom spec -- )
-    phantom&spec [
-        >r dup cached? [ vreg>> ] when r> first allocation
-    ] 2map count-vregs ;
-
-: count-scratch-regs ( spec -- )
-    [ first reg-spec>class ] map count-vregs ;
-
-: guess-vregs ( dinput rinput scratch -- int# float# )
-    [
-        0 int-regs set
-        0 double-float-regs set
-        count-scratch-regs
-        phantom-retainstack get swap count-input-vregs
-        phantom-datastack get swap count-input-vregs
-        int-regs get double-float-regs get
-    ] with-scope ;
-
-: alloc-scratch ( -- )
-    +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
-
-: guess-template-vregs ( -- int# float# )
-    +input+ get { } +scratch+ get guess-vregs ;
-
-: template-inputs ( -- )
-    ! Load input values into registers
-    load-inputs
-    ! Allocate scratch registers
-    alloc-scratch
-    ! If outputs clash, we write values back to the stack
-    outputs-clash? [ finalize-contents ] when ;
-
-: template-outputs ( -- )
-    +output+ get [ get ] map phantom-datastack get phantom-append ;
-
-: value-matches? ( value spec -- ? )
-    #! If the spec is a quotation and the value is a literal
-    #! fixnum, see if the quotation yields true when applied
-    #! to the fixnum. Otherwise, the values don't match. If the
-    #! spec is not a quotation, its a reg-class, in which case
-    #! the value is always good.
-    dup quotation? [
-        over constant?
-        [ >r value>> r> call ] [ 2drop f ] if
-    ] [
-        2drop t
-    ] if ;
-
-: class-matches? ( actual expected -- ? )
-    {
-        { f [ drop t ] }
-        { known-tag [ dup [ class-tag >boolean ] when ] }
-        [ class<= ]
-    } case ;
-
-: spec-matches? ( value spec -- ? )
-    2dup first value-matches?
-    >r >r operand-class 2 r> ?nth class-matches? r> and ;
-
-: template-matches? ( spec -- ? )
-    phantom-datastack get +input+ rot at
-    [ spec-matches? ] phantom&spec-agree? ;
-
-: ensure-template-vregs ( -- )
-    guess-template-vregs free-vregs? [
-        finalize-contents compute-free-vregs
-    ] unless ;
-
-: clear-phantoms ( -- )
-    [ stack>> delete-all ] each-phantom ;
-
-PRIVATE>
-
-: set-operand-classes ( classes -- )
-    phantom-datastack get
-    over length over add-locs
-    stack>> [ set-operand-class ] 2reverse-each ;
-
-: end-basic-block ( -- )
-    #! Commit all deferred stacking shuffling, and ensure the
-    #! in-memory data and retain stacks are up to date with
-    #! respect to the compiler's current picture.
-    finalize-contents
-    clear-phantoms
-    finalize-heights
-    fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
-
-: with-template ( quot hash -- )
-    clone [
-        ensure-template-vregs
-        template-inputs call template-outputs
-    ] bind
-    compute-free-vregs ; inline
-
-: do-template ( pair -- )
-    #! Use with return value from find-template
-    first2 with-template ;
-
-: fresh-object ( obj -- ) fresh-objects get push ;
-
-: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
-
-: init-templates ( -- )
-    #! Initialize register allocator.
-    V{ } clone fresh-objects set
-    <phantom-datastack> phantom-datastack set
-    <phantom-retainstack> phantom-retainstack set
-    compute-free-vregs ;
-
-: copy-templates ( -- )
-    #! Copies register allocator state, used when compiling
-    #! branches.
-    fresh-objects [ clone ] change
-    phantom-datastack [ clone ] change
-    phantom-retainstack [ clone ] change
-    compute-free-vregs ;
-
-: find-template ( templates -- pair/f )
-    #! Pair has shape { quot hash }
-    [ second template-matches? ] find nip ;
-
-: operand-tag ( operand -- tag/f )
-    operand-class dup [ class-tag ] when ;
-
-UNION: immediate fixnum POSTPONE: f ;
-
-: operand-immediate? ( operand -- ? )
-    operand-class immediate class<= ;
-
-: phantom-push ( obj -- )
-    1 phantom-datastack get adjust-phantom
-    phantom-datastack get stack>> push ;
-
-: phantom-shuffle ( shuffle -- )
-    [ in>> length phantom-datastack get phantom-input ] keep
-    shuffle phantom-datastack get phantom-append ;
-
-: phantom->r ( n -- )
-    phantom-datastack get phantom-input
-    phantom-retainstack get phantom-append ;
-
-: phantom-r> ( n -- )
-    phantom-retainstack get phantom-input
-    phantom-datastack get phantom-append ;
-
-: phantom-drop ( n -- )
-    phantom-datastack get phantom-input drop ;
-
-: phantom-rdrop ( n -- )
-    phantom-retainstack get phantom-input drop ;
diff --git a/basis/compiler/generator/registers/summary.txt b/basis/compiler/generator/registers/summary.txt
deleted file mode 100644
index 89a46afc03..0000000000
--- a/basis/compiler/generator/registers/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Register allocation and intrinsic selection
diff --git a/basis/compiler/generator/summary.txt b/basis/compiler/generator/summary.txt
deleted file mode 100644
index cf857ad971..0000000000
--- a/basis/compiler/generator/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Final stage of compilation generates machine code from dataflow IR
diff --git a/basis/compiler/generator/tags.txt b/basis/compiler/generator/tags.txt
deleted file mode 100644
index 86a7c8e637..0000000000
--- a/basis/compiler/generator/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-compiler
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index f22d4a2a90..9e2b4def17 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -64,6 +64,9 @@ HOOK: %jump-label cpu ( label -- )
 ! Test if vreg is 'f' or not
 HOOK: %jump-f cpu ( label -- )
 
+! Test if vreg is 't' or not
+HOOK: %jump-t cpu ( label -- )
+
 HOOK: %dispatch cpu ( -- )
 
 HOOK: %dispatch-label cpu ( word -- )
@@ -83,6 +86,10 @@ HOOK: %peek cpu ( vreg loc -- )
 ! Store vreg to stack
 HOOK: %replace cpu ( vreg loc -- )
 
+! Copy values between vregs
+HOOK: %copy cpu ( dst src -- )
+HOOK: %copy-float cpu ( dst src -- )
+
 ! Box and unbox floats
 HOOK: %unbox-float cpu ( dst src -- )
 HOOK: %box-float cpu ( dst src -- )
@@ -193,6 +200,11 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 
 HOOK: %box-alien cpu ( dst src -- )
 
+! Allocation
+HOOK: %allot cpu ( dst size type tag temp -- )
+
+HOOK: %write-barrier cpu ( src temp -- )
+
 ! GC check
 HOOK: %gc cpu ( -- )
 
diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor
index 611531785e..d48153e1b6 100644
--- a/basis/cpu/x86/allot/allot.factor
+++ b/basis/cpu/x86/allot/allot.factor
@@ -3,7 +3,8 @@
 USING: kernel cpu.architecture cpu.x86.assembler
 cpu.x86.architecture kernel.private namespaces math sequences
 generic arrays compiler.generator compiler.generator.fixup
-compiler.generator.registers system layouts alien ;
+compiler.generator.registers system layouts alien locals
+compiler.constants ;
 IN: cpu.x86.allot
 
 : allot-reg ( -- reg )
@@ -117,3 +118,37 @@ M: x86 %box-alien ( dst src -- )
         f [ v>operand ] bi@ MOV
         "end" resolve-label
     ] with-scope ;
+
+M:: x86 %write-barrier ( src temp -- )
+    #! Mark the card pointed to by vreg.
+    ! Mark the card
+    src card-bits SHR
+    "cards_offset" f temp %alien-global
+    temp temp [+] card-mark <byte> MOV
+
+    ! Mark the card deck
+    temp deck-bits card-bits - SHR
+    "decks_offset" f temp %alien-global
+    temp temp [+] card-mark <byte> MOV ;
+
+! : load-zone-ptr ( reg -- )
+!     #! Load pointer to start of zone array
+!     0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+! 
+! : load-allot-ptr ( temp -- )
+!     [ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
+! 
+! : inc-allot-ptr ( n temp -- )
+!     [ POP ] [ cell [+] swap 8 align ADD ] bi ;
+! 
+! : store-header ( temp type -- )
+!     [ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
+! 
+! : store-tagged ( dst temp tag -- )
+!     dupd tag-number OR MOV ;
+! 
+! M:: x86 %allot ( dst size type tag temp -- )
+!     temp load-allot-ptr
+!     temp type store-header
+!     temp size inc-allot-ptr
+!     dst temp store-tagged ;
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 01256fb4c5..31ead4a005 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -92,6 +92,9 @@ M: x86 %jump-label ( label -- ) JMP ;
 M: x86 %jump-f ( label -- )
     "flag" operand f v>operand CMP JE ;
 
+M: x86 %jump-t ( label -- )
+    "flag" operand f v>operand CMP JNE ;
+
 : code-alignment ( -- n )
     building get length dup cell align swap - ;
 
@@ -130,6 +133,8 @@ M: x86 %peek [ v>operand ] bi@ MOV ;
 
 M: x86 %replace swap %peek ;
 
+M: x86 %copy [ v>operand ] bi@ MOV ;
+
 : (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
 M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
diff --git a/basis/cpu/x86/sse2/sse2.factor b/basis/cpu/x86/sse2/sse2.factor
index 59a9a83ab3..3e232b518d 100644
--- a/basis/cpu/x86/sse2/sse2.factor
+++ b/basis/cpu/x86/sse2/sse2.factor
@@ -4,9 +4,12 @@ USING: alien alien.accessors arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics generic kernel
 kernel.private math math.private memory namespaces sequences
 words compiler.generator compiler.generator.registers
-cpu.architecture math.floats.private layouts quotations ;
+cpu.architecture math.floats.private layouts quotations
+system ;
 IN: cpu.x86.sse2
 
+M: x86 %copy-float [ v>operand ] bi@ MOVSD ;
+
 : define-float-op ( word op -- )
     [ "x" operand "y" operand ] swap suffix H{
         { +input+ { { float "x" } { float "y" } } }
diff --git a/unfinished/compiler/cfg.bluesky/alias/alias.factor b/unfinished/compiler/cfg.bluesky/alias/alias.factor
deleted file mode 100644
index 0ed0b49cc0..0000000000
--- a/unfinished/compiler/cfg.bluesky/alias/alias.factor
+++ /dev/null
@@ -1,293 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs hashtables sequences
-accessors vectors combinators sets compiler.vops compiler.cfg ;
-IN: compiler.cfg.alias
-
-! Alias analysis -- must be run after compiler.cfg.stack.
-!
-! We try to eliminate redundant slot and stack
-! traffic using some simple heuristics.
-! 
-! All heap-allocated objects which are loaded from the stack, or
-! other object slots are pessimistically assumed to belong to
-! the same alias class.
-!
-! Freshly-allocated objects get their own alias class.
-!
-! The data and retain stack pointer registers are treated
-! uniformly, and each one gets its own alias class.
-! 
-! Simple pseudo-C example showing load elimination:
-! 
-! int *x, *y, z: inputs
-! int a, b, c, d, e: locals
-! 
-! Before alias analysis:
-!
-! a = x[2]
-! b = x[2]
-! c = x[3]
-! y[2] = z
-! d = x[2]
-! e = y[2]
-! f = x[3]
-!
-! After alias analysis:
-!
-! a = x[2]
-! b = a /* ELIMINATED */
-! c = x[3]
-! y[2] = z
-! d = x[2] /* if x=y, d=z, if x!=y, d=b; NOT ELIMINATED */
-! e = z /* ELIMINATED */
-! f = c /* ELIMINATED */
-!
-! Simple pseudo-C example showing store elimination:
-!
-! Before alias analysis:
-!
-! x[0] = a
-! b = x[n]
-! x[0] = c
-! x[1] = d
-! e = x[0]
-! x[1] = c
-!
-! After alias analysis:
-!
-! x[0] = a /* dead if n = 0, live otherwise; NOT ELIMINATED */
-! b = x[n]
-! x[0] = c
-! /* x[1] = d */  /* ELIMINATED */
-! e = c
-! x[1] = c
-
-! Map vregs -> alias classes
-SYMBOL: vregs>acs
-
-: check [ "BUG: static type error detected" throw ] unless* ; inline
- 
-: vreg>ac ( vreg -- ac )
-    #! Only vregs produced by %%allot, %peek and %%slot can
-    #! ever be used as valid inputs to %%slot and %%set-slot,
-    #! so we assert this fact by not giving alias classes to
-    #! other vregs.
-    vregs>acs get at check ;
-
-! Map alias classes -> sequence of vregs
-SYMBOL: acs>vregs
-
-: ac>vregs ( ac -- vregs ) acs>vregs get at ;
-
-: aliases ( vreg -- vregs )
-    #! All vregs which may contain the same value as vreg.
-    vreg>ac ac>vregs ;
-
-: each-alias ( vreg quot -- )
-    [ aliases ] dip each ; inline
-
-! Map vregs -> slot# -> vreg
-SYMBOL: live-slots
-
-! Current instruction number
-SYMBOL: insn#
-
-! Load/store history, for dead store elimination
-TUPLE: load insn# ;
-TUPLE: store insn# ;
-
-: new-action ( class -- action )
-    insn# get swap boa ; inline
-
-! Maps vreg -> slot# -> sequence of loads/stores
-SYMBOL: histories
-
-: history ( vreg -- history ) histories get at ;
-
-: set-ac ( vreg ac -- )
-    #! Set alias class of newly-seen vreg.
-    {
-        [ drop H{ } clone swap histories get set-at ]
-        [ drop H{ } clone swap live-slots get set-at ]
-        [ swap vregs>acs get set-at ]
-        [ acs>vregs get push-at ]
-    } 2cleave ;
-
-: live-slot ( slot#/f vreg -- vreg' )
-    #! If the slot number is unknown, we never reuse a previous
-    #! value.
-    over [ live-slots get at at ] [ 2drop f ] if ;
-
-: load-constant-slot ( value slot# vreg -- )
-    live-slots get at check set-at ;
-
-: load-slot ( value slot#/f vreg -- )
-    over [ load-constant-slot ] [ 3drop ] if ;
-
-: record-constant-slot ( slot# vreg -- )
-    #! A load can potentially read every store of this slot#
-    #! in that alias class.
-    [
-        history [ load new-action swap ?push ] change-at
-    ] with each-alias ;
-
-: record-computed-slot ( vreg -- )
-    #! Computed load is like a load of every slot touched so far
-    [
-        history values [ load new-action swap push ] each
-    ] each-alias ;
-
-: remember-slot ( value slot#/f vreg -- )
-    over
-    [ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
-    [ 2nip record-computed-slot ] if ;
-
-SYMBOL: ac-counter
-
-: next-ac ( -- n )
-    ac-counter [ dup 1+ ] change ;
-
-! Alias class for objects which are loaded from the data stack
-! or other object slots. We pessimistically assume that they
-! can all alias each other.
-SYMBOL: heap-ac
-
-: set-heap-ac ( vreg -- ) heap-ac get set-ac ;
-
-: set-new-ac ( vreg -- ) next-ac set-ac ;
-
-: kill-constant-set-slot ( slot# vreg -- )
-    [ live-slots get at delete-at ] with each-alias ;
-
-: record-constant-set-slot ( slot# vreg -- )
-    history [
-        dup empty? [ dup peek store? [ dup pop* ] when ] unless
-        store new-action swap ?push
-    ] change-at ;
-
-: kill-computed-set-slot ( ac -- )
-    [ live-slots get at clear-assoc ] each-alias ;
-
-: remember-set-slot ( slot#/f vreg -- )
-    over [
-        [ record-constant-set-slot ]
-        [ kill-constant-set-slot ] 2bi
-    ] [ nip kill-computed-set-slot ] if ;
-
-SYMBOL: copies
-
-: resolve ( vreg -- vreg )
-    dup copies get at swap or ;
-
-SYMBOL: constants
-
-: constant ( vreg -- n/f )
-    #! Return an %iconst value, or f if the vreg was not
-    #! assigned by an %iconst.
-    resolve constants get at ;
-
-! We treat slot accessors and stack traffic alike
-GENERIC: insn-slot# ( insn -- slot#/f )
-GENERIC: insn-object ( insn -- vreg )
-
-M: %peek insn-slot# n>> ;
-M: %replace insn-slot# n>> ;
-M: %%slot insn-slot# slot>> constant ;
-M: %%set-slot insn-slot# slot>> constant ;
-
-M: %peek insn-object stack>> ;
-M: %replace insn-object stack>> ;
-M: %%slot insn-object obj>> resolve ;
-M: %%set-slot insn-object obj>> resolve ;
-
-: init-alias-analysis ( -- )
-    H{ } clone histories set
-    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
-    next-ac heap-ac set
-
-    %data next-ac set-ac
-    %retain next-ac set-ac ;
-
-GENERIC: analyze-aliases ( insn -- insn' )
-
-M: %iconst analyze-aliases
-    dup [ value>> ] [ out>> ] bi constants get set-at ;
-
-M: %%allot analyze-aliases
-    #! A freshly allocated object is distinct from any other
-    #! object.
-    dup out>> set-new-ac ;
-
-M: read-op analyze-aliases
-    dup out>> set-heap-ac
-    dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
-    2dup live-slot dup [
-        2nip %copy boa 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
-    #! from?
-    live-slot = ;
-
-M: write-op analyze-aliases
-    dup
-    [ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
-    3dup idempotent? [
-        2drop 2drop nop
-    ] [
-        [ remember-set-slot drop ] [ load-slot ] 3bi
-    ] if ;
-
-M: %copy analyze-aliases
-    #! The output vreg gets the same alias class as the input
-    #! vreg, since they both contain the same value.
-    dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
-
-M: vop analyze-aliases ;
-
-SYMBOL: live-stores
-
-: compute-live-stores ( -- )
-    histories get
-    values [
-        values [ [ store? ] filter [ insn#>> ] map ] map concat
-    ] map concat unique
-    live-stores set ;
-
-GENERIC: eliminate-dead-store ( insn -- insn' )
-
-: (eliminate-dead-store) ( insn -- insn' )
-    dup insn-slot# [
-        insn# get live-stores get key? [
-            drop nop
-        ] unless
-    ] when ;
-
-M: %replace eliminate-dead-store
-    #! Writes to above the top of the stack can be pruned also.
-    #! This is sound since any such writes are not observable
-    #! after the basic block, and any reads of those locations
-    #! will have been converted to copies by analyze-slot,
-    #! and the final stack height of the basic block is set at
-    #! the beginning by compiler.cfg.stack.
-    dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
-
-M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
-
-M: vop eliminate-dead-store ;
-
-: alias-analysis ( insns -- insns' )
-    init-alias-analysis
-    [ insn# set analyze-aliases ] map-index
-    compute-live-stores
-    [ insn# set eliminate-dead-store ] map-index ;
diff --git a/unfinished/compiler/cfg.bluesky/authors.txt b/unfinished/compiler/cfg.bluesky/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/unfinished/compiler/cfg.bluesky/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/unfinished/compiler/cfg.bluesky/builder/builder-tests.factor b/unfinished/compiler/cfg.bluesky/builder/builder-tests.factor
deleted file mode 100644
index 098919c868..0000000000
--- a/unfinished/compiler/cfg.bluesky/builder/builder-tests.factor
+++ /dev/null
@@ -1,4 +0,0 @@
-IN: compiler.cfg.builder.tests
-USING: compiler.cfg.builder tools.test ;
-
-\ build-cfg must-infer
diff --git a/unfinished/compiler/cfg.bluesky/builder/builder.factor b/unfinished/compiler/cfg.bluesky/builder/builder.factor
deleted file mode 100644
index 76a1b67dd2..0000000000
--- a/unfinished/compiler/cfg.bluesky/builder/builder.factor
+++ /dev/null
@@ -1,256 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel assocs sequences sequences.lib fry accessors
-namespaces math combinators math.order
-compiler.tree
-compiler.tree.combinators
-compiler.tree.propagation.info
-compiler.cfg
-compiler.vops
-compiler.vops.builder ;
-IN: compiler.cfg.builder
-
-! Convert tree SSA IR to CFG SSA IR.
-
-! We construct the graph and set successors first, then we
-! set predecessors in a separate pass. This simplifies the
-! logic.
-
-SYMBOL: procedures
-
-SYMBOL: loop-nesting
-
-SYMBOL: values>vregs
-
-GENERIC: convert ( node -- )
-
-M: #introduce convert drop ;
-
-: init-builder ( -- )
-    H{ } clone values>vregs set ;
-
-: end-basic-block ( -- )
-    basic-block get [ %b emit ] when ;
-
-: set-basic-block ( basic-block -- )
-    [ basic-block set ] [ instructions>> building set ] bi ;
-
-: begin-basic-block ( -- )
-    <basic-block> basic-block get
-    [
-        end-basic-block
-        dupd successors>> push
-    ] when*
-    set-basic-block ;
-
-: convert-nodes ( node -- )
-    [ convert ] each ;
-
-: (build-cfg) ( node word -- )
-    init-builder
-    begin-basic-block
-    basic-block get swap procedures get set-at
-    convert-nodes ;
-
-: build-cfg ( node word -- procedures )
-    H{ } clone [
-        procedures [ (build-cfg) ] with-variable
-    ] keep ;
-
-: value>vreg ( value -- vreg )
-    values>vregs get at ;
-
-: output-vreg ( value vreg -- )
-    swap values>vregs get set-at ;
-
-: produce-vreg ( value -- vreg )
-    next-vreg [ output-vreg ] keep ;
-
-: (load-inputs) ( seq stack -- )
-    over empty? [ 2drop ] [
-        [ <reversed> ] dip
-        [ '[ produce-vreg _ , %peek emit ] each-index ]
-        [ [ length neg ] dip %height emit ]
-        2bi
-    ] if ;
-
-: load-in-d ( node -- ) in-d>> %data (load-inputs) ;
-
-: load-in-r ( node -- ) in-r>> %retain (load-inputs) ;
-
-: (store-outputs) ( seq stack -- )
-    over empty? [ 2drop ] [
-        [ <reversed> ] dip
-        [ [ length ] dip %height emit ]
-        [ '[ value>vreg _ , %replace emit ] each-index ]
-        2bi
-    ] if ;
-
-: store-out-d ( node -- ) out-d>> %data (store-outputs) ;
-
-: store-out-r ( node -- ) out-r>> %retain (store-outputs) ;
-
-: (emit-call) ( word -- )
-    begin-basic-block %call emit begin-basic-block ;
-
-: intrinsic-inputs ( node -- )
-    [ load-in-d ]
-    [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ]
-    bi ;
-
-: intrinsic-outputs ( node -- )
-    [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ]
-    [ store-out-d ]
-    bi ;
-
-: intrinsic ( node quot -- )
-    [
-        init-intrinsic
-
-        [ intrinsic-inputs ]
-        swap
-        [ intrinsic-outputs ]
-        tri
-    ] with-scope ; inline
-
-USING: kernel.private math.private slots.private ;
-
-: maybe-emit-fixnum-shift-fast ( node -- node )
-    dup dup in-d>> second node-value-info literal>> dup fixnum? [
-        '[ , emit-fixnum-shift-fast ] intrinsic
-    ] [
-        drop dup word>> (emit-call)
-    ] if ;
-
-: emit-call ( node -- )
-    dup word>> {
-        { \ tag [ [ emit-tag ] intrinsic ] }
-
-        { \ slot [ [ dup emit-slot ] intrinsic ] }
-        { \ set-slot [ [ dup emit-set-slot ] intrinsic ] }
-
-        { \ fixnum-bitnot [ [ emit-fixnum-bitnot ] intrinsic ] }
-        { \ fixnum+fast [ [ emit-fixnum+fast ] intrinsic ] }
-        { \ fixnum-fast [ [ emit-fixnum-fast ] intrinsic ] }
-        { \ fixnum-bitand [ [ emit-fixnum-bitand ] intrinsic ] }
-        { \ fixnum-bitor [ [ emit-fixnum-bitor ] intrinsic ] }
-        { \ fixnum-bitxor [ [ emit-fixnum-bitxor ] intrinsic ] }
-        { \ fixnum*fast [ [ emit-fixnum*fast ] intrinsic ] }
-        { \ fixnum<= [ [ emit-fixnum<= ] intrinsic ] }
-        { \ fixnum>= [ [ emit-fixnum>= ] intrinsic ] }
-        { \ fixnum< [ [ emit-fixnum< ] intrinsic ] }
-        { \ fixnum> [ [ emit-fixnum> ] intrinsic ] }
-        { \ eq? [ [ emit-eq? ] intrinsic ] }
-
-        { \ fixnum-shift-fast [ maybe-emit-fixnum-shift-fast ] }
-
-        { \ float+ [ [ emit-float+ ] intrinsic ] }
-        { \ float- [ [ emit-float- ] intrinsic ] }
-        { \ float* [ [ emit-float* ] intrinsic ] }
-        { \ float/f [ [ emit-float/f ] intrinsic ] }
-        { \ float<= [ [ emit-float<= ] intrinsic ] }
-        { \ float>= [ [ emit-float>= ] intrinsic ] }
-        { \ float< [ [ emit-float< ] intrinsic ] }
-        { \ float> [ [ emit-float> ] intrinsic ] }
-        { \ float? [ [ emit-float= ] intrinsic ] }
-
-        ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] }
-        ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] }
-        ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] }
-
-        [ (emit-call) ]
-    } case drop ;
-
-M: #call convert emit-call ;
-
-: emit-call-loop ( #recursive -- )
-    dup label>> loop-nesting get at basic-block get successors>> push
-    end-basic-block
-    basic-block off
-    drop ;
-
-: emit-call-recursive ( #recursive -- )
-    label>> id>> (emit-call) ;
-
-M: #call-recursive convert
-    dup label>> loop?>>
-    [ emit-call-loop ] [ emit-call-recursive ] if ;
-
-M: #push convert
-    [
-        [ out-d>> first produce-vreg ]
-        [ node-output-infos first literal>> ]
-        bi emit-literal
-    ]
-    [ store-out-d ] bi ;
-
-M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ;
-
-M: #>r convert [ load-in-d ] [ store-out-r ] bi ;
-
-M: #r> convert [ load-in-r ] [ store-out-d ] bi ;
-
-M: #terminate convert drop ;
-
-: integer-conditional ( in1 in2 cc -- )
-    [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline
-
-: float-conditional ( in1 in2 branch -- )
-    [ next-vreg [ %fcmp emit ] keep ] dip emit ; inline
-
-: emit-if ( #if -- )
-    in-d>> first value>vreg
-    next-vreg dup f emit-literal
-    cc/= integer-conditional ;
-
-: convert-nested ( node -- last-bb )
-    [
-        <basic-block>
-        [ set-basic-block ] keep
-        [ convert-nodes end-basic-block ] dip
-        basic-block get
-    ] with-scope
-    [ basic-block get successors>> push ] dip ;
-
-: convert-if-children ( #if -- )
-    children>> [ convert-nested ] map sift
-    <basic-block>
-    [ '[ , _ successors>> push ] each ]
-    [ set-basic-block ]
-    bi ;
-
-M: #if convert
-    [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ;
-
-M: #dispatch convert
-    "Unimplemented" throw ;
-
-M: #phi convert drop ;
-
-M: #declare convert drop ;
-
-M: #return convert drop %return emit ;
-
-: convert-recursive ( #recursive -- )
-    [ [ label>> id>> ] [ child>> ] bi (build-cfg) ]
-    [ (emit-call) ]
-    bi ;
-
-: begin-loop ( #recursive -- )
-    label>> basic-block get 2array loop-nesting get push ;
-
-: end-loop ( -- )
-    loop-nesting get pop* ;
-
-: convert-loop ( #recursive -- )
-    begin-basic-block
-    [ begin-loop ]
-    [ child>> convert-nodes ]
-    [ drop end-loop ]
-    tri ;
-
-M: #recursive convert
-    dup label>> loop?>>
-    [ convert-loop ] [ convert-recursive ] if ;
-
-M: #copy convert drop ;
diff --git a/unfinished/compiler/cfg.bluesky/cfg.factor b/unfinished/compiler/cfg.bluesky/cfg.factor
deleted file mode 100644
index ae14f3e009..0000000000
--- a/unfinished/compiler/cfg.bluesky/cfg.factor
+++ /dev/null
@@ -1,47 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sequences sets fry ;
-IN: compiler.cfg
-
-! The id is a globally unique id used for fast hashcode* and
-! equal? on basic blocks. The number is assigned by
-! linearization.
-TUPLE: basic-block < identity-tuple
-id
-number
-instructions
-successors
-predecessors
-stack-frame ;
-
-SYMBOL: next-block-id
-
-: <basic-block> ( -- basic-block )
-    basic-block new
-        next-block-id counter >>id
-        V{ } clone >>instructions
-        V{ } clone >>successors
-        V{ } clone >>predecessors ;
-
-M: basic-block hashcode* id>> nip ;
-
-! Utilities
-SYMBOL: visited-blocks
-
-: visit-block ( basic-block quot -- )
-    over visited-blocks get 2dup key?
-    [ 2drop 2drop ] [ conjoin call ] if ; inline
-
-: (each-block) ( basic-block quot -- )
-    '[
-        ,
-        [ call ]
-        [ [ successors>> ] dip '[ , (each-block) ] each ]
-        2bi
-    ] visit-block ; inline
-
-: each-block ( basic-block quot -- )
-    H{ } clone visited-blocks [ (each-block) ] with-variable ; inline
-
-: copy-at ( from to assoc -- )
-    3dup nip at* [ -rot set-at drop ] [ 2drop 2drop ] if ; inline
diff --git a/unfinished/compiler/cfg.bluesky/elaboration/elaboration.factor b/unfinished/compiler/cfg.bluesky/elaboration/elaboration.factor
deleted file mode 100644
index c3c3e47472..0000000000
--- a/unfinished/compiler/cfg.bluesky/elaboration/elaboration.factor
+++ /dev/null
@@ -1,49 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces math layouts sequences locals
-combinators compiler.vops compiler.vops.builder
-compiler.cfg.builder ;
-IN: compiler.cfg.elaboration
-
-! This pass must run before conversion to machine IR to ensure
-! correctness.
-
-GENERIC: elaborate* ( insn -- )
-
-: slot-shift ( -- n )
-    tag-bits get cell log2 - ;
-
-:: compute-slot-known-tag ( insn -- addr )
-    { $1 $2 $3 $4 $5 } temps
-    init-intrinsic
-    $1 slot-shift %iconst emit  ! load shift offset
-    $2 insn slot>> $1 %shr emit ! shift slot by shift offset
-    $3 insn tag>> %iconst emit  ! load tag number
-    $4 $2 $3 %isub emit
-    $5 insn obj>> $4 %iadd emit ! compute slot offset
-    $5
-    ;
-
-:: compute-slot-any-tag ( insn -- addr )
-    { $1 $2 $3 $4 } temps
-    init-intrinsic
-    $1 insn obj>> emit-untag    ! untag object
-    $2 slot-shift %iconst emit  ! load shift offset
-    $3 insn slot>> $2 %shr emit ! shift slot by shift offset
-    $4 $1 $3 %iadd emit         ! compute slot offset
-    $4
-    ;
-
-: compute-slot ( insn -- addr )
-    dup tag>> [ compute-slot-known-tag ] [ compute-slot-any-tag ] if ;
-
-M: %%slot elaborate*
-    [ out>> ] [ compute-slot ] bi %load emit ;
-
-M: %%set-slot elaborate*
-    [ in>> ] [ compute-slot ] bi %store emit ;
-
-M: object elaborate* , ;
-
-: elaboration ( insns -- insns )
-    [ [ elaborate* ] each ] { } make ;
diff --git a/unfinished/compiler/cfg.bluesky/kill-nops/kill-nops.factor b/unfinished/compiler/cfg.bluesky/kill-nops/kill-nops.factor
deleted file mode 100644
index 56e88c37e4..0000000000
--- a/unfinished/compiler/cfg.bluesky/kill-nops/kill-nops.factor
+++ /dev/null
@@ -1,9 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel compiler.vops ;
-IN: compiler.cfg.kill-nops
-
-! Smallest compiler pass ever.
-
-: kill-nops ( instructions -- instructions' )
-    [ nop? not ] filter ;
diff --git a/unfinished/compiler/cfg.bluesky/live-ranges/live-ranges.factor b/unfinished/compiler/cfg.bluesky/live-ranges/live-ranges.factor
deleted file mode 100644
index e6ff6164d9..0000000000
--- a/unfinished/compiler/cfg.bluesky/live-ranges/live-ranges.factor
+++ /dev/null
@@ -1,40 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs accessors math.order sequences
-compiler.vops ;
-IN: compiler.cfg.live-ranges
-
-TUPLE: live-range from to ;
-
-! Maps vregs to live ranges
-SYMBOL: live-ranges
-
-: def ( n vreg -- )
-    [ dup live-range boa ] dip live-ranges get set-at ;
-
-: use ( n vreg -- )
-    live-ranges get at [ max ] change-to drop ;
-
-GENERIC: compute-live-ranges* ( n insn -- )
-
-M: nullary-op compute-live-ranges*
-    2drop ;
-
-M: flushable-op compute-live-ranges*
-    out>> def ;
-
-M: effect-op compute-live-ranges*
-    in>> use ;
-
-M: unary-op compute-live-ranges*
-    [ out>> def ] [ in>> use ] 2bi ;
-
-M: binary-op compute-live-ranges*
-    [ call-next-method ] [ in1>> use ] [ in2>> use ] 2tri ;
-
-M: %store compute-live-ranges*
-    [ call-next-method ] [ addr>> use ] 2bi ;
-
-: compute-live-ranges ( insns -- )
-    H{ } clone live-ranges set
-    [ swap compute-live-ranges* ] each-index ;
diff --git a/unfinished/compiler/cfg.bluesky/predecessors/predecessors.factor b/unfinished/compiler/cfg.bluesky/predecessors/predecessors.factor
deleted file mode 100644
index c05a425a79..0000000000
--- a/unfinished/compiler/cfg.bluesky/predecessors/predecessors.factor
+++ /dev/null
@@ -1,12 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg kernel accessors sequences ;
-IN: compiler.cfg.predecessors
-
-! Pass to compute precedecessors.
-
-: compute-predecessors ( procedure -- )
-    [
-        dup successors>>
-        [ predecessors>> push ] with each
-    ] each-block ;
diff --git a/unfinished/compiler/cfg.bluesky/simplifier/simplifier.factor b/unfinished/compiler/cfg.bluesky/simplifier/simplifier.factor
deleted file mode 100644
index 2e51a1af9a..0000000000
--- a/unfinished/compiler/cfg.bluesky/simplifier/simplifier.factor
+++ /dev/null
@@ -1,25 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences kernel
-compiler.cfg
-compiler.cfg.predecessors
-compiler.cfg.stack
-compiler.cfg.alias
-compiler.cfg.write-barrier
-compiler.cfg.elaboration
-compiler.cfg.vn
-compiler.cfg.vn.conditions
-compiler.cfg.kill-nops ;
-IN: compiler.cfg.simplifier
-
-: simplify ( insns -- insns' )
-    normalize-height
-    alias-analysis
-    elaboration
-    value-numbering
-    eliminate-write-barrier
-    kill-nops ;
-
-: simplify-cfg ( procedure -- procedure )
-    dup compute-predecessors
-    dup [ [ simplify ] change-instructions drop ] each-block ;
diff --git a/unfinished/compiler/cfg.bluesky/stack/stack.factor b/unfinished/compiler/cfg.bluesky/stack/stack.factor
deleted file mode 100644
index 43dd7a0c84..0000000000
--- a/unfinished/compiler/cfg.bluesky/stack/stack.factor
+++ /dev/null
@@ -1,42 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math namespaces sequences kernel fry
-compiler.vops ;
-IN: compiler.cfg.stack
-
-! Combine multiple stack height changes into one, done at the
-! start of the basic block.
-!
-! Alias analysis and value numbering assume this optimization
-! has been performed.
-
-! Current data and retain stack height is stored in
-! %data, %retain variables.
-GENERIC: compute-heights ( insn -- )
-
-M: %height compute-heights
-    [ n>> ] [ stack>> ] bi [ + ] change ;
-
-M: object compute-heights drop ;
-
-GENERIC: normalize-height* ( insn -- insn )
-
-M: %height normalize-height*
-    [ n>> ] [ stack>> ] bi [ swap - ] change nop ;
-
-: (normalize-height) ( insn -- insn )
-    dup stack>> get '[ , + ] change-n ; inline
-
-M: %peek normalize-height* (normalize-height) ;
-
-M: %replace normalize-height* (normalize-height) ;
-
-M: object normalize-height* ;
-
-: normalize-height ( insns -- insns' )
-    0 %data set
-    0 %retain set
-    [ [ compute-heights ] each ]
-    [ [ [ normalize-height* ] map ] with-scope ] bi
-    %data get dup zero? [ drop ] [ %data %height boa prefix ] if
-    %retain get dup zero? [ drop ] [ %retain %height boa prefix ] if ;
diff --git a/unfinished/compiler/cfg.bluesky/summary.txt b/unfinished/compiler/cfg.bluesky/summary.txt
deleted file mode 100644
index eac58baecd..0000000000
--- a/unfinished/compiler/cfg.bluesky/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Low-level optimizer operating on control flow graph SSA IR
diff --git a/unfinished/compiler/cfg.bluesky/vn/conditions/conditions.factor b/unfinished/compiler/cfg.bluesky/vn/conditions/conditions.factor
deleted file mode 100644
index 259e8232f9..0000000000
--- a/unfinished/compiler/cfg.bluesky/vn/conditions/conditions.factor
+++ /dev/null
@@ -1,53 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences layouts accessors compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions
-compiler.cfg.vn.liveness
-compiler.cfg.vn ;
-IN: compiler.cfg.vn.conditions
-
-! The CFG generator produces naive code for the following code
-! sequence:
-!
-! fixnum< [ ... ] [ ... ] if
-!
-! The fixnum< comparison generates a boolean, which is then
-! tested against f.
-!
-! Using value numbering, we optimize the comparison of a boolean
-! against f where the boolean is the result of comparison.
-
-: expr-f? ( expr -- ? )
-    dup op>> %iconst eq?
-    [ value>> \ f tag-number = ] [ drop f ] if ;
-
-: comparison-with-f? ( insn -- expr/f ? )
-    #! The expr is a binary-op %icmp or %fcmp.
-    dup code>> cc/= eq? [
-        in>> vreg>vn vn>expr dup in2>> vn>expr expr-f?
-    ] [ drop f f ] if ;
-
-: of-boolean? ( expr -- expr/f ? )
-    #! The expr is a binary-op %icmp or %fcmp.
-    in1>> vn>expr dup op>> { %%iboolean %%fboolean } memq? ;
-
-: original-comparison ( expr -- in/f code/f )
-    [ in>> vn>vreg ] [ code>> ] bi ;
-
-: eliminate-boolean ( insn -- in/f code/f )
-    comparison-with-f? [
-        of-boolean? [
-            original-comparison
-        ] [ drop f f ] if
-    ] [ drop f f ] if ;
-
-M: cond-branch make-value-node
-    #! If the conditional branch is testing the result of an
-    #! earlier comparison against f, we only mark as live the
-    #! earlier comparison, so DCE will eliminate the boolean.
-    dup eliminate-boolean drop swap in>> or live-vreg ;
- 
-M: cond-branch eliminate
-    dup eliminate-boolean dup
-    [ [ >>in ] [ >>code ] bi* ] [ 2drop ] if ;
diff --git a/unfinished/compiler/cfg.bluesky/vn/constant-fold/constant-fold.factor b/unfinished/compiler/cfg.bluesky/vn/constant-fold/constant-fold.factor
deleted file mode 100644
index f30a55d869..0000000000
--- a/unfinished/compiler/cfg.bluesky/vn/constant-fold/constant-fold.factor
+++ /dev/null
@@ -1,17 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel compiler.vops compiler.cfg.vn.graph
-compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.constant-fold
-
-GENERIC: constant-fold ( insn -- insn' )
-
-M: vop constant-fold ;
-
-: expr>insn ( out constant-expr -- constant-op )
-    [ value>> ] [ op>> ] bi new swap >>value swap >>out ;
-
-M: pure-op constant-fold
-    dup out>>
-    dup vreg>vn vn>expr
-    dup constant-expr? [ expr>insn nip ] [ 2drop ] if ;
diff --git a/unfinished/compiler/cfg.bluesky/vn/expressions/expressions.factor b/unfinished/compiler/cfg.bluesky/vn/expressions/expressions.factor
deleted file mode 100644
index 7b84c01057..0000000000
--- a/unfinished/compiler/cfg.bluesky/vn/expressions/expressions.factor
+++ /dev/null
@@ -1,64 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes kernel math namespaces sorting
-compiler.vops compiler.cfg.vn.graph ;
-IN: compiler.cfg.vn.expressions
-
-! Referentially-transparent expressions
-TUPLE: expr op ;
-TUPLE: nullary-expr < expr ;
-TUPLE: unary-expr < expr in ;
-TUPLE: binary-expr < expr in1 in2 ;
-TUPLE: commutative-expr < binary-expr ;
-TUPLE: boolean-expr < unary-expr code ;
-TUPLE: constant-expr < expr value ;
-TUPLE: literal-expr < unary-expr object ;
-
-! op is always %peek
-TUPLE: peek-expr < expr loc ;
-
-SYMBOL: input-expr-counter
-
-: next-input-expr ( -- n )
-    input-expr-counter [ dup 1 + ] change ;
-
-! Expressions whose values are inputs to the basic block. We
-! can eliminate a second computation having the same 'n' as
-! the first one; we can also eliminate input-exprs whose
-! result is not used.
-TUPLE: input-expr < expr n ;
-
-GENERIC: >expr ( insn -- expr )
-
-M: %literal-table >expr
-    class nullary-expr boa ;
-
-M: constant-op >expr
-    [ class ] [ value>> ] bi constant-expr boa ;
-
-M: %literal >expr
-    [ class ] [ in>> vreg>vn ] [ object>> ] tri literal-expr boa ;
-
-M: unary-op >expr
-    [ class ] [ in>> vreg>vn ] bi unary-expr boa ;
-
-M: binary-op >expr
-    [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
-    binary-expr boa ;
-
-M: commutative-op >expr
-    [ class ] [ in1>> vreg>vn ] [ in2>> vreg>vn ] tri
-    sort-pair commutative-expr boa ;
-
-M: boolean-op >expr
-    [ class ] [ in>> vreg>vn ] [ code>> ] tri
-    boolean-expr boa ;
-
-M: %peek >expr
-    [ class ] [ stack-loc ] bi peek-expr boa ;
-
-M: flushable-op >expr
-    class next-input-expr input-expr boa ;
-
-: init-expressions ( -- )
-    0 input-expr-counter set ;
diff --git a/unfinished/compiler/cfg.bluesky/vn/graph/graph.factor b/unfinished/compiler/cfg.bluesky/vn/graph/graph.factor
deleted file mode 100644
index ef5d7c2d46..0000000000
--- a/unfinished/compiler/cfg.bluesky/vn/graph/graph.factor
+++ /dev/null
@@ -1,37 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs biassocs accessors
-math.order prettyprint.backend parser ;
-IN: compiler.cfg.vn.graph
-
-TUPLE: vn n ;
-
-SYMBOL: vn-counter
-
-: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
-
-: VN: scan-word vn boa parsed ; parsing
-
-M: vn <=> [ n>> ] compare ;
-
-M: vn pprint* \ VN: pprint-word n>> pprint* ;
-
-! biassoc mapping expressions to value numbers
-SYMBOL: exprs>vns
-
-: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
-
-: vn>expr ( vn -- expr ) exprs>vns get value-at ;
-
-SYMBOL: vregs>vns
-
-: vreg>vn ( vreg -- vn ) vregs>vns get at ;
-
-: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
-
-: set-vn ( vn vreg -- ) vregs>vns get set-at ;
-
-: init-value-graph ( -- )
-    0 vn-counter set
-    <bihash> exprs>vns set
-    <bihash> vregs>vns set ;
diff --git a/unfinished/compiler/cfg.bluesky/vn/liveness/liveness.factor b/unfinished/compiler/cfg.bluesky/vn/liveness/liveness.factor
deleted file mode 100644
index 4a218d40df..0000000000
--- a/unfinished/compiler/cfg.bluesky/vn/liveness/liveness.factor
+++ /dev/null
@@ -1,37 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs sets accessors compiler.vops
-compiler.cfg.vn.graph compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.liveness
-
-! A set of VNs which are (transitively) used by effect-ops. This
-! is precisely the set of VNs whose value is needed outside of
-! the basic block.
-SYMBOL: live-vns
-
-GENERIC: live-expr ( expr -- )
-
-: live-vn ( vn -- )
-    #! Mark a VN and all VNs used in its computation as live.
-    dup live-vns get key? [ drop ] [
-        [ live-vns get conjoin ] [ vn>expr live-expr ] bi
-    ] if ;
-
-: live-vreg ( vreg -- ) vreg>vn live-vn ;
-
-M: expr live-expr drop ;
-M: literal-expr live-expr in>> live-vn ;
-M: unary-expr live-expr in>> live-vn ;
-M: binary-expr live-expr [ in1>> live-vn ] [ in2>> live-vn ] bi ;
-
-: live? ( vreg -- ? )
-    dup vreg>vn tuck vn>vreg =
-    [ live-vns get key? ] [ drop f ] if ;
-
-: init-liveness ( -- )
-    H{ } clone live-vns set ;
-
-GENERIC: eliminate ( insn -- insn' )
-
-M: flushable-op eliminate dup out>> live? ?nop ;
-M: vop eliminate ;
diff --git a/unfinished/compiler/cfg.bluesky/vn/propagate/propagate.factor b/unfinished/compiler/cfg.bluesky/vn/propagate/propagate.factor
deleted file mode 100644
index 75ada5f8ed..0000000000
--- a/unfinished/compiler/cfg.bluesky/vn/propagate/propagate.factor
+++ /dev/null
@@ -1,43 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs sequences kernel accessors
-compiler.vops
-compiler.cfg.vn.graph ;
-IN: compiler.cfg.vn.propagate
-
-! If two vregs compute the same value, replace references to
-! the latter with the former.
-
-: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
-
-GENERIC: propogate ( insn -- insn )
-
-M: effect-op propogate
-    [ resolve ] change-in ;
-
-M: unary-op propogate
-    [ resolve ] change-in ;
-
-M: binary-op propogate
-    [ resolve ] change-in1
-    [ resolve ] change-in2 ;
-
-M: %phi propogate
-    [ [ resolve ] map ] change-in ;
-
-M: %%slot propogate
-    [ resolve ] change-obj
-    [ resolve ] change-slot ;
-
-M: %%set-slot propogate
-    call-next-method
-    [ resolve ] change-obj
-    [ resolve ] change-slot ;
-
-M: %store propogate
-    call-next-method
-    [ resolve ] change-addr ;
-
-M: nullary-op propogate ;
-
-M: flushable-op propogate ;
diff --git a/unfinished/compiler/cfg.bluesky/vn/simplify/simplify.factor b/unfinished/compiler/cfg.bluesky/vn/simplify/simplify.factor
deleted file mode 100644
index f16f3e3e8a..0000000000
--- a/unfinished/compiler/cfg.bluesky/vn/simplify/simplify.factor
+++ /dev/null
@@ -1,220 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators classes math math.order
-layouts locals
-compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions ;
-IN: compiler.cfg.vn.simplify
-
-! Return value of f means we didn't simplify.
-GENERIC: simplify* ( expr -- vn/expr/f )
-
-: constant ( val type -- expr ) swap constant-expr boa ;
-
-: simplify-not ( in -- vn/expr/f )
-    {
-        { [ dup constant-expr? ] [ value>> bitnot %iconst constant ] }
-        { [ dup op>> %not = ] [ in>> ] }
-        [ drop f ]
-    } cond ;
-
-: simplify-box-float ( in -- vn/expr/f )
-    {
-        { [ dup op>> %%unbox-float = ] [ in>> ] }
-        [ drop f ]
-    } cond ;
-
-: simplify-unbox-float ( in -- vn/expr/f )
-    {
-        { [ dup literal-expr? ] [ object>> %fconst constant ] }
-        { [ dup op>> %%box-float = ] [ in>> ] }
-        [ drop f ]
-    } cond ;
-
-M: unary-expr simplify*
-    #! Note the copy propagation: a %copy always simplifies to
-    #! its source vn.
-    [ in>> vn>expr ] [ op>> ] bi {
-        { %copy [ ] }
-        { %not [ simplify-not ] }
-        { %%box-float [ simplify-box-float ] }
-        { %%unbox-float [ simplify-unbox-float ] }
-        [ 2drop f ]
-    } case ;
-
-: izero? ( expr -- ? ) T{ constant-expr f %iconst 0 } = ;
-
-: ione? ( expr -- ? ) T{ constant-expr f %iconst 1 } = ;
-
-: ineg-one? ( expr -- ? ) T{ constant-expr f %iconst -1 } = ;
-
-: fzero? ( expr -- ? ) T{ constant-expr f %fconst 0 } = ;
-
-: fone? ( expr -- ? ) T{ constant-expr f %fconst 1 } = ;
-
-: fneg-one? ( expr -- ? ) T{ constant-expr f %fconst -1 } = ;
-
-: identity ( in1 in2 val type -- expr ) constant 2nip ;
-
-: constant-fold? ( in1 in2 -- ? )
-    [ constant-expr? ] both? ;
-
-:: constant-fold ( in1 in2 quot type -- expr )
-    in1 in2 constant-fold?
-    [ in1 value>> in2 value>> quot call type constant ]
-    [ f ]
-    if ; inline
-
-: simplify-iadd ( in1 in2 -- vn/expr/f )
-    {
-        { [ over izero? ] [ nip ] }
-        { [ dup izero? ] [ drop ] }
-        [ [ + ] %iconst constant-fold ]
-    } cond ;
-
-: simplify-imul ( in1 in2 -- vn/expr/f )
-    {
-        { [ over ione? ] [ nip ] }
-        { [ dup ione? ] [ drop ] }
-        [ [ * ] %iconst constant-fold ]
-    } cond ;
-
-: simplify-and ( in1 in2 -- vn/expr/f )
-    {
-        { [ dup izero? ] [ 0 %iconst identity ] }
-        { [ dup ineg-one? ] [ drop ] }
-        { [ 2dup = ] [ drop ] }
-        [ [ bitand ] %iconst constant-fold ]
-    } cond ;
-
-: simplify-or ( in1 in2 -- vn/expr/f )
-    {
-        { [ dup izero? ] [ drop ] }
-        { [ dup ineg-one? ] [ -1 %iconst identity ] }
-        { [ 2dup = ] [ drop ] }
-        [ [ bitor ] %iconst constant-fold ]
-    } cond ;
-
-: simplify-xor ( in1 in2 -- vn/expr/f )
-    {
-        { [ dup izero? ] [ drop ] }
-        [ [ bitxor ] %iconst constant-fold ]
-    } cond ;
-
-: simplify-fadd ( in1 in2 -- vn/expr/f )
-    {
-        { [ over fzero? ] [ nip ] }
-        { [ dup fzero? ] [ drop ] }
-        [ [ + ] %fconst constant-fold ]
-    } cond ;
-
-: simplify-fmul ( in1 in2 -- vn/expr/f )
-    {
-        { [ over fone? ] [ nip ] }
-        { [ dup fone? ] [ drop ] }
-        [ [ * ] %fconst constant-fold ]
-    } cond ;
-
-: commutative-operands ( expr -- in1 in2 )
-    [ in1>> vn>expr ] [ in2>> vn>expr ] bi
-    over constant-expr? [ swap ] when ;
-
-M: commutative-expr simplify*
-    [ commutative-operands ] [ op>> ] bi {
-        { %iadd [ simplify-iadd ] }
-        { %imul [ simplify-imul ] }
-        { %and [ simplify-and ] }
-        { %or [ simplify-or ] }
-        { %xor [ simplify-xor ] }
-        { %fadd [ simplify-fadd ] }
-        { %fmul [ simplify-fmul ] }
-        [ 3drop f ]
-    } case ;
-
-: simplify-isub ( in1 in2 -- vn/expr/f )
-    {
-        { [ dup izero? ] [ drop ] }
-        { [ 2dup = ] [ 0 %iconst identity ] }
-        [ [ - ] %iconst constant-fold ]
-    } cond ;
-
-: simplify-idiv ( in1 in2 -- vn/expr/f )
-    {
-        { [ dup ione? ] [ drop ] }
-        [ [ /i ] %iconst constant-fold ]
-    } cond ;
-
-: simplify-imod ( in1 in2 -- vn/expr/f )
-    {
-        { [ dup ione? ] [ 0 %iconst identity ] }
-        { [ 2dup = ] [ 0 %iconst identity ] }
-        [ [ mod ] %iconst constant-fold ]
-    } cond ;
-
-: simplify-shl ( in1 in2 -- vn/expr/f )
-    {
-        { [ dup izero? ] [ drop ] }
-        { [ over izero? ] [ drop ] }
-        [ [ shift ] %iconst constant-fold ]
-    } cond ;
-
-: unsigned ( n -- n' )
-    cell-bits 2^ 1- bitand ;
-
-: useless-shift? ( in1 in2 -- ? )
-    over op>> %shl = [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ;
-
-: simplify-shr ( in1 in2 -- vn/expr/f )
-    {
-        { [ dup izero? ] [ drop ] }
-        { [ over izero? ] [ drop ] }
-        { [ 2dup useless-shift? ] [ drop in1>> ] }
-        [ [ neg shift unsigned ] %iconst constant-fold ]
-    } cond ;
-
-: simplify-sar ( in1 in2 -- vn/expr/f )
-    {
-        { [ dup izero? ] [ drop ] }
-        { [ over izero? ] [ drop ] }
-        { [ 2dup useless-shift? ] [ drop in1>> ] }
-        [ [ neg shift ] %iconst constant-fold ]
-    } cond ;
-
-: simplify-icmp ( in1 in2 -- vn/expr/f )
-    = [ +eq+ %cconst constant ] [ f ] if ;
-
-: simplify-fsub ( in1 in2 -- vn/expr/f )
-    {
-        { [ dup izero? ] [ drop ] }
-        [ [ - ] %fconst constant-fold ]
-    } cond ;
-
-: simplify-fdiv ( in1 in2 -- vn/expr/f )
-    {
-        { [ dup fone? ] [ drop ] }
-        [ [ /i ] %fconst constant-fold ]
-    } cond ;
-
-M: binary-expr simplify*
-    [ in1>> vn>expr ] [ in2>> vn>expr ] [ op>> ] tri {
-        { %isub [ simplify-isub ] }
-        { %idiv [ simplify-idiv ] }
-        { %imod [ simplify-imod ] }
-        { %shl [ simplify-shl ] }
-        { %shr [ simplify-shr ] }
-        { %sar [ simplify-sar ] }
-        { %icmp [ simplify-icmp ] }
-        { %fsub [ simplify-fsub ] }
-        { %fdiv [ simplify-fdiv ] }
-        [ 3drop f ]
-    } case ;
-
-M: expr simplify* drop f ;
-
-: simplify ( expr -- vn )
-    dup simplify* {
-        { [ dup not ] [ drop expr>vn ] }
-        { [ dup expr? ] [ expr>vn nip ] }
-        { [ dup vn? ] [ nip ] }
-    } cond ;
diff --git a/unfinished/compiler/cfg.bluesky/vn/vn.factor b/unfinished/compiler/cfg.bluesky/vn/vn.factor
deleted file mode 100644
index e16fff01fc..0000000000
--- a/unfinished/compiler/cfg.bluesky/vn/vn.factor
+++ /dev/null
@@ -1,31 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs biassocs classes kernel math accessors
-sorting sets sequences compiler.vops
-compiler.cfg.vn.graph
-compiler.cfg.vn.expressions
-compiler.cfg.vn.simplify
-compiler.cfg.vn.liveness
-compiler.cfg.vn.constant-fold
-compiler.cfg.vn.propagate ;
-IN: compiler.cfg.vn
-
-: insn>vn ( insn -- vn ) >expr simplify ; inline
-
-GENERIC: make-value-node ( insn -- )
-M: flushable-op make-value-node [ insn>vn ] [ out>> ] bi set-vn ;
-M: effect-op make-value-node in>> live-vreg ;
-M: %store make-value-node [ in>> live-vreg ] [ addr>> live-vreg ] bi ;
-M: %%set-slot make-value-node [ in>> live-vreg ] [ obj>> live-vreg ] bi ;
-M: nullary-op make-value-node drop ;
-
-: init-value-numbering ( -- )
-    init-value-graph
-    init-expressions
-    init-liveness ;
-
-: value-numbering ( instructions -- instructions )
-    init-value-numbering
-    [ [ make-value-node ] each ]
-    [ [ eliminate constant-fold propogate ] map ]
-    bi ;
diff --git a/unfinished/compiler/cfg.bluesky/write-barrier/write-barrier.factor b/unfinished/compiler/cfg.bluesky/write-barrier/write-barrier.factor
deleted file mode 100644
index f42f37702f..0000000000
--- a/unfinished/compiler/cfg.bluesky/write-barrier/write-barrier.factor
+++ /dev/null
@@ -1,26 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets sequences
-compiler.vops compiler.cfg ;
-IN: compiler.cfg.write-barrier
-
-! Eliminate redundant write barrier hits.
-SYMBOL: hits
-
-GENERIC: eliminate-write-barrier* ( insn -- insn' )
-
-M: %%allot eliminate-write-barrier*
-    dup out>> hits get conjoin ;
-
-M: %write-barrier eliminate-write-barrier*
-    dup in>> hits get key?
-    [ drop nop ] [ dup in>> hits get conjoin ] if ;
-
-M: %copy eliminate-write-barrier*
-    dup in/out hits get copy-at ;
-
-M: vop eliminate-write-barrier* ;
-
-: eliminate-write-barrier ( insns -- insns )
-    H{ } clone hits set
-    [ eliminate-write-barrier* ] map ;
diff --git a/unfinished/compiler/lvops.bluesky/lvops.factor b/unfinished/compiler/lvops.bluesky/lvops.factor
deleted file mode 100644
index e1f5ebb528..0000000000
--- a/unfinished/compiler/lvops.bluesky/lvops.factor
+++ /dev/null
@@ -1,21 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.lvops
-
-! Machine representation ("linear virtual operations"). Uses
-! same operations as CFG basic blocks, except edges and branches
-! are replaced by linear jumps (_b* instances).
-
-TUPLE: _label label ;
-
-! Unconditional jump to label
-TUPLE: _b label ;
-
-! Integer
-TUPLE: _bi label in code ;
-TUPLE: _bf label in code ;
-
-! Dispatch table, jumps to one of following _address
-! depending value of 'in'
-TUPLE: _dispatch in ;
-TUPLE: _address word ;
diff --git a/unfinished/compiler/machine.bluesky/builder/builder.factor b/unfinished/compiler/machine.bluesky/builder/builder.factor
deleted file mode 100644
index 42379d4fa3..0000000000
--- a/unfinished/compiler/machine.bluesky/builder/builder.factor
+++ /dev/null
@@ -1,50 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math accessors sequences namespaces
-compiler.cfg compiler.vops compiler.lvops ;
-IN: compiler.machine.builder
-
-SYMBOL: block-counter
-
-: number-basic-block ( basic-block -- )
-    #! Make this fancy later.
-    dup number>> [ drop ] [
-        block-counter [ dup 1+ ] change >>number
-        [ , ] [
-            successors>> <reversed>
-            [ number-basic-block ] each
-        ] bi
-    ] if ;
-
-: flatten-basic-blocks ( procedure -- blocks )
-    [
-        0 block-counter
-        [ number-basic-block ]
-        with-variable
-    ] { } make ;
-
-GENERIC: linearize-instruction ( basic-block insn -- )
-
-M: object linearize-instruction
-    , drop ;
-
-M: %b linearize-instruction
-    drop successors>> first number>> _b emit ;
-
-: conditional-branch ( basic-block insn class -- )
-    [ successors>> ] 2dip
-    [ [ first number>> ] [ [ in>> ] [ code>> ] bi ] [ ] tri* emit ]
-    [ 2drop second number>> _b emit ]
-    3bi ; inline
-
-M: %bi linearize-instruction _bi conditional-branch ;
-M: %bf linearize-instruction _bf conditional-branch ;
-
-: build-mr ( procedure -- insns )
-    [
-        flatten-basic-blocks [
-            [ number>> _label emit ]
-            [ dup instructions>> [ linearize-instruction ] with each ]
-            bi
-        ] each
-    ] { } make ;
diff --git a/unfinished/compiler/machine.bluesky/debugger/debugger.factor b/unfinished/compiler/machine.bluesky/debugger/debugger.factor
deleted file mode 100644
index adc84d771f..0000000000
--- a/unfinished/compiler/machine.bluesky/debugger/debugger.factor
+++ /dev/null
@@ -1,45 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences assocs io
-prettyprint inference generator optimizer
-compiler.vops
-compiler.tree.builder
-compiler.tree.optimizer
-compiler.cfg.builder
-compiler.cfg.simplifier
-compiler.machine.builder
-compiler.machine.simplifier ;
-IN: compiler.machine.debugger
-
-: tree>linear ( tree word -- linear )
-    [
-        init-counter
-        build-cfg
-        [ simplify-cfg build-mr simplify-mr ] assoc-map
-    ] with-scope ;
-
-: linear. ( linear -- )
-    [
-        "==== " write swap .
-        [ . ] each
-    ] assoc-each ;
-
-: linearized-quot. ( quot -- )
-    build-tree optimize-tree
-    "Anonymous quotation" tree>linear
-    linear. ;
-
-: linearized-word. ( word -- )
-    dup build-tree-from-word nip optimize-tree
-    dup word-dataflow nip optimize swap tree>linear linear. ;
-
-: >basic-block ( quot -- basic-block )
-    build-tree optimize-tree
-    [
-        init-counter
-        "Anonymous quotation" build-cfg
-        >alist first second simplify-cfg
-    ] with-scope ;
-
-: basic-block. ( basic-block -- )
-    instructions>> [ . ] each ;
diff --git a/unfinished/compiler/machine.bluesky/simplifier/simplifier.factor b/unfinished/compiler/machine.bluesky/simplifier/simplifier.factor
deleted file mode 100644
index a477c71c04..0000000000
--- a/unfinished/compiler/machine.bluesky/simplifier/simplifier.factor
+++ /dev/null
@@ -1,18 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces sequences.next compiler.lvops ;
-IN: compiler.machine.simplifier
-
-: useless-branch? ( next insn -- ? )
-    2dup [ _label? ] [ _b? ] bi* and
-    [ [ label>> ] bi@ = ] [ 2drop f ] if ;
-
-: simplify-mr ( insns -- insns )
-    #! Remove unconditional branches to labels immediately
-    #! following.
-    [
-        [
-            tuck useless-branch?
-            [ drop ] [ , ] if
-        ] each-next
-    ] { } make ;
diff --git a/unfinished/compiler/new/new.factor b/unfinished/compiler/new/new.factor
deleted file mode 100644
index fd402916a0..0000000000
--- a/unfinished/compiler/new/new.factor
+++ /dev/null
@@ -1,122 +0,0 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces arrays sequences io debugger
-words fry continuations vocabs assocs dlists definitions math
-threads graphs generic combinators deques search-deques
-stack-checker stack-checker.state stack-checker.inlining
-compiler.errors compiler.units compiler.tree.builder
-compiler.tree.optimizer compiler.cfg.builder
-compiler.cfg.linearization compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.codegen ;
-IN: compiler.new
-
-SYMBOL: compile-queue
-SYMBOL: compiled
-
-: queue-compile ( word -- )
-    {
-        { [ dup "forgotten" word-prop ] [ ] }
-        { [ dup compiled get key? ] [ ] }
-        { [ dup inlined-block? ] [ ] }
-        { [ dup primitive? ] [ ] }
-        [ dup compile-queue get push-front ]
-    } cond drop ;
-
-: maybe-compile ( word -- )
-    dup compiled>> [ drop ] [ queue-compile ] if ;
-
-SYMBOL: +failed+
-
-: ripple-up ( words -- )
-    dup "compiled-effect" word-prop +failed+ eq?
-    [ usage [ word? ] filter ] [ compiled-usage keys ] if
-    [ queue-compile ] each ;
-
-: ripple-up? ( word effect -- ? )
-    #! If the word has previously been compiled and had a
-    #! different stack effect, we have to recompile any callers.
-    swap "compiled-effect" word-prop [ = not ] keep and ;
-
-: save-effect ( word effect -- )
-    [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
-    [ "compiled-effect" set-word-prop ]
-    2bi ;
-
-: start ( word -- )
-    H{ } clone dependencies set
-    H{ } clone generic-dependencies set
-    f swap compiler-error ;
-
-: fail ( word error -- )
-    [ swap compiler-error ]
-    [
-        drop
-        [ compiled-unxref ]
-        [ f swap compiled get set-at ]
-        [ +failed+ save-effect ]
-        tri
-    ] 2bi
-    return ;
-
-: frontend ( word -- effect nodes )
-    [ build-tree-from-word ] [ fail ] recover optimize-tree ;
-
-: finish ( effect word -- )
-    [ swap save-effect ]
-    [ compiled-unxref ]
-    [
-        dup crossref?
-        [
-            dependencies get >alist
-            generic-dependencies get >alist
-            compiled-xref
-        ] [ drop ] if
-    ] tri ;
-
-: save-asm ( asm -- )
-    [ [ code>> ] [ label>> ] bi compiled get set-at ]
-    [ calls>> [ queue-compile ] each ]
-    bi ;
-
-: backend ( nodes word -- )
-    build-cfg [
-        build-mr
-        linear-scan
-        build-stack-frame
-        generate
-        save-asm
-    ] each ;
-
-: (compile) ( word -- )
-    '[
-        _ {
-            [ start ]
-            [ frontend ]
-            [ backend ]
-            [ finish ]
-        } cleave
-    ] with-return ;
-
-: compile-loop ( deque -- )
-    [ (compile) yield ] slurp-deque ;
-
-: decompile ( word -- )
-    f 2array 1array t modify-code-heap ;
-
-: optimized-recompile-hook ( words -- alist )
-    [
-        <hashed-dlist> compile-queue set
-        H{ } clone compiled set
-        [ queue-compile ] each
-        compile-queue get compile-loop
-        compiled get >alist
-    ] with-scope ;
-
-: enable-compiler ( -- )
-    [ optimized-recompile-hook ] recompile-hook set-global ;
-
-: disable-compiler ( -- )
-    [ default-recompile-hook ] recompile-hook set-global ;
-
-: recompile-all ( -- )
-    forget-errors all-words compile ;
diff --git a/unfinished/compiler/vops.bluesky/builder/builder.factor b/unfinished/compiler/vops.bluesky/builder/builder.factor
deleted file mode 100644
index 9ce3be8f8e..0000000000
--- a/unfinished/compiler/vops.bluesky/builder/builder.factor
+++ /dev/null
@@ -1,202 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser kernel namespaces words layouts sequences classes
-classes.algebra accessors math arrays byte-arrays
-inference.dataflow optimizer.allot compiler.cfg compiler.vops ;
-IN: compiler.vops.builder
-
-<< : TEMP: CREATE dup [ get ] curry define-inline ; parsing >>
-
-! Temps   Inputs    Outputs
-TEMP: $1  TEMP: #1  TEMP: ^1
-TEMP: $2  TEMP: #2  TEMP: ^2
-TEMP: $3  TEMP: #3  TEMP: ^3
-TEMP: $4  TEMP: #4  TEMP: ^4
-TEMP: $5  TEMP: #5  TEMP: ^5
-
-GENERIC: emit-literal ( vreg object -- )
-
-M: fixnum emit-literal ( vreg object -- )
-    tag-bits get shift %iconst emit ;
-
-M: f emit-literal
-    class tag-number %iconst emit ;
-
-M: object emit-literal ( vreg object -- )
-    next-vreg [ %literal-table emit ] keep
-    swap %literal emit ;
-
-: temps ( seq -- ) [ next-vreg swap set ] each ;
-
-: init-intrinsic ( -- )
-    { $1 $2 $3 $4 ^1 ^2 ^3 ^4 } temps ;
-
-: load-iconst ( value -- vreg )
-    [ next-vreg dup ] dip %iconst emit ;
-
-: load-tag-mask ( -- vreg )
-    tag-mask get load-iconst ;
-
-: load-tag-bits ( -- vreg )
-    tag-bits get load-iconst ;
-
-: emit-tag-fixnum ( out in -- )
-    load-tag-bits %shl emit ;
-
-: emit-untag-fixnum ( out in -- )
-    load-tag-bits %sar emit ;
-
-: emit-untag ( out in -- )
-    next-vreg dup tag-mask get bitnot %iconst emit
-    %and emit ;
-
-: emit-tag ( -- )
-    $1 #1 load-tag-mask %and emit
-    ^1 $1 emit-tag-fixnum ;
-
-: emit-slot ( node -- )
-    [ ^1 #1 #2 ] dip dup in-d>> first node-class class-tag %%slot emit ;
-
-UNION: immediate fixnum POSTPONE: f ;
-
-: emit-write-barrier ( node -- )
-    dup in-d>> first node-class immediate class< [ #2 %write-barrier emit ] unless ;
-
-: emit-set-slot ( node -- )
-    [ emit-write-barrier ]
-    [ [ #1 #2 #3 ] dip dup in-d>> second node-class class-tag %%set-slot emit ]
-    bi ;
-
-: emit-fixnum-bitnot ( -- )
-    $1 #1 %not emit
-    ^1 $1 load-tag-mask %xor emit ;
-
-: emit-fixnum+fast ( -- )
-    ^1 #1 #2 %iadd emit ;
-
-: emit-fixnum-fast ( -- )
-    ^1 #1 #2 %isub emit ;
-
-: emit-fixnum-bitand ( -- )
-    ^1 #1 #2 %and emit ;
-
-: emit-fixnum-bitor ( -- )
-    ^1 #1 #2 %or emit ;
-
-: emit-fixnum-bitxor ( -- )
-    ^1 #1 #2 %xor emit ;
-
-: emit-fixnum*fast ( -- )
-    $1 #1 emit-untag-fixnum
-    ^1 $1 #2 %imul emit ;
-
-: emit-fixnum-shift-left-fast ( n -- )
-    [ $1 ] dip %iconst emit
-    ^1 #1 $1 %shl emit ;
-
-: emit-fixnum-shift-right-fast ( n -- )
-    [ $1 ] dip %iconst emit
-    $2 #1 $1 %sar emit
-    ^1 $2 emit-untag ;
-
-: emit-fixnum-shift-fast ( n -- )
-    dup 0 >=
-    [ emit-fixnum-shift-left-fast ]
-    [ neg emit-fixnum-shift-right-fast ] if ;
-
-: emit-fixnum-compare ( cc -- )
-    $1 #1 #2 %icmp emit
-    [ ^1 $1 ] dip %%iboolean emit ;
-
-: emit-fixnum<= ( -- )
-    cc<= emit-fixnum-compare ;
-
-: emit-fixnum>= ( -- )
-    cc>= emit-fixnum-compare ;
-
-: emit-fixnum< ( -- )
-    cc< emit-fixnum-compare ;
-
-: emit-fixnum> ( -- )
-    cc> emit-fixnum-compare ;
-
-: emit-eq? ( -- )
-    cc= emit-fixnum-compare ;
-
-: emit-unbox-float ( out in -- )
-    %%unbox-float emit ;
-
-: emit-box-float ( out in -- )
-    %%box-float emit ;
-
-: emit-unbox-floats ( -- )
-    $1 #1 emit-unbox-float
-    $2 #2 emit-unbox-float ;
-
-: emit-float+ ( -- )
-    emit-unbox-floats
-    $3 $1 $2 %fadd emit
-    ^1 $3 emit-box-float ;
-
-: emit-float- ( -- )
-    emit-unbox-floats
-    $3 $1 $2 %fsub emit
-    ^1 $3 emit-box-float ;
-
-: emit-float* ( -- )
-    emit-unbox-floats
-    $3 $1 $2 %fmul emit
-    ^1 $3 emit-box-float ;
-
-: emit-float/f ( -- )
-    emit-unbox-floats
-    $3 $1 $2 %fdiv emit
-    ^1 $3 emit-box-float ;
-
-: emit-float-compare ( cc -- )
-    emit-unbox-floats
-    $3 $1 $2 %fcmp emit
-    [ ^1 $3 ] dip %%fboolean emit ;
-
-: emit-float<= ( -- )
-    cc<= emit-float-compare ;
-
-: emit-float>= ( -- )
-    cc>= emit-float-compare ;
-
-: emit-float< ( -- )
-    cc< emit-float-compare ;
-
-: emit-float> ( -- )
-    cc> emit-float-compare ;
-
-: emit-float= ( -- )
-    cc= emit-float-compare ;
-
-: emit-allot ( vreg size class -- )
-    [ tag-number ] [ type-number ] bi %%allot emit ;
-
-: emit-(tuple) ( layout -- )
-    [ [ ^1 ] dip size>> 2 + tuple emit-allot ]
-    [ [ $1 ] dip emit-literal ] bi
-    $2 1 emit-literal
-    $1 ^1 $2 tuple tag-number %%set-slot emit ;
-
-: emit-(array) ( n -- )
-    [ [ ^1 ] dip 2 + array emit-allot ]
-    [ [ $1 ] dip emit-literal ] bi
-    $2 1 emit-literal
-    $1 ^1 $2 array tag-number %%set-slot emit ;
-
-: emit-(byte-array) ( n -- )
-    [ [ ^1 ] dip bytes>cells 2 + byte-array emit-allot ]
-    [ [ $1 ] dip emit-literal ] bi
-    $2 1 emit-literal
-    $1 ^1 $2 byte-array tag-number %%set-slot emit ;
-
-! fixnum>bignum
-! bignum>fixnum
-! fixnum+
-! fixnum-
-! getenv, setenv
-! alien accessors
diff --git a/unfinished/compiler/vops.bluesky/vops.factor b/unfinished/compiler/vops.bluesky/vops.factor
deleted file mode 100644
index 839d4e064d..0000000000
--- a/unfinished/compiler/vops.bluesky/vops.factor
+++ /dev/null
@@ -1,181 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: parser prettyprint.backend kernel accessors math
-math.order sequences namespaces arrays assocs ;
-IN: compiler.vops
-
-TUPLE: vreg n ;
-
-: VREG: scan-word vreg boa parsed ; parsing
-
-M: vreg pprint* \ VREG: pprint-word n>> pprint* ;
-
-SYMBOL: vreg-counter
-
-: init-counter ( -- )
-    { 0 } clone vreg-counter set ;
-
-: next-vreg ( -- n )
-    0 vreg-counter get [ dup 1+ ] change-nth vreg boa ;
-
-: emit ( ... class -- ) boa , ; inline
-
-! ! ! Instructions. Those prefixed with %% are high level
-! ! ! instructions eliminated during the elaboration phase.
-TUPLE: vop ;
-
-! Instruction which does not touch vregs.
-TUPLE: nullary-op < vop ;
-
-! Does nothing
-TUPLE: nop < nullary-op ;
-
-: nop ( -- vop ) T{ nop } ;
-
-: ?nop ( vop ? -- vop/nop ) [ drop nop ] unless ;
-
-! Instruction with no side effects; if 'out' is never read, we
-! can eliminate it.
-TUPLE: flushable-op < vop out ;
-
-! Instruction which is referentially transparent; we can replace
-! repeated computation with a reference to a previous value
-TUPLE: pure-op < flushable-op ;
-
-! Instruction only used for its side effect, produces no values
-TUPLE: effect-op < vop in ;
-
-TUPLE: binary-op < pure-op in1 in2 ;
-
-: inputs ( insn -- in1 in2 ) [ in1>> ] [ in2>> ] bi ; inline
-
-: in/out ( insn -- in out ) [ in>> ] [ out>> ] bi ; inline
-
-TUPLE: unary-op < pure-op in ;
-
-! Merge point; out is a sequence of vregs in a sequence of
-! sequences of vregs
-TUPLE: %phi < pure-op in ;
-
-! Integer, floating point, condition register copy
-TUPLE: %copy < unary-op ;
-
-! Constants
-TUPLE: constant-op < pure-op value ;
-
-TUPLE: %iconst < constant-op ; ! Integer
-TUPLE: %fconst < constant-op ; ! Float
-TUPLE: %cconst < constant-op ; ! Comparison result, +lt+ +eq+ +gt+
-
-! Load address of literal table into out
-TUPLE: %literal-table < pure-op ;
-
-! Load object literal from table.
-TUPLE: %literal < unary-op object ;
-
-! Read/write ops: candidates for alias analysis
-TUPLE: read-op < flushable-op ;
-TUPLE: write-op < effect-op ;
-
-! Stack shuffling
-SINGLETON: %data
-SINGLETON: %retain
-
-TUPLE: %peek < read-op n stack ;
-TUPLE: %replace < write-op n stack ;
-TUPLE: %height < nullary-op n stack ;
-
-: stack-loc ( insn -- pair ) [ n>> ] [ stack>> ] bi 2array ;
-
-TUPLE: commutative-op < binary-op ;
-
-! Integer arithmetic
-TUPLE: %iadd < commutative-op ;
-TUPLE: %isub < binary-op ;
-TUPLE: %imul < commutative-op ;
-TUPLE: %idiv < binary-op ;
-TUPLE: %imod < binary-op ;
-TUPLE: %icmp < binary-op ;
-
-! Bitwise ops
-TUPLE: %not < unary-op ;
-TUPLE: %and < commutative-op ;
-TUPLE: %or  < commutative-op ;
-TUPLE: %xor < commutative-op ;
-TUPLE: %shl < binary-op ;
-TUPLE: %shr < binary-op ;
-TUPLE: %sar < binary-op ;
-
-! Float arithmetic
-TUPLE: %fadd < commutative-op ;
-TUPLE: %fsub < binary-op ;
-TUPLE: %fmul < commutative-op ;
-TUPLE: %fdiv < binary-op ;
-TUPLE: %fcmp < binary-op ;
-
-! Float/integer conversion
-TUPLE: %f>i < unary-op ;
-TUPLE: %i>f < unary-op ;
-
-! Float boxing/unboxing
-TUPLE: %%box-float < unary-op ;
-TUPLE: %%unbox-float < unary-op ;
-
-! High level slot accessors for alias analysis
-! tag is f; if its not f, we can generate a faster sequence
-TUPLE: %%slot < read-op obj slot tag ;
-TUPLE: %%set-slot < write-op obj slot tag ;
-
-TUPLE: %write-barrier < effect-op ;
-
-! Memory
-TUPLE: %load < unary-op ;
-TUPLE: %store < effect-op addr ;
-
-! Control flow; they jump to either the first or second successor
-! of the BB
-
-! Unconditional transfer to first successor
-TUPLE: %b < nullary-op ;
-
-SYMBOL: cc<
-SYMBOL: cc<=
-SYMBOL: cc=
-SYMBOL: cc>
-SYMBOL: cc>=
-SYMBOL: cc/=
-
-: evaluate-cc ( result cc -- ? )
-    H{
-        { cc<  { +lt+           } }
-        { cc<= { +lt+ +eq+      } }
-        { cc=  {      +eq+      } }
-        { cc>= {      +eq+ +gt+ } }
-        { cc>  {           +gt+ } }
-        { cc/= { +lt+      +gt+ } }
-    } at memq? ;
-
-TUPLE: cond-branch < effect-op code ;
-
-TUPLE: %bi < cond-branch ;
-TUPLE: %bf < cond-branch ;
-
-! Convert condition register to a boolean
-TUPLE: boolean-op < unary-op code ;
-
-TUPLE: %%iboolean < boolean-op ;
-TUPLE: %%fboolean < boolean-op ;
-
-! Dispatch table, jumps to successor 0..n-1 depending value of
-! in, which must be in the range [0,n)
-TUPLE: %dispatch < effect-op ;
-
-! Procedures
-TUPLE: %return < nullary-op ;
-TUPLE: %prolog < nullary-op ;
-TUPLE: %epilog < nullary-op ;
-TUPLE: %jump < nullary-op word ;
-TUPLE: %call < nullary-op word ;
-
-! Heap allocation
-TUPLE: %%allot < flushable-op size tag type ;

From e6e313eba9367db5c2041b9c6c5cb7d7a525f3cb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 7 Oct 2008 16:42:11 -0500
Subject: [PATCH 003/318] Backend updates

---
 basis/cpu/architecture/architecture.factor    |  42 +-
 basis/cpu/x86/32/32.factor                    |   2 -
 basis/cpu/x86/64/64.factor                    |   2 -
 basis/cpu/x86/allot/allot.factor              | 216 +++---
 .../cpu/x86/architecture/architecture.factor  |  61 +-
 basis/cpu/x86/intrinsics/intrinsics.factor    | 308 +++------
 basis/cpu/x86/sse2/sse2.factor                |   9 +-
 unfinished/compiler/backend/backend.factor    | 189 -----
 unfinished/compiler/backend/x86/32/32.factor  | 318 ---------
 unfinished/compiler/backend/x86/64/64.factor  | 226 ------
 .../compiler/backend/x86/sse2/sse2.factor     | 106 ---
 unfinished/compiler/backend/x86/x86.factor    | 643 ------------------
 12 files changed, 235 insertions(+), 1887 deletions(-)
 delete mode 100644 unfinished/compiler/backend/backend.factor
 delete mode 100644 unfinished/compiler/backend/x86/32/32.factor
 delete mode 100644 unfinished/compiler/backend/x86/64/64.factor
 delete mode 100644 unfinished/compiler/backend/x86/sse2/sse2.factor
 delete mode 100644 unfinished/compiler/backend/x86/x86.factor

diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 9e2b4def17..c5e8c88988 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -5,12 +5,15 @@ memory namespaces make sequences layouts system hashtables
 classes alien byte-arrays combinators words sets ;
 IN: cpu.architecture
 
-! Register classes
-SINGLETON: int-regs
-SINGLETON: single-float-regs
-SINGLETON: double-float-regs
-UNION: float-regs single-float-regs double-float-regs ;
-UNION: reg-class int-regs float-regs ;
+! Labels
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
+
+! Mapping from register class to machine registers
+HOOK: machine-registers cpu ( -- assoc )
 
 ! A pseudo-register class for parameters spilled on the stack
 SINGLETON: stack-params
@@ -29,7 +32,7 @@ M: object param-reg param-regs nth ;
 GENERIC: vregs ( register-class -- regs )
 
 ! Load a literal (immediate or indirect)
-GENERIC# load-literal 1 ( obj vreg -- )
+GENERIC# load-literal 1 ( obj reg -- )
 
 HOOK: load-indirect cpu ( obj reg -- )
 
@@ -40,21 +43,9 @@ TUPLE: stack-frame total-size size params return ;
 ! Set up caller stack frame
 HOOK: %prologue cpu ( n -- )
 
-: %prologue-later ( -- ) \ %prologue-later , ;
-
 ! Tear down stack frame
 HOOK: %epilogue cpu ( n -- )
 
-: %epilogue-later ( -- ) \ %epilogue-later , ;
-
-! Store word XT in stack frame
-HOOK: %save-word-xt cpu ( -- )
-
-! Store dispatch branch XT in stack frame
-HOOK: %save-dispatch-xt cpu ( -- )
-
-M: object %save-dispatch-xt %save-word-xt ;
-
 ! Call another word
 HOOK: %call cpu ( word -- )
 
@@ -103,7 +94,7 @@ HOOK: small-enough? cpu ( n -- ? )
 ! Is this structure small enough to be returned in registers?
 HOOK: struct-small-enough? cpu ( heap-size -- ? )
 
-! Do we pass explode value structs?
+! Do we pass value structs by value or hidden reference?
 HOOK: value-structs? cpu ( -- ? )
 
 ! If t, fp parameters are shadowed by dummy int parameters
@@ -158,12 +149,6 @@ M: stack-params param-reg drop ;
 
 M: stack-params param-regs drop f ;
 
-GENERIC: v>operand ( obj -- operand )
-
-M: integer v>operand tag-fixnum ;
-
-M: f v>operand drop \ f tag-number ;
-
 M: object load-literal v>operand load-indirect ;
 
 PREDICATE: small-slot < integer cells small-enough? ;
@@ -207,8 +192,3 @@ HOOK: %write-barrier cpu ( src temp -- )
 
 ! GC check
 HOOK: %gc cpu ( -- )
-
-: operand ( var -- op ) get v>operand ; inline
-
-: unique-operands ( operands quot -- )
-    >r [ operand ] map prune r> each ; inline
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index dc891a8178..a16beed09c 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -20,8 +20,6 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 temp-reg-1 EAX ;
 M: x86.32 temp-reg-2 ECX ;
 
-M: temp-reg v>operand drop EBX ;
-
 M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
 
 M: x86.32 %alien-invoke (CALL) rel-dlsym ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 5bcd733eaa..9ecd3436bb 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -15,8 +15,6 @@ M: x86.64 stack-reg RSP ;
 M: x86.64 temp-reg-1 RAX ;
 M: x86.64 temp-reg-2 RCX ;
 
-M: temp-reg v>operand drop RBX ;
-
 M: int-regs return-reg drop RAX ;
 M: int-regs vregs drop { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } ;
 M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor
index d48153e1b6..2c38a99833 100644
--- a/basis/cpu/x86/allot/allot.factor
+++ b/basis/cpu/x86/allot/allot.factor
@@ -7,118 +7,6 @@ compiler.generator.registers system layouts alien locals
 compiler.constants ;
 IN: cpu.x86.allot
 
-: allot-reg ( -- reg )
-    #! We temporarily use the datastack register, since it won't
-    #! be accessed inside the quotation given to %allot in any
-    #! case.
-    ds-reg ;
-
-: (object@) ( n -- operand ) allot-reg swap [+] ;
-
-: object@ ( n -- operand ) cells (object@) ;
-
-: load-zone-ptr ( reg -- )
-    #! Load pointer to start of zone array
-    0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
-
-: load-allot-ptr ( -- )
-    allot-reg load-zone-ptr
-    allot-reg PUSH
-    allot-reg dup cell [+] MOV ;
-
-: inc-allot-ptr ( n -- )
-    allot-reg POP
-    allot-reg cell [+] swap 8 align ADD ;
-
-M: x86 %gc ( -- )
-    "end" define-label
-    temp-reg-1 load-zone-ptr
-    temp-reg-2 temp-reg-1 cell [+] MOV
-    temp-reg-2 1024 ADD
-    temp-reg-1 temp-reg-1 3 cells [+] MOV
-    temp-reg-2 temp-reg-1 CMP
-    "end" get JLE
-    0 frame-required
-    %prepare-alien-invoke
-    "minor_gc" f %alien-invoke
-    "end" resolve-label ;
-
-: store-header ( header -- )
-    0 object@ swap type-number tag-fixnum MOV ;
-
-: %allot ( header size quot -- )
-    allot-reg PUSH
-    swap >r >r
-    load-allot-ptr
-    store-header
-    r> call
-    r> inc-allot-ptr
-    allot-reg POP ; inline
-
-: %store-tagged ( reg tag -- )
-    >r dup fresh-object v>operand r>
-    allot-reg swap tag-number OR
-    allot-reg MOV ;
-
-M: x86 %box-float ( dst src -- )
-    #! Only called by pentium4 backend, uses SSE2 instruction
-    #! dest is a loc or a vreg
-    float 16 [
-        8 (object@) swap v>operand MOVSD
-        float %store-tagged
-    ] %allot ;
-
-: %allot-bignum-signed-1 ( outreg inreg -- )
-    #! on entry, inreg is a signed 32-bit quantity
-    #! exits with tagged ptr to bignum in outreg
-    #! 1 cell header, 1 cell length, 1 cell sign, + digits
-    #! length is the # of digits + sign
-    [
-        { "end" "nonzero" "positive" "store" }
-        [ define-label ] each
-        dup v>operand 0 CMP ! is it zero?
-        "nonzero" get JNE
-        0 >bignum pick load-literal ! this is our result
-        "end" get JMP
-        "nonzero" resolve-label
-        bignum 4 cells [
-            ! Write length
-            1 object@ 2 v>operand MOV
-            ! Test sign
-            dup v>operand 0 CMP
-            "positive" get JGE
-            2 object@ 1 MOV ! negative sign
-            dup v>operand NEG
-            "store" get JMP
-            "positive" resolve-label
-            2 object@ 0 MOV ! positive sign
-            "store" resolve-label
-            3 object@ swap v>operand MOV
-            ! Store tagged ptr in reg
-            bignum %store-tagged
-        ] %allot
-        "end" resolve-label
-    ] with-scope ;
-
-M: x86 %box-alien ( dst src -- )
-    [
-        { "end" "f" } [ define-label ] each
-        dup v>operand 0 CMP
-        "f" get JE
-        alien 4 cells [
-            1 object@ f v>operand MOV
-            2 object@ f v>operand MOV
-            ! Store src in alien-offset slot
-            3 object@ swap v>operand MOV
-            ! Store tagged ptr in dst
-            dup object %store-tagged
-        ] %allot
-        "end" get JMP
-        "f" resolve-label
-        f [ v>operand ] bi@ MOV
-        "end" resolve-label
-    ] with-scope ;
-
 M:: x86 %write-barrier ( src temp -- )
     #! Mark the card pointed to by vreg.
     ! Mark the card
@@ -131,24 +19,86 @@ M:: x86 %write-barrier ( src temp -- )
     "decks_offset" f temp %alien-global
     temp temp [+] card-mark <byte> MOV ;
 
-! : load-zone-ptr ( reg -- )
-!     #! Load pointer to start of zone array
-!     0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
-! 
-! : load-allot-ptr ( temp -- )
-!     [ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
-! 
-! : inc-allot-ptr ( n temp -- )
-!     [ POP ] [ cell [+] swap 8 align ADD ] bi ;
-! 
-! : store-header ( temp type -- )
-!     [ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
-! 
-! : store-tagged ( dst temp tag -- )
-!     dupd tag-number OR MOV ;
-! 
-! M:: x86 %allot ( dst size type tag temp -- )
-!     temp load-allot-ptr
-!     temp type store-header
-!     temp size inc-allot-ptr
-!     dst temp store-tagged ;
+: load-zone-ptr ( reg -- )
+    #! Load pointer to start of zone array
+    0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+
+: load-allot-ptr ( temp -- )
+    [ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
+
+: inc-allot-ptr ( n temp -- )
+    [ POP ] [ cell [+] swap 8 align ADD ] bi ;
+
+: store-header ( temp type -- )
+    [ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
+
+: store-tagged ( dst temp tag -- )
+    dupd tag-number OR MOV ;
+
+M:: x86 %allot ( dst size type tag temp -- )
+    temp load-allot-ptr
+    temp type store-header
+    temp size inc-allot-ptr
+    dst temp store-tagged ;
+
+M: x86 %gc ( -- )
+    "end" define-label
+    temp-reg-1 load-zone-ptr
+    temp-reg-2 temp-reg-1 cell [+] MOV
+    temp-reg-2 1024 ADD
+    temp-reg-1 temp-reg-1 3 cells [+] MOV
+    temp-reg-2 temp-reg-1 CMP
+    "end" get JLE
+    %prepare-alien-invoke
+    "minor_gc" f %alien-invoke
+    "end" resolve-label ;
+
+: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
+
+:: %allot-bignum-signed-1 ( dst src temp -- )
+    #! on entry, inreg is a signed 32-bit quantity
+    #! exits with tagged ptr to bignum in outreg
+    #! 1 cell header, 1 cell length, 1 cell sign, + digits
+    #! length is the # of digits + sign
+    [
+        { "end" "nonzero" "positive" "store" } [ define-label ] each
+        src 0 CMP ! is it zero?
+        "nonzero" get JNE
+        ! Use cached zero value
+        0 >bignum dst load-indirect
+        "end" get JMP
+        "nonzero" resolve-label
+        ! Allocate a bignum
+        dst 4 cells bignum bignum temp %allot
+        ! Write length
+        dst 1 bignum@ 2 MOV
+        ! Test sign
+        src 0 CMP
+        "positive" get JGE
+        dst 2 bignum@ 1 MOV ! negative sign
+        src NEG
+        "store" get JMP
+        "positive" resolve-label
+        dst 2 bignum@ 0 MOV ! positive sign
+        "store" resolve-label
+        dst 3 bignum@ src MOV
+        "end" resolve-label
+    ] with-scope ;
+
+: alien@ ( reg n -- op ) cells object tag-number - [+] ;
+
+M:: x86 %box-alien ( dst src temp -- )
+    [
+        { "end" "f" } [ define-label ] each
+        src 0 CMP
+        "f" get JE
+        dst 4 cells alien object temp %allot
+        dst 1 alien@ \ f tag-number MOV
+        dst 2 alien@ \ f tag-number MOV
+        ! Store src in alien-offset slot
+        dst 3 alien@ src MOV
+        "end" get JMP
+        "f" resolve-label
+        \ f tag-number MOV
+        "end" resolve-label
+    ] with-scope ;
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 31ead4a005..0ebc696323 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -22,8 +22,10 @@ HOOK: stack-reg cpu ( -- reg )
 
 : reg-stack ( n reg -- op ) swap cells neg [+] ;
 
-M: ds-loc v>operand n>> ds-reg reg-stack ;
-M: rs-loc v>operand n>> rs-reg reg-stack ;
+GENERIC: loc>operand ( loc -- operand )
+
+M: ds-loc loc>operand n>> ds-reg reg-stack ;
+M: rs-loc loc>operand n>> rs-reg reg-stack ;
 
 M: int-regs %save-param-reg drop >r stack@ r> MOV ;
 M: int-regs %load-param-reg drop swap stack@ MOV ;
@@ -49,7 +51,11 @@ HOOK: fixnum>slot@ cpu ( op -- )
 
 HOOK: prepare-division cpu ( -- )
 
-M: immediate load-literal v>operand swap v>operand MOV ;
+M: f load-literal
+    \ f tag-number MOV drop ;
+
+M: fixnum load-literal
+    swap tag-fixnum MOV ;
 
 : align-stack ( n -- n' )
     os macosx? cpu x86.64? or [ 16 align ] when ;
@@ -57,16 +63,16 @@ M: immediate load-literal v>operand swap v>operand MOV ;
 M: x86 stack-frame-size ( n -- i )
     3 cells + align-stack ;
 
-M: x86 %save-word-xt ( -- )
-    temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
+M: x86 %save-word-xt ( -- ) ;
 
 : decr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
 
 M: x86 %prologue ( n -- )
-    dup PUSH
-    temp-reg v>operand PUSH
-    3 cells - decr-stack-reg ;
+    temp-reg-1 0 MOV rc-absolute-cell rel-this
+    dup cell + PUSH
+    temp-reg-1 PUSH
+    stack-reg swap 2 cells - SUB ;
 
 : incr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
@@ -79,21 +85,21 @@ M: x86 %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    "stack_chain" f temp-reg v>operand %alien-global
-    temp-reg v>operand [] stack-reg MOV
-    temp-reg v>operand [] cell SUB
-    temp-reg v>operand 2 cells [+] ds-reg MOV
-    temp-reg v>operand 3 cells [+] rs-reg MOV ;
+    "stack_chain" f temp-reg-1 %alien-global
+    temp-reg-1 [] stack-reg MOV
+    temp-reg-1 [] cell SUB
+    temp-reg-1 2 cells [+] ds-reg MOV
+    temp-reg-1 3 cells [+] rs-reg MOV ;
 
 M: x86 %call ( label -- ) CALL ;
 
 M: x86 %jump-label ( label -- ) JMP ;
 
-M: x86 %jump-f ( label -- )
-    "flag" operand f v>operand CMP JE ;
+M: x86 %jump-f ( label vreg -- )
+    \ f tag-number CMP JE ;
 
-M: x86 %jump-t ( label -- )
-    "flag" operand f v>operand CMP JNE ;
+M: x86 %jump-t ( label vreg -- )
+    \ f tag-number CMP JNE ;
 
 : code-alignment ( -- n )
     building get length dup cell align swap - ;
@@ -126,14 +132,9 @@ M: x86 %dispatch ( -- )
 M: x86 %dispatch-label ( word -- )
     0 cell, rc-absolute-cell rel-word ;
 
-M: x86 %unbox-float ( dst src -- )
-    [ v>operand ] bi@ float-offset [+] MOVSD ;
+M: x86 %peek loc>operand MOV ;
 
-M: x86 %peek [ v>operand ] bi@ MOV ;
-
-M: x86 %replace swap %peek ;
-
-M: x86 %copy [ v>operand ] bi@ MOV ;
+M: x86 %replace loc>operand swap MOV ;
 
 : (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
@@ -158,13 +159,13 @@ M: x86 %return ( -- ) 0 %unwind ;
 
 ! Alien intrinsics
 M: x86 %unbox-byte-array ( dst src -- )
-    [ v>operand ] bi@ byte-array-offset [+] LEA ;
+    byte-array-offset [+] LEA ;
 
 M: x86 %unbox-alien ( dst src -- )
-    [ v>operand ] bi@ alien-offset [+] MOV ;
+    alien-offset [+] MOV ;
 
 M: x86 %unbox-f ( dst src -- )
-    drop v>operand 0 MOV ;
+    drop 0 MOV ;
 
 M: x86 %unbox-any-c-ptr ( dst src -- )
     { "is-byte-array" "end" "start" } [ define-label ] each
@@ -173,11 +174,11 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
     ds-reg 0 MOV
     ! Object is stored in ds-reg
     rs-reg PUSH
-    rs-reg swap v>operand MOV
+    rs-reg swap MOV
     ! We come back here with displaced aliens
     "start" resolve-label
     ! Is the object f?
-    rs-reg f v>operand CMP
+    rs-reg \ f tag-number CMP
     "end" get JE
     ! Is the object an alien?
     rs-reg header-offset [+] alien type-number tag-fixnum CMP
@@ -194,7 +195,7 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
     ds-reg byte-array-offset ADD
     "end" resolve-label
     ! Done, store address in destination register
-    v>operand ds-reg MOV
+    ds-reg MOV
     ! Restore rs-reg
     rs-reg POP
     ! Restore ds-reg
diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor
index a0cfd1b01e..3ef25a9075 100644
--- a/basis/cpu/x86/intrinsics/intrinsics.factor
+++ b/basis/cpu/x86/intrinsics/intrinsics.factor
@@ -1,103 +1,74 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors arrays cpu.x86.assembler
-cpu.x86.allot cpu.x86.architecture cpu.architecture kernel
-kernel.private math math.private namespaces quotations sequences
-words generic byte-arrays hashtables hashtables.private
-sequences.private sbufs sbufs.private
-vectors vectors.private layouts system strings.private
-slots.private 
-compiler.constants
-compiler.intrinsics
-compiler.generator
-compiler.generator.fixup
-compiler.generator.registers ;
+USING: accessors arrays byte-arrays alien.accessors
+compiler.backend kernel kernel.private math memory namespaces
+make sequences words system layouts combinators math.order
+math.private alien alien.c-types slots.private cpu.x86.assembler
+cpu.x86.assembler.private locals compiler.backend
+compiler.codegen.fixup compiler.constants compiler.intrinsics
+compiler.cfg.builder compiler.cfg.registers compiler.cfg.stacks
+compiler.cfg.templates compiler.codegen ;
 IN: cpu.x86.intrinsics
 
 ! Type checks
 \ tag [
     "in" operand tag-mask get AND
     "in" operand %tag-fixnum
-] H{
-    { +input+ { { f "in" } } }
-    { +output+ { "in" } }
+] T{ template
+    { input { { f "in" } } }
+    { output { "in" } }
 } define-intrinsic
 
 ! Slots
-: %slot-literal-known-tag ( -- op )
-    "obj" operand
-    "n" get cells
-    "obj" get operand-tag - [+] ;
-
-: %slot-literal-any-tag ( -- op )
-    "obj" operand %untag
-    "obj" operand "n" get cells [+] ;
-
-: %slot-any ( -- op )
-    "obj" operand %untag
-    "n" operand fixnum>slot@
-    "obj" operand "n" operand [+] ;
-
 \ slot {
     ! Slot number is literal and the tag is known
     {
-        [ "val" operand %slot-literal-known-tag MOV ] H{
-            { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "val" } } }
-            { +output+ { "val" } }
+        [ "val" operand %slot-literal-known-tag MOV ] T{ template
+            { input { { f "obj" known-tag } { small-slot "n" } } }
+            { scratch { { f "val" } } }
+            { output { "val" } }
         }
     }
     ! Slot number is literal
     {
-        [ "obj" operand %slot-literal-any-tag MOV ] H{
-            { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
-            { +output+ { "obj" } }
+        [ "obj" operand %slot-literal-any-tag MOV ] T{ template
+            { input { { f "obj" } { small-slot "n" } } }
+            { output { "obj" } }
         }
     }
     ! Slot number in a register
     {
-        [ "obj" operand %slot-any MOV ] H{
-            { +input+ { { f "obj" } { f "n" } } }
-            { +output+ { "obj" } }
-            { +clobber+ { "n" } }
+        [ "obj" operand %slot-any MOV ] T{ template
+            { input { { f "obj" } { f "n" } } }
+            { output { "obj" } }
+            { clobber { "n" } }
         }
     }
 } define-intrinsics
 
-: generate-write-barrier ( -- )
-    #! Mark the card pointed to by vreg.
-    "val" get operand-immediate? "obj" get fresh-object? or [
-        ! Mark the card
-        "obj" operand card-bits SHR
-        "cards_offset" f temp-reg v>operand %alien-global
-        temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
-
-        ! Mark the card deck
-        "obj" operand deck-bits card-bits - SHR
-        "decks_offset" f temp-reg v>operand %alien-global
-        temp-reg v>operand "obj" operand [+] card-mark <byte> MOV
-    ] unless ;
-
-\ set-slot {
+\ (set-slot) {
     ! Slot number is literal and the tag is known
     {
-        [ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] H{
-            { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
-            { +clobber+ { "obj" } }
+        [ %slot-literal-known-tag "val" operand MOV ] T{ template
+            { input { { f "val" } { f "obj" known-tag } { small-slot "n" } } }
+            { scratch { { f "scratch" } } }
+            { clobber { "obj" } }
         }
     }
     ! Slot number is literal
     {
-        [ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] H{
-            { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
-            { +clobber+ { "obj" } }
+        [ %slot-literal-any-tag "val" operand MOV ] T{ template
+            { input { { f "val" } { f "obj" } { small-slot "n" } } }
+            { scratch { { f "scratch" } } }
+            { clobber { "obj" } }
         }
     }
     ! Slot number in a register
     {
-        [ %slot-any "val" operand MOV generate-write-barrier ] H{
-            { +input+ { { f "val" } { f "obj" } { f "n" } } }
-            { +clobber+ { "obj" "n" } }
+        [ %slot-any "val" operand MOV ] T{ template
+            { input { { f "val" } { f "obj" } { f "n" } } }
+            { scratch { { f "scratch" } } }
+            { clobber { "obj" "n" } }
         }
     }
 } define-intrinsics
@@ -117,15 +88,15 @@ IN: cpu.x86.intrinsics
     >r [ "x" operand "y" operand ] swap suffix r> 2array ;
 
 : fixnum-value-op ( op -- pair )
-    H{
-        { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
-        { +output+ { "x" } }
+    T{ template
+        { input { { f "x" } { small-tagged "y" } } }
+        { output { "x" } }
     } fixnum-op ;
 
 : fixnum-register-op ( op -- pair )
-    H{
-        { +input+ { { f "x" } { f "y" } } }
-        { +output+ { "x" } }
+    T{ template
+        { input { { f "x" } { f "y" } } }
+        { output { "x" } }
     } fixnum-op ;
 
 : define-fixnum-op ( word op -- )
@@ -145,28 +116,28 @@ IN: cpu.x86.intrinsics
 \ fixnum-bitnot [
     "x" operand NOT
     "x" operand tag-mask get XOR
-] H{
-    { +input+ { { f "x" } } }
-    { +output+ { "x" } }
+] T{ template
+    { input { { f "x" } } }
+    { output { "x" } }
 } define-intrinsic
 
 \ fixnum*fast {
     {
         [
             "x" operand "y" get IMUL2
-        ] H{
-            { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
-            { +output+ { "x" } }
+        ] T{ template
+            { input { { f "x" } { [ small-tagged? ] "y" } } }
+            { output { "x" } }
         }
     } {
         [
             "out" operand "x" operand MOV
             "out" operand %untag-fixnum
             "y" operand "out" operand IMUL2
-        ] H{
-            { +input+ { { f "x" } { f "y" } } }
-            { +scratch+ { { f "out" } } }
-            { +output+ { "out" } }
+        ] T{ template
+            { input { { f "x" } { f "y" } } }
+            { scratch { { f "out" } } }
+            { output { "out" } }
         }
     }
 } define-intrinsics
@@ -179,9 +150,9 @@ IN: cpu.x86.intrinsics
     dup 0 < [ neg SAR ] [ SHL ] if
     ! Mask off low bits
     "x" operand %untag
-] H{
-    { +input+ { { f "x" } { [ ] "y" } } }
-    { +output+ { "x" } }
+] T{ template
+    { input { { f "x" } { [ ] "y" } } }
+    { output { "x" } }
 } define-intrinsic
 
 : overflow-check ( word -- )
@@ -194,15 +165,16 @@ IN: cpu.x86.intrinsics
     ! There was an overflow. Recompute the original operand.
     { "y" "x" } %untag-fixnums
     "x" operand "y" operand rot execute
-    "z" get "x" get %allot-bignum-signed-1
+    "z" operand "x" operand "y" operand %allot-bignum-signed-1
     "end" resolve-label ; inline
 
 : overflow-template ( word insn -- )
-    [ overflow-check ] curry H{
-        { +input+ { { f "x" } { f "y" } } }
-        { +scratch+ { { f "z" } } }
-        { +output+ { "z" } }
-        { +clobber+ { "x" "y" } }
+    [ overflow-check ] curry T{ template
+        { input { { f "x" } { f "y" } } }
+        { scratch { { f "z" } } }
+        { output { "z" } }
+        { clobber { "x" "y" } }
+        { gc t }
     } define-intrinsic ;
 
 \ fixnum+ \ ADD overflow-template
@@ -222,21 +194,23 @@ IN: cpu.x86.intrinsics
     2array define-if-intrinsics ;
 
 {
-    { fixnum< JGE }
-    { fixnum<= JG }
-    { fixnum> JLE }
-    { fixnum>= JL }
-    { eq? JNE }
+    { fixnum< JL }
+    { fixnum<= JLE }
+    { fixnum> JG }
+    { fixnum>= JGE }
+    { eq? JE }
 } [
     first2 define-fixnum-jump
 ] each
 
 \ fixnum>bignum [
     "x" operand %untag-fixnum
-    "x" get dup %allot-bignum-signed-1
-] H{
-    { +input+ { { f "x" } } }
-    { +output+ { "x" } }
+    "x" operand dup "scratch" operand %allot-bignum-signed-1
+] T{ template
+    { input { { f "x" } } }
+    { scratch { { f "scratch" } } }
+    { output { "x" } }
+    { gc t }
 } define-intrinsic
 
 \ bignum>fixnum [
@@ -247,7 +221,7 @@ IN: cpu.x86.intrinsics
     "y" operand "x" operand cell [+] MOV
      ! if the length is 1, its just the sign and nothing else,
      ! so output 0
-    "y" operand 1 v>operand CMP
+    "y" operand 1 tag-fixnum CMP
     "nonzero" get JNE
     "y" operand 0 MOV
     "end" get JMP
@@ -263,11 +237,11 @@ IN: cpu.x86.intrinsics
     "positive" resolve-label
     "y" operand 3 SHL
     "end" resolve-label
-] H{
-    { +input+ { { f "x" } } }
-    { +scratch+ { { f "y" } } }
-    { +clobber+ { "x" } }
-    { +output+ { "y" } }
+] T{ template
+    { input { { f "x" } } }
+    { scratch { { f "y" } } }
+    { clobber { "x" } }
+    { output { "y" } }
 } define-intrinsic
 
 ! User environment
@@ -279,96 +253,18 @@ IN: cpu.x86.intrinsics
 
 \ getenv [
     %userenv  "n" operand dup [] MOV
-] H{
-    { +input+ { { f "n" } } }
-    { +scratch+ { { f "x" } } }
-    { +output+ { "n" } }
+] T{ template
+    { input { { f "n" } } }
+    { scratch { { f "x" } } }
+    { output { "n" } }
 } define-intrinsic
 
 \ setenv [
     %userenv  "n" operand [] "val" operand MOV
-] H{
-    { +input+ { { f "val" } { f "n" } } }
-    { +scratch+ { { f "x" } } }
-    { +clobber+ { "n" } }
-} define-intrinsic
-
-\ (tuple) [
-    tuple "layout" get size>> 2 + cells [
-        ! Store layout
-        "layout" get "scratch" get load-literal
-        1 object@ "scratch" operand MOV
-        ! Store tagged ptr in reg
-        "tuple" get tuple %store-tagged
-    ] %allot
-] H{
-    { +input+ { { [ ] "layout" } } }
-    { +scratch+ { { f "tuple" } { f "scratch" } } }
-    { +output+ { "tuple" } }
-} define-intrinsic
-
-\ (array) [
-    array "n" get 2 + cells [
-        ! Store length
-        1 object@ "n" operand MOV
-        ! Store tagged ptr in reg
-        "array" get object %store-tagged
-    ] %allot
-] H{
-    { +input+ { { [ ] "n" } } }
-    { +scratch+ { { f "array" } } }
-    { +output+ { "array" } }
-} define-intrinsic
-
-\ (byte-array) [
-    byte-array "n" get 2 cells + [
-        ! Store length
-        1 object@ "n" operand MOV
-        ! Store tagged ptr in reg
-        "array" get object %store-tagged
-    ] %allot
-] H{
-    { +input+ { { [ ] "n" } } }
-    { +scratch+ { { f "array" } } }
-    { +output+ { "array" } }
-} define-intrinsic
-
-\ <ratio> [
-    ratio 3 cells [
-        1 object@ "numerator" operand MOV
-        2 object@ "denominator" operand MOV
-        ! Store tagged ptr in reg
-        "ratio" get ratio %store-tagged
-    ] %allot
-] H{
-    { +input+ { { f "numerator" } { f "denominator" } } }
-    { +scratch+ { { f "ratio" } } }
-    { +output+ { "ratio" } }
-} define-intrinsic
-
-\ <complex> [
-    complex 3 cells [
-        1 object@ "real" operand MOV
-        2 object@ "imaginary" operand MOV
-        ! Store tagged ptr in reg
-        "complex" get complex %store-tagged
-    ] %allot
-] H{
-    { +input+ { { f "real" } { f "imaginary" } } }
-    { +scratch+ { { f "complex" } } }
-    { +output+ { "complex" } }
-} define-intrinsic
-
-\ <wrapper> [
-    wrapper 2 cells [
-        1 object@ "obj" operand MOV
-        ! Store tagged ptr in reg
-        "wrapper" get object %store-tagged
-    ] %allot
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "wrapper" } } }
-    { +output+ { "wrapper" } }
+] T{ template
+    { input { { f "val" } { f "n" } } }
+    { scratch { { f "x" } } }
+    { clobber { "n" } }
 } define-intrinsic
 
 ! Alien intrinsics
@@ -385,14 +281,14 @@ IN: cpu.x86.intrinsics
     small-reg POP ; inline
 
 : alien-integer-get-template
-    H{
-        { +input+ {
+    T{ template
+        { input {
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { f "value" } } }
-        { +output+ { "value" } }
-        { +clobber+ { "offset" } }
+        { scratch { { f "value" } } }
+        { output { "value" } }
+        { clobber { "offset" } }
     } ;
 
 : define-getter ( word quot reg -- )
@@ -414,13 +310,13 @@ IN: cpu.x86.intrinsics
     small-reg POP ; inline
 
 : alien-integer-set-template
-    H{
-        { +input+ {
+    T{ template
+        { input {
             { f "value" fixnum }
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +clobber+ { "value" "offset" } }
+        { clobber { "value" "offset" } }
     } ;
 
 : define-setter ( word reg -- )
@@ -443,23 +339,23 @@ IN: cpu.x86.intrinsics
 
 \ alien-cell [
     "value" operand [ MOV ] %alien-accessor
-] H{
-    { +input+ {
+] T{ template
+    { input {
         { unboxed-c-ptr "alien" c-ptr }
         { f "offset" fixnum }
     } }
-    { +scratch+ { { unboxed-alien "value" } } }
-    { +output+ { "value" } }
-    { +clobber+ { "offset" } }
+    { scratch { { unboxed-alien "value" } } }
+    { output { "value" } }
+    { clobber { "offset" } }
 } define-intrinsic
 
 \ set-alien-cell [
     "value" operand [ swap MOV ] %alien-accessor
-] H{
-    { +input+ {
+] T{ template
+    { input {
         { unboxed-c-ptr "value" pinned-c-ptr }
         { unboxed-c-ptr "alien" c-ptr }
         { f "offset" fixnum }
     } }
-    { +clobber+ { "offset" } }
+    { clobber { "offset" } }
 } define-intrinsic
diff --git a/basis/cpu/x86/sse2/sse2.factor b/basis/cpu/x86/sse2/sse2.factor
index 3e232b518d..81108aa55a 100644
--- a/basis/cpu/x86/sse2/sse2.factor
+++ b/basis/cpu/x86/sse2/sse2.factor
@@ -8,7 +8,14 @@ cpu.architecture math.floats.private layouts quotations
 system ;
 IN: cpu.x86.sse2
 
-M: x86 %copy-float [ v>operand ] bi@ MOVSD ;
+M: x86 %copy-float MOVSD ;
+
+M:: x86 %box-float ( dst src temp -- )
+    dst 16 float float temp %allot
+    dst 8 float tag-number - [+] src MOVSD ;
+
+M: x86 %unbox-float ( dst src -- )
+    float-offset [+] MOVSD ;
 
 : define-float-op ( word op -- )
     [ "x" operand "y" operand ] swap suffix H{
diff --git a/unfinished/compiler/backend/backend.factor b/unfinished/compiler/backend/backend.factor
deleted file mode 100644
index 2a516c6ec4..0000000000
--- a/unfinished/compiler/backend/backend.factor
+++ /dev/null
@@ -1,189 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs arrays generic kernel kernel.private
-math memory namespaces make sequences layouts system hashtables
-classes alien byte-arrays combinators words ;
-IN: compiler.backend
-
-! Labels
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-: define-label ( name -- ) <label> swap set ;
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
-! Mapping from register class to machine registers
-HOOK: machine-registers cpu ( -- assoc )
-
-! A pseudo-register class for parameters spilled on the stack
-SINGLETON: stack-params
-
-! Return values of this class go here
-GENERIC: return-reg ( register-class -- reg )
-
-! Sequence of registers used for parameter passing in class
-GENERIC: param-regs ( register-class -- regs )
-
-GENERIC: param-reg ( n register-class -- reg )
-
-M: object param-reg param-regs nth ;
-
-! Load a literal (immediate or indirect)
-GENERIC# load-literal 1 ( obj reg -- )
-
-HOOK: load-indirect cpu ( obj reg -- )
-
-HOOK: stack-frame-size cpu ( frame-size -- n )
-
-! Set up caller stack frame
-HOOK: %prologue cpu ( n -- )
-
-! Tear down stack frame
-HOOK: %epilogue cpu ( n -- )
-
-! Call another word
-HOOK: %call cpu ( word -- )
-
-! Local jump for branches
-HOOK: %jump-label cpu ( label -- )
-
-! Test if vreg is 'f' or not
-HOOK: %jump-f cpu ( label reg -- )
-
-! Test if vreg is 't' or not
-HOOK: %jump-t cpu ( label reg -- )
-
-HOOK: %dispatch cpu ( -- )
-
-HOOK: %dispatch-label cpu ( word -- )
-
-! Return to caller
-HOOK: %return cpu ( -- )
-
-! Change datastack height
-HOOK: %inc-d cpu ( n -- )
-
-! Change callstack height
-HOOK: %inc-r cpu ( n -- )
-
-! Load stack into vreg
-HOOK: %peek cpu ( reg loc -- )
-
-! Store vreg to stack
-HOOK: %replace cpu ( reg loc -- )
-
-! Copy values between vregs
-HOOK: %copy cpu ( dst src -- )
-HOOK: %copy-float cpu ( dst src -- )
-
-! Box and unbox floats
-HOOK: %unbox-float cpu ( dst src -- )
-HOOK: %box-float cpu ( dst src -- )
-
-! FFI stuff
-
-! Is this integer small enough to appear in value template
-! slots?
-HOOK: small-enough? cpu ( n -- ? )
-
-! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? cpu ( heap-size -- ? )
-
-! Do we pass explode value structs?
-HOOK: value-structs? cpu ( -- ? )
-
-! If t, fp parameters are shadowed by dummy int parameters
-HOOK: fp-shadows-int? cpu ( -- ? )
-
-HOOK: %prepare-unbox cpu ( -- )
-
-HOOK: %unbox cpu ( n reg-class func -- )
-
-HOOK: %unbox-long-long cpu ( n func -- )
-
-HOOK: %unbox-small-struct cpu ( c-type -- )
-
-HOOK: %unbox-large-struct cpu ( n c-type -- )
-
-HOOK: %box cpu ( n reg-class func -- )
-
-HOOK: %box-long-long cpu ( n func -- )
-
-HOOK: %prepare-box-struct cpu ( size -- )
-
-HOOK: %box-small-struct cpu ( c-type -- )
-
-HOOK: %box-large-struct cpu ( n c-type -- )
-
-GENERIC: %save-param-reg ( stack reg reg-class -- )
-
-GENERIC: %load-param-reg ( stack reg reg-class -- )
-
-HOOK: %prepare-alien-invoke cpu ( -- )
-
-HOOK: %prepare-var-args cpu ( -- )
-
-M: object %prepare-var-args ;
-
-HOOK: %alien-invoke cpu ( function library -- )
-
-HOOK: %cleanup cpu ( alien-node -- )
-
-HOOK: %alien-callback cpu ( quot -- )
-
-HOOK: %callback-value cpu ( ctype -- )
-
-! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind cpu ( n -- )
-
-HOOK: %prepare-alien-indirect cpu ( -- )
-
-HOOK: %alien-indirect cpu ( -- )
-
-M: stack-params param-reg drop ;
-
-M: stack-params param-regs drop f ;
-
-M: object load-literal load-indirect ;
-
-PREDICATE: small-slot < integer cells small-enough? ;
-
-PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
-
-: if-small-struct ( n size true false -- ? )
-    [ over not over struct-small-enough? and ] 2dip
-    [ [ nip ] prepose ] dip if ;
-    inline
-
-: %unbox-struct ( n c-type -- )
-    [
-        %unbox-small-struct
-    ] [
-        %unbox-large-struct
-    ] if-small-struct ;
-
-: %box-struct ( n c-type -- )
-    [
-        %box-small-struct
-    ] [
-        %box-large-struct
-    ] if-small-struct ;
-
-! Alien accessors
-HOOK: %unbox-byte-array cpu ( dst src -- )
-
-HOOK: %unbox-alien cpu ( dst src -- )
-
-HOOK: %unbox-f cpu ( dst src -- )
-
-HOOK: %unbox-any-c-ptr cpu ( dst src -- )
-
-HOOK: %box-alien cpu ( dst src -- )
-
-! Allocation
-HOOK: %allot cpu ( dst size type tag temp -- )
-
-HOOK: %write-barrier cpu ( src temp -- )
-
-! GC check
-HOOK: %gc cpu ( -- )
diff --git a/unfinished/compiler/backend/x86/32/32.factor b/unfinished/compiler/backend/x86/32/32.factor
deleted file mode 100644
index 73fc81bd00..0000000000
--- a/unfinished/compiler/backend/x86/32/32.factor
+++ /dev/null
@@ -1,318 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays kernel kernel.private math
-namespaces sequences stack-checker.known-words system layouts
-combinators command-line io vocabs.loader accessors init
-compiler compiler.units compiler.constants compiler.codegen
-compiler.cfg.builder compiler.alien compiler.codegen.fixup
-cpu.x86 compiler.backend compiler.backend.x86 ;
-IN: compiler.backend.x86.32
-
-! We implement the FFI for Linux, OS X and Windows all at once.
-! OS X requires that the stack be 16-byte aligned, and we do
-! this on all platforms, sacrificing some stack space for
-! code simplicity.
-
-M: x86.32 machine-registers
-    {
-        { int-regs { EAX ECX EDX EBP EBX } }
-        { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
-    } ;
-
-M: x86.32 ds-reg ESI ;
-M: x86.32 rs-reg EDI ;
-M: x86.32 stack-reg ESP ;
-M: x86.32 stack-save-reg EDX ;
-M: x86.32 temp-reg-1 EAX ;
-M: x86.32 temp-reg-2 ECX ;
-
-M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
-
-M: x86.32 %alien-invoke (CALL) rel-dlsym ;
-
-M: x86.32 struct-small-enough? ( size -- ? )
-    heap-size { 1 2 4 8 } member?
-    os { linux netbsd solaris } member? not and ;
-
-! On x86, parameters are never passed in registers.
-M: int-regs return-reg drop EAX ;
-M: int-regs param-regs drop { } ;
-M: int-regs push-return-reg return-reg PUSH ;
-: load/store-int-return ( n reg-class -- src dst )
-    return-reg stack-reg rot [+] ;
-M: int-regs load-return-reg load/store-int-return MOV ;
-M: int-regs store-return-reg load/store-int-return swap MOV ;
-
-M: float-regs param-regs drop { } ;
-
-: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
-
-M: float-regs push-return-reg
-    stack-reg swap reg-size [ SUB  stack-reg [] ] keep FSTP ;
-
-: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
-
-: load/store-float-return ( n reg-class -- op size )
-    [ stack@ ] [ reg-size ] bi* ;
-M: float-regs load-return-reg load/store-float-return FLD ;
-M: float-regs store-return-reg load/store-float-return FSTP ;
-
-: align-sub ( n -- )
-    dup 16 align swap - ESP swap SUB ;
-
-: align-add ( n -- )
-    16 align ESP swap ADD ;
-
-: with-aligned-stack ( n quot -- )
-    swap dup align-sub slip align-add ; inline
-
-M: x86.32 fixnum>slot@ 1 SHR ;
-
-M: x86.32 prepare-division CDQ ;
-
-M: x86.32 load-indirect
-    0 [] MOV rc-absolute-cell rel-literal ;
-
-M: object %load-param-reg 3drop ;
-
-M: object %save-param-reg 3drop ;
-
-: box@ ( n reg-class -- stack@ )
-    #! Used for callbacks; we want to box the values given to
-    #! us by the C function caller. Computes stack location of
-    #! nth parameter; note that we must go back one more stack
-    #! frame, since %box sets one up to call the one-arg boxer
-    #! function. The size of this stack frame so far depends on
-    #! the reg-class of the boxer's arg.
-    reg-size neg + stack-frame* + 20 + ;
-
-: (%box) ( n reg-class -- )
-    #! If n is f, push the return register onto the stack; we
-    #! are boxing a return value of a C function. If n is an
-    #! integer, push [ESP+n] on the stack; we are boxing a
-    #! parameter being passed to a callback from C.
-    over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
-    push-return-reg ;
-
-M: x86.32 %box ( n reg-class func -- )
-    over reg-size [
-        >r (%box) r> f %alien-invoke
-    ] with-aligned-stack ;
-    
-: (%box-long-long) ( n -- )
-    #! If n is f, push the return registers onto the stack; we
-    #! are boxing a return value of a C function. If n is an
-    #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
-    #! boxing a parameter being passed to a callback from C.
-    [
-        int-regs box@
-        EDX over stack@ MOV
-        EAX swap cell - stack@ MOV 
-    ] when*
-    EDX PUSH
-    EAX PUSH ;
-
-M: x86.32 %box-long-long ( n func -- )
-    8 [
-        [ (%box-long-long) ] [ f %alien-invoke ] bi*
-    ] with-aligned-stack ;
-
-: struct-return@ ( size n -- n )
-    [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
-
-M: x86.32 %box-large-struct ( n c-type -- )
-    ! Compute destination address
-    heap-size
-    [ swap struct-return@ ] keep
-    ECX ESP roll [+] LEA
-    8 [
-        ! Push struct size
-        PUSH
-        ! Push destination address
-        ECX PUSH
-        ! Copy the struct from the C stack
-        "box_value_struct" f %alien-invoke
-    ] with-aligned-stack ;
-
-M: x86.32 %prepare-box-struct ( size -- )
-    ! Compute target address for value struct return
-    EAX ESP rot f struct-return@ [+] LEA
-    ! Store it as the first parameter
-    ESP [] EAX MOV ;
-
-M: x86.32 %box-small-struct ( c-type -- )
-    #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
-    12 [
-        heap-size PUSH
-        EDX PUSH
-        EAX PUSH
-        "box_small_struct" f %alien-invoke
-    ] with-aligned-stack ;
-
-M: x86.32 %prepare-unbox ( -- )
-    #! Move top of data stack to EAX.
-    EAX ESI [] MOV
-    ESI 4 SUB ;
-
-: (%unbox) ( func -- )
-    4 [
-        ! Push parameter
-        EAX PUSH
-        ! Call the unboxer
-        f %alien-invoke
-    ] with-aligned-stack ;
-
-M: x86.32 %unbox ( n reg-class func -- )
-    #! The value being unboxed must already be in EAX.
-    #! If n is f, we're unboxing a return value about to be
-    #! returned by the callback. Otherwise, we're unboxing
-    #! a parameter to a C function about to be called.
-    (%unbox)
-    ! Store the return value on the C stack
-    over [ store-return-reg ] [ 2drop ] if ;
-
-M: x86.32 %unbox-long-long ( n func -- )
-    (%unbox)
-    ! Store the return value on the C stack
-    [
-        dup stack@ EAX MOV
-        cell + stack@ EDX MOV
-    ] when* ;
-
-: %unbox-struct-1 ( -- )
-    #! Alien must be in EAX.
-    4 [
-        EAX PUSH
-        "alien_offset" f %alien-invoke
-        ! Load first cell
-        EAX EAX [] MOV
-    ] with-aligned-stack ;
-
-: %unbox-struct-2 ( -- )
-    #! Alien must be in EAX.
-    4 [
-        EAX PUSH
-        "alien_offset" f %alien-invoke
-        ! Load second cell
-        EDX EAX 4 [+] MOV
-        ! Load first cell
-        EAX EAX [] MOV
-    ] with-aligned-stack ;
-
-M: x86 %unbox-small-struct ( size -- )
-    #! Alien must be in EAX.
-    heap-size cell align cell /i {
-        { 1 [ %unbox-struct-1 ] }
-        { 2 [ %unbox-struct-2 ] }
-    } case ;
-
-M: x86.32 %unbox-large-struct ( n c-type -- )
-    #! Alien must be in EAX.
-    heap-size
-    ! Compute destination address
-    ECX ESP roll [+] LEA
-    12 [
-        ! Push struct size
-        PUSH
-        ! Push destination address
-        ECX PUSH
-        ! Push source address
-        EAX PUSH
-        ! Copy the struct to the stack
-        "to_value_struct" f %alien-invoke
-    ] with-aligned-stack ;
-
-M: x86.32 %prepare-alien-indirect ( -- )
-    "unbox_alien" f %alien-invoke
-    cell temp@ EAX MOV ;
-
-M: x86.32 %alien-indirect ( -- )
-    cell temp@ CALL ;
-
-M: x86.32 %alien-callback ( quot -- )
-    4 [
-        EAX load-indirect
-        EAX PUSH
-        "c_to_factor" f %alien-invoke
-    ] with-aligned-stack ;
-
-M: x86.32 %callback-value ( ctype -- )
-    ! Align C stack
-    ESP 12 SUB
-    ! Save top of data stack
-    %prepare-unbox
-    EAX PUSH
-    ! Restore data/call/retain stacks
-    "unnest_stacks" f %alien-invoke
-    ! Place top of data stack in EAX
-    EAX POP
-    ! Restore C stack
-    ESP 12 ADD
-    ! Unbox EAX
-    unbox-return ;
-
-M: x86.32 %cleanup ( alien-node -- )
-    #! a) If we just called an stdcall function in Windows, it
-    #! cleaned up the stack frame for us. But we don't want that
-    #! so we 'undo' the cleanup since we do that in %epilogue.
-    #! b) If we just called a function returning a struct, we
-    #! have to fix ESP.
-    {
-        {
-            [ dup abi>> "stdcall" = ]
-            [ alien-stack-frame ESP swap SUB ]
-        } {
-            [ dup return>> large-struct? ]
-            [ drop EAX PUSH ]
-        }
-        [ drop ]
-    } cond ;
-
-M: x86.32 %unwind ( n -- ) RET ;
-
-os windows? [
-    cell "longlong" c-type (>>align)
-    cell "ulonglong" c-type (>>align)
-    4 "double" c-type (>>align)
-] unless
-
-: (sse2?) ( -- ? ) "Intrinsic" throw ;
-
-<<
-
-\ (sse2?) [
-    { EAX EBX ECX EDX } [ PUSH ] each
-    EAX 1 MOV
-    CPUID
-    EDX 26 SHR
-    EDX 1 AND
-    { EAX EBX ECX EDX } [ POP ] each
-    JE
-] { } define-if-intrinsic
-
-\ (sse2?) { } { object } define-primitive
-
->>
-
-: sse2? ( -- ? ) (sse2?) ;
-
-"-no-sse2" cli-args member? [
-    "Checking if your CPU supports SSE2..." print flush
-    [ optimized-recompile-hook ] recompile-hook [
-        [ sse2? ] compile-call
-    ] with-variable
-    [
-        " - yes" print
-        "compiler.backend.x86.sse2" require
-        [
-            sse2? [
-                "This image was built to use SSE2, which your CPU does not support." print
-                "You will need to bootstrap Factor again." print
-                flush
-                1 exit
-            ] unless
-        ] "compiler.backend.x86" add-init-hook
-    ] [
-        " - no" print
-    ] if
-] unless
diff --git a/unfinished/compiler/backend/x86/64/64.factor b/unfinished/compiler/backend/x86/64/64.factor
deleted file mode 100644
index c8760e51b4..0000000000
--- a/unfinished/compiler/backend/x86/64/64.factor
+++ /dev/null
@@ -1,226 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays kernel kernel.private math
-namespaces make sequences system layouts alien alien.accessors
-alien.structs slots splitting assocs combinators
-cpu.x86 compiler.codegen compiler.constants
-compiler.codegen.fixup compiler.cfg.registers compiler.backend
-compiler.backend.x86 compiler.backend.x86.sse2 ;
-IN: compiler.backend.x86.64
-
-M: x86.64 machine-registers
-    {
-        { int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
-        { double-float-regs {
-            XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
-            XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
-        } }
-    } ;
-
-M: x86.64 ds-reg R14 ;
-M: x86.64 rs-reg R15 ;
-M: x86.64 stack-reg RSP ;
-M: x86.64 stack-save-reg RSI ;
-M: x86.64 temp-reg-1 RAX ;
-M: x86.64 temp-reg-2 RCX ;
-
-M: int-regs return-reg drop RAX ;
-M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
-
-M: float-regs return-reg drop XMM0 ;
-
-M: float-regs param-regs
-    drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-
-M: x86.64 fixnum>slot@ drop ;
-
-M: x86.64 prepare-division CQO ;
-
-M: x86.64 load-indirect ( literal reg -- )
-    0 [] MOV rc-relative rel-literal ;
-
-M: stack-params %load-param-reg
-    drop
-    >r R11 swap stack@ MOV
-    r> stack@ R11 MOV ;
-
-M: stack-params %save-param-reg
-    >r stack-frame* + cell + swap r> %load-param-reg ;
-
-: with-return-regs ( quot -- )
-    [
-        V{ RDX RAX } clone int-regs set
-        V{ XMM1 XMM0 } clone float-regs set
-        call
-    ] with-scope ; inline
-
-! The ABI for passing structs by value is pretty messed up
-<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>reg-class) >>
-
-: struct-types&offset ( struct-type -- pairs )
-    fields>> [
-        [ type>> ] [ offset>> ] bi 2array
-    ] map ;
-
-: split-struct ( pairs -- seq )
-    [
-        [ 8 mod zero? [ t , ] when , ] assoc-each
-    ] { } make { t } split harvest ;
-
-: flatten-small-struct ( c-type -- seq )
-    struct-types&offset split-struct [
-        [ c-type c-type-reg-class ] map
-        int-regs swap member? "void*" "double" ? c-type
-    ] map ;
-
-: flatten-large-struct ( c-type -- seq )
-    heap-size cell align
-    cell /i "__stack_value" c-type <repetition> ;
-
-M: struct-type flatten-value-type ( type -- seq )
-    dup heap-size 16 > [
-        flatten-large-struct
-    ] [
-        flatten-small-struct
-    ] if ;
-
-M: x86.64 %prepare-unbox ( -- )
-    ! First parameter is top of stack
-    RDI R14 [] MOV
-    R14 cell SUB ;
-
-M: x86.64 %unbox ( n reg-class func -- )
-    ! Call the unboxer
-    f %alien-invoke
-    ! Store the return value on the C stack
-    over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-
-M: x86.64 %unbox-long-long ( n func -- )
-    int-regs swap %unbox ;
-
-: %unbox-struct-field ( c-type i -- )
-    ! Alien must be in RDI.
-    RDI swap cells [+] swap reg-class>> {
-        { int-regs [ int-regs get pop swap MOV ] }
-        { double-float-regs [ float-regs get pop swap MOVSD ] }
-    } case ;
-
-M: x86.64 %unbox-small-struct ( c-type -- )
-    ! Alien must be in RDI.
-    "alien_offset" f %alien-invoke
-    ! Move alien_offset() return value to RDI so that we don't
-    ! clobber it.
-    RDI RAX MOV
-    [
-        flatten-small-struct [ %unbox-struct-field ] each-index
-    ] with-return-regs ;
-
-M: x86.64 %unbox-large-struct ( n c-type -- )
-    ! Source is in RDI
-    heap-size
-    ! Load destination address
-    RSI RSP roll [+] LEA
-    ! Load structure size
-    RDX swap MOV
-    ! Copy the struct to the C stack
-    "to_value_struct" f %alien-invoke ;
-
-: load-return-value ( reg-class -- )
-    0 over param-reg swap return-reg
-    2dup eq? [ 2drop ] [ MOV ] if ;
-
-M: x86.64 %box ( n reg-class func -- )
-    rot [
-        rot [ 0 swap param-reg ] keep %load-param-reg
-    ] [
-        swap load-return-value
-    ] if*
-    f %alien-invoke ;
-
-M: x86.64 %box-long-long ( n func -- )
-    int-regs swap %box ;
-
-M: x86.64 struct-small-enough? ( size -- ? )
-    heap-size 2 cells <= ;
-
-: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
-
-: %box-struct-field ( c-type i -- )
-    box-struct-field@ swap reg-class>> {
-        { int-regs [ int-regs get pop MOV ] }
-        { double-float-regs [ float-regs get pop MOVSD ] }
-    } case ;
-
-M: x86.64 %box-small-struct ( c-type -- )
-    #! Box a <= 16-byte struct.
-    [
-        [ flatten-small-struct [ %box-struct-field ] each-index ]
-        [ RDX swap heap-size MOV ] bi
-        RDI 0 box-struct-field@ MOV
-        RSI 1 box-struct-field@ MOV
-        "box_small_struct" f %alien-invoke
-    ] with-return-regs ;
-
-: struct-return@ ( size n -- n )
-    [ ] [ \ stack-frame get swap - ] ?if ;
-
-M: x86.64 %box-large-struct ( n c-type -- )
-    ! Struct size is parameter 2
-    heap-size
-    RSI over MOV
-    ! Compute destination address
-    swap struct-return@ RDI RSP rot [+] LEA
-    ! Copy the struct from the C stack
-    "box_value_struct" f %alien-invoke ;
-
-M: x86.64 %prepare-box-struct ( size -- )
-    ! Compute target address for value struct return
-    RAX RSP rot f struct-return@ [+] LEA
-    RSP 0 [+] RAX MOV ;
-
-M: x86.64 %prepare-var-args RAX RAX XOR ;
-
-M: x86.64 %alien-global
-    [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
-
-M: x86.64 %alien-invoke
-    R11 0 MOV
-    rc-absolute-cell rel-dlsym
-    R11 CALL ;
-
-M: x86.64 %prepare-alien-indirect ( -- )
-    "unbox_alien" f %alien-invoke
-    cell temp@ RAX MOV ;
-
-M: x86.64 %alien-indirect ( -- )
-    cell temp@ CALL ;
-
-M: x86.64 %alien-callback ( quot -- )
-    RDI load-indirect "c_to_factor" f %alien-invoke ;
-
-M: x86.64 %callback-value ( ctype -- )
-    ! Save top of data stack
-    %prepare-unbox
-    ! Put former top of data stack in RDI
-    cell temp@ RDI MOV
-    ! Restore data/call/retain stacks
-    "unnest_stacks" f %alien-invoke
-    ! Put former top of data stack in RDI
-    RDI cell temp@ MOV
-    ! Unbox former top of data stack to return registers
-    unbox-return ;
-
-M: x86.64 %cleanup ( alien-node -- ) drop ;
-
-M: x86.64 %unwind ( n -- ) drop 0 RET ;
-
-USE: cpu.x86.intrinsics
-
-! On 64-bit systems, the result of reading 4 bytes from memory
-! is a fixnum.
-\ alien-unsigned-4 small-reg-32 define-unsigned-getter
-\ set-alien-unsigned-4 small-reg-32 define-setter
-
-\ alien-signed-4 small-reg-32 define-signed-getter
-\ set-alien-signed-4 small-reg-32 define-setter
diff --git a/unfinished/compiler/backend/x86/sse2/sse2.factor b/unfinished/compiler/backend/x86/sse2/sse2.factor
deleted file mode 100644
index 4364a8c24a..0000000000
--- a/unfinished/compiler/backend/x86/sse2/sse2.factor
+++ /dev/null
@@ -1,106 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays generic kernel system
-kernel.private math math.private memory namespaces sequences
-words math.floats.private layouts quotations locals cpu.x86
-compiler.codegen compiler.cfg.templates compiler.cfg.builder
-compiler.cfg.registers compiler.constants compiler.backend
-compiler.backend.x86 ;
-IN: compiler.backend.x86.sse2
-
-M:: x86 %box-float ( dst src temp -- )
-    #! Only called by pentium4 backend, uses SSE2 instruction
-    dst 16 float float temp %allot
-    dst 8 float tag-number - [+] src MOVSD ;
-
-M: x86 %unbox-float ( dst src -- )
-    float-offset [+] MOVSD ;
-
-: define-float-op ( word op -- )
-    [ "x" operand "y" operand ] swap suffix T{ template
-        { input { { float "x" } { float "y" } } }
-        { output { "x" } }
-    } define-intrinsic ;
-
-{
-    { float+ ADDSD }
-    { float- SUBSD }
-    { float* MULSD }
-    { float/f DIVSD }
-} [
-    first2 define-float-op
-] each
-
-: define-float-jump ( word op -- )
-    [ "x" operand "y" operand UCOMISD ] swap suffix
-    { { float "x" } { float "y" } } define-if-intrinsic ;
-
-{
-    { float< JAE }
-    { float<= JA }
-    { float> JBE }
-    { float>= JB }
-    { float= JNE }
-} [
-    first2 define-float-jump
-] each
-
-\ float>fixnum [
-    "out" operand "in" operand CVTTSD2SI
-    "out" operand tag-bits get SHL
-] T{ template
-    { input { { float "in" } } }
-    { scratch { { f "out" } } }
-    { output { "out" } }
-} define-intrinsic
-
-\ fixnum>float [
-    "in" operand %untag-fixnum
-    "out" operand "in" operand CVTSI2SD
-] T{ template
-    { input { { f "in" } } }
-    { scratch { { float "out" } } }
-    { output { "out" } }
-    { clobber { "in" } }
-} define-intrinsic
-
-: alien-float-get-template
-    T{ template
-        { input {
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { scratch { { float "value" } } }
-        { output { "value" } }
-        { clobber { "offset" } }
-    } ;
-
-: alien-float-set-template
-    T{ template
-        { input {
-            { float "value" float }
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { clobber { "offset" } }
-    } ;
-
-: define-alien-float-intrinsics ( word get-quot word set-quot -- )
-    [ "value" operand swap %alien-accessor ] curry
-    alien-float-set-template
-    define-intrinsic
-    [ "value" operand swap %alien-accessor ] curry
-    alien-float-get-template
-    define-intrinsic ;
-
-\ alien-double
-[ MOVSD ]
-\ set-alien-double
-[ swap MOVSD ]
-define-alien-float-intrinsics
-
-\ alien-float
-[ dupd MOVSS dup CVTSS2SD ]
-\ set-alien-float
-[ swap dup dup CVTSD2SS MOVSS ]
-define-alien-float-intrinsics
diff --git a/unfinished/compiler/backend/x86/x86.factor b/unfinished/compiler/backend/x86/x86.factor
deleted file mode 100644
index da0586a7b9..0000000000
--- a/unfinished/compiler/backend/x86/x86.factor
+++ /dev/null
@@ -1,643 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays alien.accessors
-compiler.backend kernel kernel.private math memory namespaces
-make sequences words system layouts combinators math.order
-math.private alien alien.c-types slots.private cpu.x86
-cpu.x86.private locals compiler.backend compiler.codegen.fixup
-compiler.constants compiler.intrinsics compiler.cfg.builder
-compiler.cfg.registers compiler.cfg.stacks
-compiler.cfg.templates compiler.codegen ;
-IN: compiler.backend.x86
-
-HOOK: ds-reg cpu ( -- reg )
-HOOK: rs-reg cpu ( -- reg )
-HOOK: stack-reg cpu ( -- reg )
-HOOK: stack-save-reg cpu ( -- reg )
-
-: stack@ ( n -- op ) stack-reg swap [+] ;
-
-: reg-stack ( n reg -- op ) swap cells neg [+] ;
-
-GENERIC: loc>operand ( loc -- operand )
-
-M: ds-loc loc>operand n>> ds-reg reg-stack ;
-M: rs-loc loc>operand n>> rs-reg reg-stack ;
-
-M: int-regs %save-param-reg drop >r stack@ r> MOV ;
-M: int-regs %load-param-reg drop swap stack@ MOV ;
-
-GENERIC: MOVSS/D ( dst src reg-class -- )
-
-M: single-float-regs MOVSS/D drop MOVSS ;
-M: double-float-regs MOVSS/D drop MOVSD ;
-
-M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
-M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
-
-GENERIC: push-return-reg ( reg-class -- )
-GENERIC: load-return-reg ( stack@ reg-class -- )
-GENERIC: store-return-reg ( stack@ reg-class -- )
-
-! Only used by inline allocation
-HOOK: temp-reg-1 cpu ( -- reg )
-HOOK: temp-reg-2 cpu ( -- reg )
-
-HOOK: fixnum>slot@ cpu ( op -- )
-
-HOOK: prepare-division cpu ( -- )
-
-M: f load-literal
-    \ f tag-number MOV drop ;
-
-M: fixnum load-literal
-    swap tag-fixnum MOV ;
-
-M: x86 stack-frame ( n -- i )
-    3 cells + 16 align cell - ;
-
-: factor-area-size ( -- n ) 4 cells ;
-
-M: x86 %prologue ( n -- )
-    temp-reg-1 0 MOV rc-absolute-cell rel-this
-    dup cell + PUSH
-    temp-reg-1 PUSH
-    stack-reg swap 2 cells - SUB ;
-
-M: x86 %epilogue ( n -- )
-    stack-reg swap ADD ;
-
-HOOK: %alien-global cpu ( symbol dll register -- )
-
-M: x86 %prepare-alien-invoke
-    #! Save Factor stack pointers in case the C code calls a
-    #! callback which does a GC, which must reliably trace
-    #! all roots.
-    "stack_chain" f temp-reg-1 %alien-global
-    temp-reg-1 [] stack-reg MOV
-    temp-reg-1 [] cell SUB
-    temp-reg-1 2 cells [+] ds-reg MOV
-    temp-reg-1 3 cells [+] rs-reg MOV ;
-
-M: x86 %call ( label -- ) CALL ;
-
-M: x86 %jump-label ( label -- ) JMP ;
-
-M: x86 %jump-f ( label vreg -- ) \ f tag-number CMP JE ;
-
-M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
-
-: code-alignment ( -- n )
-    building get length dup cell align swap - ;
-
-: align-code ( n -- )
-    0 <repetition> % ;
-
-M:: x86 %dispatch ( src temp -- )
-    ! Load jump table base. We use a temporary register
-    ! since on AMD64 we have to load a 64-bit immediate. On
-    ! x86, this is redundant.
-    ! Untag and multiply to get a jump table offset
-    src fixnum>slot@
-    ! Add jump table base
-    temp HEX: ffffffff MOV rc-absolute-cell rel-here
-    src temp ADD
-    src HEX: 7f [+] JMP
-    ! Fix up the displacement above
-    code-alignment dup bootstrap-cell 8 = 15 9 ? +
-    building get dup pop* push
-    align-code ;
-
-M: x86 %dispatch-label ( word -- )
-    0 cell, rc-absolute-cell rel-word ;
-
-M: x86 %peek loc>operand MOV ;
-
-M: x86 %replace loc>operand swap MOV ;
-
-: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
-
-M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
-
-M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
-
-M: x86 fp-shadows-int? ( -- ? ) f ;
-
-M: x86 value-structs? t ;
-
-M: x86 small-enough? ( n -- ? )
-    HEX: -80000000 HEX: 7fffffff between? ;
-
-: %untag ( reg -- ) tag-mask get bitnot AND ;
-
-: %untag-fixnum ( reg -- ) tag-bits get SAR ;
-
-: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-
-: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
-
-M: x86 %return ( -- ) 0 %unwind ;
-
-! Alien intrinsics
-M: x86 %unbox-byte-array ( dst src -- )
-    byte-array-offset [+] LEA ;
-
-M: x86 %unbox-alien ( dst src -- )
-    alien-offset [+] MOV ;
-
-M: x86 %unbox-f ( dst src -- )
-    drop 0 MOV ;
-
-M: x86 %unbox-any-c-ptr ( dst src -- )
-    { "is-byte-array" "end" "start" } [ define-label ] each
-    ! Address is computed in ds-reg
-    ds-reg PUSH
-    ds-reg 0 MOV
-    ! Object is stored in ds-reg
-    rs-reg PUSH
-    rs-reg swap MOV
-    ! We come back here with displaced aliens
-    "start" resolve-label
-    ! Is the object f?
-    rs-reg \ f tag-number CMP
-    "end" get JE
-    ! Is the object an alien?
-    rs-reg header-offset [+] alien type-number tag-fixnum CMP
-    "is-byte-array" get JNE
-    ! If so, load the offset and add it to the address
-    ds-reg rs-reg alien-offset [+] ADD
-    ! Now recurse on the underlying alien
-    rs-reg rs-reg underlying-alien-offset [+] MOV
-    "start" get JMP
-    "is-byte-array" resolve-label
-    ! Add byte array address to address being computed
-    ds-reg rs-reg ADD
-    ! Add an offset to start of byte array's data
-    ds-reg byte-array-offset ADD
-    "end" resolve-label
-    ! Done, store address in destination register
-    ds-reg MOV
-    ! Restore rs-reg
-    rs-reg POP
-    ! Restore ds-reg
-    ds-reg POP ;
-
-M:: x86 %write-barrier ( src temp -- )
-    #! Mark the card pointed to by vreg.
-    ! Mark the card
-    src card-bits SHR
-    "cards_offset" f temp %alien-global
-    temp temp [+] card-mark <byte> MOV
-
-    ! Mark the card deck
-    temp deck-bits card-bits - SHR
-    "decks_offset" f temp %alien-global
-    temp temp [+] card-mark <byte> MOV ;
-
-: load-zone-ptr ( reg -- )
-    #! Load pointer to start of zone array
-    0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
-
-: load-allot-ptr ( temp -- )
-    [ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
-
-: inc-allot-ptr ( n temp -- )
-    [ POP ] [ cell [+] swap 8 align ADD ] bi ;
-
-: store-header ( temp type -- )
-    [ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
-
-: store-tagged ( dst temp tag -- )
-    dupd tag-number OR MOV ;
-
-M:: x86 %allot ( dst size type tag temp -- )
-    temp load-allot-ptr
-    temp type store-header
-    temp size inc-allot-ptr
-    dst temp store-tagged ;
-
-M: x86 %gc ( -- )
-    "end" define-label
-    temp-reg-1 load-zone-ptr
-    temp-reg-2 temp-reg-1 cell [+] MOV
-    temp-reg-2 1024 ADD
-    temp-reg-1 temp-reg-1 3 cells [+] MOV
-    temp-reg-2 temp-reg-1 CMP
-    "end" get JLE
-    %prepare-alien-invoke
-    "minor_gc" f %alien-invoke
-    "end" resolve-label ;
-
-: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
-
-:: %allot-bignum-signed-1 ( dst src temp -- )
-    #! on entry, inreg is a signed 32-bit quantity
-    #! exits with tagged ptr to bignum in outreg
-    #! 1 cell header, 1 cell length, 1 cell sign, + digits
-    #! length is the # of digits + sign
-    [
-        { "end" "nonzero" "positive" "store" } [ define-label ] each
-        src 0 CMP ! is it zero?
-        "nonzero" get JNE
-        ! Use cached zero value
-        0 >bignum dst load-indirect
-        "end" get JMP
-        "nonzero" resolve-label
-        ! Allocate a bignum
-        dst 4 cells bignum bignum temp %allot
-        ! Write length
-        dst 1 bignum@ 2 MOV
-        ! Test sign
-        src 0 CMP
-        "positive" get JGE
-        dst 2 bignum@ 1 MOV ! negative sign
-        src NEG
-        "store" get JMP
-        "positive" resolve-label
-        dst 2 bignum@ 0 MOV ! positive sign
-        "store" resolve-label
-        dst 3 bignum@ src MOV
-        "end" resolve-label
-    ] with-scope ;
-
-: alien@ ( reg n -- op ) cells object tag-number - [+] ;
-
-M:: x86 %box-alien ( dst src temp -- )
-    [
-        { "end" "f" } [ define-label ] each
-        src 0 CMP
-        "f" get JE
-        dst 4 cells alien object temp %allot
-        dst 1 alien@ \ f tag-number MOV
-        dst 2 alien@ \ f tag-number MOV
-        ! Store src in alien-offset slot
-        dst 3 alien@ src MOV
-        "end" get JMP
-        "f" resolve-label
-        \ f tag-number MOV
-        "end" resolve-label
-    ] with-scope ;
-
-! Type checks
-\ tag [
-    "in" operand tag-mask get AND
-    "in" operand %tag-fixnum
-] T{ template
-    { input { { f "in" } } }
-    { output { "in" } }
-} define-intrinsic
-
-! Slots
-: %slot-literal-known-tag ( -- op )
-    "obj" operand
-    "n" get cells
-    "obj" operand-tag - [+] ;
-
-: %slot-literal-any-tag ( -- op )
-    "obj" operand %untag
-    "obj" operand "n" get cells [+] ;
-
-: %slot-any ( -- op )
-    "obj" operand %untag
-    "n" operand fixnum>slot@
-    "obj" operand "n" operand [+] ;
-
-\ slot {
-    ! Slot number is literal and the tag is known
-    {
-        [ "val" operand %slot-literal-known-tag MOV ] T{ template
-            { input { { f "obj" known-tag } { small-slot "n" } } }
-            { scratch { { f "val" } } }
-            { output { "val" } }
-        }
-    }
-    ! Slot number is literal
-    {
-        [ "obj" operand %slot-literal-any-tag MOV ] T{ template
-            { input { { f "obj" } { small-slot "n" } } }
-            { output { "obj" } }
-        }
-    }
-    ! Slot number in a register
-    {
-        [ "obj" operand %slot-any MOV ] T{ template
-            { input { { f "obj" } { f "n" } } }
-            { output { "obj" } }
-            { clobber { "n" } }
-        }
-    }
-} define-intrinsics
-
-\ (set-slot) {
-    ! Slot number is literal and the tag is known
-    {
-        [ %slot-literal-known-tag "val" operand MOV ] T{ template
-            { input { { f "val" } { f "obj" known-tag } { small-slot "n" } } }
-            { scratch { { f "scratch" } } }
-            { clobber { "obj" } }
-        }
-    }
-    ! Slot number is literal
-    {
-        [ %slot-literal-any-tag "val" operand MOV ] T{ template
-            { input { { f "val" } { f "obj" } { small-slot "n" } } }
-            { scratch { { f "scratch" } } }
-            { clobber { "obj" } }
-        }
-    }
-    ! Slot number in a register
-    {
-        [ %slot-any "val" operand MOV ] T{ template
-            { input { { f "val" } { f "obj" } { f "n" } } }
-            { scratch { { f "scratch" } } }
-            { clobber { "obj" "n" } }
-        }
-    }
-} define-intrinsics
-
-! Sometimes, we need to do stuff with operands which are
-! less than the word size. Instead of teaching the register
-! allocator about the different sized registers, with all
-! the complexity this entails, we just push/pop a register
-! which is guaranteed to be unused (the tempreg)
-: small-reg cell 8 = RBX EBX ? ; inline
-: small-reg-8 BL ; inline
-: small-reg-16 BX ; inline
-: small-reg-32 EBX ; inline
-
-! Fixnums
-: fixnum-op ( op hash -- pair )
-    >r [ "x" operand "y" operand ] swap suffix r> 2array ;
-
-: fixnum-value-op ( op -- pair )
-    T{ template
-        { input { { f "x" } { small-tagged "y" } } }
-        { output { "x" } }
-    } fixnum-op ;
-
-: fixnum-register-op ( op -- pair )
-    T{ template
-        { input { { f "x" } { f "y" } } }
-        { output { "x" } }
-    } fixnum-op ;
-
-: define-fixnum-op ( word op -- )
-    [ fixnum-value-op ] keep fixnum-register-op
-    2array define-intrinsics ;
-
-{
-    { fixnum+fast ADD }
-    { fixnum-fast SUB }
-    { fixnum-bitand AND }
-    { fixnum-bitor OR }
-    { fixnum-bitxor XOR }
-} [
-    first2 define-fixnum-op
-] each
-
-\ fixnum-bitnot [
-    "x" operand NOT
-    "x" operand tag-mask get XOR
-] T{ template
-    { input { { f "x" } } }
-    { output { "x" } }
-} define-intrinsic
-
-\ fixnum*fast {
-    {
-        [
-            "x" operand "y" get IMUL2
-        ] T{ template
-            { input { { f "x" } { [ small-tagged? ] "y" } } }
-            { output { "x" } }
-        }
-    } {
-        [
-            "out" operand "x" operand MOV
-            "out" operand %untag-fixnum
-            "y" operand "out" operand IMUL2
-        ] T{ template
-            { input { { f "x" } { f "y" } } }
-            { scratch { { f "out" } } }
-            { output { "out" } }
-        }
-    }
-} define-intrinsics
-
-: %untag-fixnums ( seq -- )
-    [ %untag-fixnum ] unique-operands ;
-
-\ fixnum-shift-fast [
-    "x" operand "y" get
-    dup 0 < [ neg SAR ] [ SHL ] if
-    ! Mask off low bits
-    "x" operand %untag
-] T{ template
-    { input { { f "x" } { [ ] "y" } } }
-    { output { "x" } }
-} define-intrinsic
-
-: overflow-check ( word -- )
-    "end" define-label
-    "z" operand "x" operand MOV
-    "z" operand "y" operand pick execute
-    ! If the previous arithmetic operation overflowed, then we
-    ! turn the result into a bignum and leave it in EAX.
-    "end" get JNO
-    ! There was an overflow. Recompute the original operand.
-    { "y" "x" } %untag-fixnums
-    "x" operand "y" operand rot execute
-    "z" operand "x" operand "y" operand %allot-bignum-signed-1
-    "end" resolve-label ; inline
-
-: overflow-template ( word insn -- )
-    [ overflow-check ] curry T{ template
-        { input { { f "x" } { f "y" } } }
-        { scratch { { f "z" } } }
-        { output { "z" } }
-        { clobber { "x" "y" } }
-        { gc t }
-    } define-intrinsic ;
-
-\ fixnum+ \ ADD overflow-template
-\ fixnum- \ SUB overflow-template
-
-: fixnum-jump ( op inputs -- pair )
-    >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
-
-: fixnum-value-jump ( op -- pair )
-    { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
-
-: fixnum-register-jump ( op -- pair )
-    { { f "x" } { f "y" } } fixnum-jump ;
-
-: define-fixnum-jump ( word op -- )
-    [ fixnum-value-jump ] keep fixnum-register-jump
-    2array define-if-intrinsics ;
-
-{
-    { fixnum< JL }
-    { fixnum<= JLE }
-    { fixnum> JG }
-    { fixnum>= JGE }
-    { eq? JE }
-} [
-    first2 define-fixnum-jump
-] each
-
-\ fixnum>bignum [
-    "x" operand %untag-fixnum
-    "x" operand dup "scratch" operand %allot-bignum-signed-1
-] T{ template
-    { input { { f "x" } } }
-    { scratch { { f "scratch" } } }
-    { output { "x" } }
-    { gc t }
-} define-intrinsic
-
-\ bignum>fixnum [
-    "nonzero" define-label
-    "positive" define-label
-    "end" define-label
-    "x" operand %untag
-    "y" operand "x" operand cell [+] MOV
-     ! if the length is 1, its just the sign and nothing else,
-     ! so output 0
-    "y" operand 1 tag-fixnum CMP
-    "nonzero" get JNE
-    "y" operand 0 MOV
-    "end" get JMP
-    "nonzero" resolve-label
-    ! load the value
-    "y" operand "x" operand 3 cells [+] MOV
-    ! load the sign
-    "x" operand "x" operand 2 cells [+] MOV
-    ! is the sign negative?
-    "x" operand 0 CMP
-    "positive" get JE
-    "y" operand -1 IMUL2
-    "positive" resolve-label
-    "y" operand 3 SHL
-    "end" resolve-label
-] T{ template
-    { input { { f "x" } } }
-    { scratch { { f "y" } } }
-    { clobber { "x" } }
-    { output { "y" } }
-} define-intrinsic
-
-! User environment
-: %userenv ( -- )
-    "x" operand 0 MOV
-    "userenv" f rc-absolute-cell rel-dlsym
-    "n" operand fixnum>slot@
-    "n" operand "x" operand ADD ;
-
-\ getenv [
-    %userenv  "n" operand dup [] MOV
-] T{ template
-    { input { { f "n" } } }
-    { scratch { { f "x" } } }
-    { output { "n" } }
-} define-intrinsic
-
-\ setenv [
-    %userenv  "n" operand [] "val" operand MOV
-] T{ template
-    { input { { f "val" } { f "n" } } }
-    { scratch { { f "x" } } }
-    { clobber { "n" } }
-} define-intrinsic
-
-! Alien intrinsics
-: %alien-accessor ( quot -- )
-    "offset" operand %untag-fixnum
-    "offset" operand "alien" operand ADD
-    "offset" operand [] swap call ; inline
-
-: %alien-integer-get ( quot reg -- )
-    small-reg PUSH
-    swap %alien-accessor
-    "value" operand small-reg MOV
-    "value" operand %tag-fixnum
-    small-reg POP ; inline
-
-: alien-integer-get-template
-    T{ template
-        { input {
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { scratch { { f "value" } } }
-        { output { "value" } }
-        { clobber { "offset" } }
-    } ;
-
-: define-getter ( word quot reg -- )
-    [ %alien-integer-get ] 2curry
-    alien-integer-get-template
-    define-intrinsic ;
-
-: define-unsigned-getter ( word reg -- )
-    [ small-reg dup XOR MOV ] swap define-getter ;
-
-: define-signed-getter ( word reg -- )
-    [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
-
-: %alien-integer-set ( quot reg -- )
-    small-reg PUSH
-    small-reg "value" operand MOV
-    small-reg %untag-fixnum
-    swap %alien-accessor
-    small-reg POP ; inline
-
-: alien-integer-set-template
-    T{ template
-        { input {
-            { f "value" fixnum }
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { clobber { "value" "offset" } }
-    } ;
-
-: define-setter ( word reg -- )
-    [ swap MOV ] swap
-    [ %alien-integer-set ] 2curry
-    alien-integer-set-template
-    define-intrinsic ;
-
-\ alien-unsigned-1 small-reg-8 define-unsigned-getter
-\ set-alien-unsigned-1 small-reg-8 define-setter
-
-\ alien-signed-1 small-reg-8 define-signed-getter
-\ set-alien-signed-1 small-reg-8 define-setter
-
-\ alien-unsigned-2 small-reg-16 define-unsigned-getter
-\ set-alien-unsigned-2 small-reg-16 define-setter
-
-\ alien-signed-2 small-reg-16 define-signed-getter
-\ set-alien-signed-2 small-reg-16 define-setter
-
-\ alien-cell [
-    "value" operand [ MOV ] %alien-accessor
-] T{ template
-    { input {
-        { unboxed-c-ptr "alien" c-ptr }
-        { f "offset" fixnum }
-    } }
-    { scratch { { unboxed-alien "value" } } }
-    { output { "value" } }
-    { clobber { "offset" } }
-} define-intrinsic
-
-\ set-alien-cell [
-    "value" operand [ swap MOV ] %alien-accessor
-] T{ template
-    { input {
-        { unboxed-c-ptr "value" pinned-c-ptr }
-        { unboxed-c-ptr "alien" c-ptr }
-        { f "offset" fixnum }
-    } }
-    { clobber { "offset" } }
-} define-intrinsic

From 7b6d9c4c4fb8a67b7af9abc8c98879dde2444bbb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 7 Oct 2008 20:00:38 -0500
Subject: [PATCH 004/318] Debugging new codegen

---
 basis/compiler/cfg/builder/builder.factor     | 11 +--
 basis/compiler/cfg/debugger/debugger.factor   |  6 +-
 .../linear-scan/allocation/allocation.factor  |  5 +-
 .../linear-scan/assignment/assignment.factor  |  1 +
 .../cfg/linear-scan/linear-scan.factor        |  4 +-
 basis/compiler/cfg/registers/registers.factor |  7 --
 .../cfg/stack-frame/stack-frame.factor        |  6 +-
 basis/compiler/cfg/stacks/stacks.factor       |  6 +-
 basis/compiler/cfg/templates/templates.factor |  4 +-
 basis/compiler/codegen/codegen.factor         | 13 ++--
 basis/compiler/codegen/fixup/fixup.factor     |  2 +-
 basis/compiler/compiler-docs.factor           |  2 +-
 basis/cpu/architecture/architecture.factor    | 19 ++---
 basis/cpu/x86/32/32.factor                    | 25 ++++---
 basis/cpu/x86/64/64.factor                    | 23 ++++--
 basis/cpu/x86/allot/allot.factor              | 45 +++++++++--
 .../cpu/x86/architecture/architecture.factor  | 50 ++++++-------
 basis/cpu/x86/assembler/assembler.factor      |  8 +-
 basis/cpu/x86/bootstrap.factor                |  2 +-
 basis/cpu/x86/intrinsics/intrinsics.factor    | 74 +++++++------------
 basis/cpu/x86/sse2/sse2.factor                | 50 ++++++-------
 21 files changed, 194 insertions(+), 169 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index c8add3ca09..85e49d080e 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -4,6 +4,7 @@ USING: accessors arrays assocs combinators hashtables kernel
 math fry namespaces make sequences words byte-arrays
 locals layouts alien.c-types alien.structs
 stack-checker.inlining
+cpu.architecture
 compiler.intrinsics
 compiler.tree
 compiler.tree.builder
@@ -154,7 +155,7 @@ M: #if emit-node
     #! correct register state
     gensym [
         [
-            copy-phantoms
+            init-phantoms
             ##prologue
             [ emit-nodes ] with-node-iterator
             ##epilogue
@@ -170,12 +171,12 @@ M: #if emit-node
 
 : emit-dispatch ( node -- )
     phantom-pop int-regs next-vreg
-    [ finalize-contents finalize-heights ##epilogue ] 2dip ##dispatch
+    [ finalize-phantoms ##epilogue ] 2dip ##dispatch
     dispatch-branches init-phantoms ;
 
 M: #dispatch emit-node
     tail-call? [
-        emit-dispatch iterate-next
+        emit-dispatch stop-iterating
     ] [
         current-word get gensym [
             [
@@ -295,12 +296,12 @@ M: #r> emit-node
 
 ! #return
 M: #return emit-node
-    drop finalize-phantoms ##epilogue ##return f ;
+    drop finalize-phantoms ##epilogue ##return stop-iterating ;
 
 M: #return-recursive emit-node
     finalize-phantoms
     label>> id>> loops get key?
-    [ ##epilogue ##return ] unless f ;
+    [ ##epilogue ##return ] unless stop-iterating ;
 
 ! #terminate
 M: #terminate emit-node drop stop-iterating ;
diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 1da954c22e..f7591ba105 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -3,7 +3,8 @@
 USING: kernel words sequences quotations namespaces io
 accessors prettyprint prettyprint.config
 compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.linearization ;
+compiler.cfg.builder compiler.cfg.linearization
+compiler.cfg.stack-frame ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -14,7 +15,8 @@ M: callable test-cfg
 M: word test-cfg
     [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
 
-: test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;
+: test-mr ( quot -- mrs )
+    test-cfg [ build-mr build-stack-frame ] map ;
 
 : mr. ( mrs -- )
     [
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 4a9646c88a..4d1d8543bf 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -1,10 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences math math.order kernel assocs
-accessors vectors fry heaps
+accessors vectors fry heaps cpu.architecture
 compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals
-compiler.backend ;
+compiler.cfg.linear-scan.live-intervals ;
 IN: compiler.cfg.linear-scan.allocation
 
 ! Mapping from register classes to sequences of machine registers
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index ffe8e6b687..541ab606a2 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math assocs namespaces sequences heaps
 fry make combinators
+cpu.architecture
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.linear-scan.live-intervals ;
diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index f62e3a39d1..046f2a7eff 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces
-compiler.backend
+cpu.architecture
 compiler.cfg
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation
@@ -29,5 +29,5 @@ IN: compiler.cfg.linear-scan
             machine-registers allocate-registers
             assign-registers
         ] change-instructions
-        spill-counts get >>spill-counts
+        ! spill-counts get >>spill-counts
     ] with-scope ;
diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor
index ebc8382f0f..3a4a82f70b 100644
--- a/basis/compiler/cfg/registers/registers.factor
+++ b/basis/compiler/cfg/registers/registers.factor
@@ -17,13 +17,6 @@ M: value >vreg drop f ;
 M: value set-value-class 2drop ;
 M: value value-class* drop f ;
 
-! Register classes
-SINGLETON: int-regs
-SINGLETON: single-float-regs
-SINGLETON: double-float-regs
-UNION: float-regs single-float-regs double-float-regs ;
-UNION: reg-class int-regs float-regs ;
-
 ! Virtual registers
 TUPLE: vreg reg-class n ;
 SYMBOL: vreg-counter
diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index 6ec34d37c2..7a419779a3 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math.order assocs kernel sequences
-make compiler.cfg.instructions compiler.cfg.instructions.syntax
-compiler.cfg.registers ;
+combinators make compiler.cfg.instructions
+compiler.cfg.instructions.syntax compiler.cfg.registers ;
 IN: compiler.cfg.stack-frame
 
 SYMBOL: frame-required?
@@ -21,7 +21,7 @@ GENERIC: compute-stack-frame* ( insn -- )
         [ [ params>> ] bi@ max ]
         [ [ return>> ] bi@ max ]
         [ [ total-size>> ] bi@ max ]
-    } cleave
+    } 2cleave
     stack-frame boa ;
 
 M: ##stack-frame compute-stack-frame*
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index 56be18c107..beb301d97a 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -3,7 +3,7 @@
 USING: arrays assocs classes classes.private classes.algebra
 combinators hashtables kernel layouts math fry namespaces
 quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order compiler.backend
+byte-arrays accessors sets math.order cpu.architecture
 compiler.cfg.instructions compiler.cfg.registers ;
 IN: compiler.cfg.stacks
 
@@ -11,6 +11,10 @@ IN: compiler.cfg.stacks
 ! doing a bit of optimization along the way.
 SYMBOL: known-tag
 
+PREDICATE: small-slot < integer cells small-enough? ;
+
+PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
+
 ! Value protocol
 GENERIC: move-spec ( obj -- spec )
 GENERIC: live-loc? ( actual current -- ? )
diff --git a/basis/compiler/cfg/templates/templates.factor b/basis/compiler/cfg/templates/templates.factor
index 72e092ad68..0e8f49676c 100644
--- a/basis/compiler/cfg/templates/templates.factor
+++ b/basis/compiler/cfg/templates/templates.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors sequences kernel fry namespaces
-quotations combinators classes.algebra compiler.backend
-compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks ;
+quotations combinators classes.algebra compiler.cfg.instructions
+compiler.cfg.registers compiler.cfg.stacks ;
 IN: compiler.cfg.templates
 
 TUPLE: template input output scratch clobber gc ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index fe6b45e88a..f157ad1d15 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -3,10 +3,10 @@
 USING: namespaces make math math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
 combinators classes.algebra alien alien.c-types alien.structs
-alien.strings sets threads libc continuations.private
+alien.strings alien.arrays sets threads libc continuations.private
+cpu.architecture
 compiler.errors
 compiler.alien
-compiler.backend
 compiler.codegen.fixup
 compiler.cfg
 compiler.cfg.instructions
@@ -88,7 +88,7 @@ M: ##peek generate-insn
     [ dst>> v>operand ] [ loc>> ] bi %peek ;
 
 M: ##replace generate-insn
-    [ src>> ] [ loc>> ] bi %replace ;
+    [ src>> v>operand ] [ loc>> ] bi %replace ;
 
 M: ##inc-d generate-insn n>> %inc-d ;
 
@@ -111,6 +111,9 @@ M: ##intrinsic generate-insn
 : (operand) ( name -- operand )
     operands get at* [ "Bad operand name" throw ] unless ;
 
+: literal ( name -- value )
+    (operand) value>> ;
+
 : operand ( name -- operand )
     (operand) v>operand ;
 
@@ -134,10 +137,10 @@ M: _branch generate-insn
     label>> lookup-label %jump-label ;
 
 M: _branch-f generate-insn
-    [ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
+    [ label>> lookup-label ] [ src>> v>operand ] bi %jump-f ;
 
 M: _branch-t generate-insn
-    [ src>> v>operand ] [ label>> lookup-label ] bi %jump-t ;
+    [ label>> lookup-label ] [ src>> v>operand ] bi %jump-t ;
 
 M: ##dispatch-label generate-insn label>> %dispatch-label ;
 
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index 5e8c1809a5..6e45ab27e9 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -4,7 +4,7 @@ USING: arrays byte-arrays generic assocs hashtables io.binary
 kernel kernel.private math namespaces make sequences words
 quotations strings alien.accessors alien.strings layouts system
 combinators math.bitwise words.private math.order accessors
-growable compiler.constants compiler.backend ;
+growable cpu.architecture compiler.constants ;
 IN: compiler.codegen.fixup
 
 GENERIC: fixup* ( obj -- )
diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor
index 1f941a0f88..542c833178 100644
--- a/basis/compiler/compiler-docs.factor
+++ b/basis/compiler/compiler-docs.factor
@@ -1,4 +1,4 @@
-USING: compiler.generator help.markup help.syntax words io parser
+USING: help.markup help.syntax words io parser
 assocs words.private sequences compiler.units ;
 IN: compiler
 
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index c5e8c88988..f4243eb987 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -12,6 +12,13 @@ TUPLE: label offset ;
 : define-label ( name -- ) <label> swap set ;
 : resolve-label ( label/name -- ) dup label? [ get ] unless , ;
 
+! Register classes
+SINGLETON: int-regs
+SINGLETON: single-float-regs
+SINGLETON: double-float-regs
+UNION: float-regs single-float-regs double-float-regs ;
+UNION: reg-class int-regs float-regs ;
+
 ! Mapping from register class to machine registers
 HOOK: machine-registers cpu ( -- assoc )
 
@@ -38,8 +45,6 @@ HOOK: load-indirect cpu ( obj reg -- )
 
 HOOK: stack-frame-size cpu ( frame-size -- n )
 
-TUPLE: stack-frame total-size size params return ;
-
 ! Set up caller stack frame
 HOOK: %prologue cpu ( n -- )
 
@@ -53,10 +58,10 @@ HOOK: %call cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 
 ! Test if vreg is 'f' or not
-HOOK: %jump-f cpu ( label -- )
+HOOK: %jump-f cpu ( label vreg -- )
 
 ! Test if vreg is 't' or not
-HOOK: %jump-t cpu ( label -- )
+HOOK: %jump-t cpu ( label vreg -- )
 
 HOOK: %dispatch cpu ( -- )
 
@@ -149,11 +154,7 @@ M: stack-params param-reg drop ;
 
 M: stack-params param-regs drop f ;
 
-M: object load-literal v>operand load-indirect ;
-
-PREDICATE: small-slot < integer cells small-enough? ;
-
-PREDICATE: small-tagged < integer v>operand small-enough? ;
+M: object load-literal load-indirect ;
 
 : if-small-struct ( n size true false -- ? )
     [ over not over struct-small-enough? and ] 2dip
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index a16beed09c..67809c4d91 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -1,12 +1,13 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types arrays cpu.x86.assembler
-cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
-cpu.architecture kernel kernel.private math namespaces sequences
-stack-checker.known-words compiler.generator.registers
-compiler.generator.fixup compiler.generator system layouts
-combinators command-line compiler compiler.units io
-vocabs.loader accessors init ;
+USING: locals alien.c-types arrays kernel kernel.private math
+namespaces sequences stack-checker.known-words system layouts io
+vocabs.loader accessors init combinators command-line
+cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics
+cpu.x86.allot cpu.architecture compiler compiler.units
+compiler.constants compiler.alien compiler.codegen
+compiler.codegen.fixup compiler.cfg.builder
+compiler.cfg.instructions ;
 IN: cpu.x86.32
 
 ! We implement the FFI for Linux, OS X and Windows all at once.
@@ -14,6 +15,12 @@ IN: cpu.x86.32
 ! this on all platforms, sacrificing some stack space for
 ! code simplicity.
 
+M: x86.32 machine-registers
+    {
+        { int-regs { EAX ECX EDX EBP EBX } }
+        { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
+    } ;
+
 M: x86.32 ds-reg ESI ;
 M: x86.32 rs-reg EDI ;
 M: x86.32 stack-reg ESP ;
@@ -254,7 +261,7 @@ M: x86.32 %cleanup ( alien-node -- )
         [ drop ]
     } cond ;
 
-M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
+M: x86.32 %unwind ( n -- ) RET ;
 
 os windows? [
     cell "longlong" c-type (>>align)
@@ -273,7 +280,7 @@ os windows? [
     EDX 26 SHR
     EDX 1 AND
     { EAX EBX ECX EDX } [ POP ] each
-    JE
+    JNE
 ] { } define-if-intrinsic
 
 \ (sse2?) { } { object } define-primitive
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 9ecd3436bb..6a3d272dfb 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -1,14 +1,23 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays cpu.x86.assembler
-cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
-cpu.x86.allot cpu.architecture kernel kernel.private math
-namespaces make sequences compiler.generator
-compiler.generator.registers compiler.generator.fixup system
+USING: accessors alien.c-types arrays kernel kernel.private math
+namespaces make sequences system
 layouts alien alien.accessors alien.structs slots splitting
-assocs combinators ;
+assocs combinators cpu.x86.assembler
+cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
+cpu.x86.allot cpu.architecture compiler.constants
+compiler.codegen compiler.codegen.fixup compiler.cfg.instructions ;
 IN: cpu.x86.64
 
+M: x86.64 machine-registers
+    {
+        { int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
+        { double-float-regs {
+            XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
+            XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
+        } }
+    } ;
+
 M: x86.64 ds-reg R14 ;
 M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
@@ -215,7 +224,7 @@ M: x86.64 %callback-value ( ctype -- )
 
 M: x86.64 %cleanup ( alien-node -- ) drop ;
 
-M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
+M: x86.64 %unwind ( n -- ) drop 0 RET ;
 
 USE: cpu.x86.intrinsics
 
diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor
index 2c38a99833..7dfd1f4096 100644
--- a/basis/cpu/x86/allot/allot.factor
+++ b/basis/cpu/x86/allot/allot.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel cpu.architecture cpu.x86.assembler
-cpu.x86.architecture kernel.private namespaces math sequences
-generic arrays compiler.generator compiler.generator.fixup
-compiler.generator.registers system layouts alien locals
-compiler.constants ;
+USING: kernel words kernel.private namespaces math math.private
+sequences generic arrays system layouts alien locals
+cpu.architecture cpu.x86.assembler cpu.x86.architecture
+compiler.constants compiler.cfg.templates compiler.cfg.builder
+compiler.codegen compiler.codegen.fixup ;
 IN: cpu.x86.allot
 
 M:: x86 %write-barrier ( src temp -- )
@@ -102,3 +102,38 @@ M:: x86 %box-alien ( dst src temp -- )
         \ f tag-number MOV
         "end" resolve-label
     ] with-scope ;
+
+: overflow-check ( word -- )
+    "end" define-label
+    "z" operand "x" operand MOV
+    "z" operand "y" operand pick execute
+    ! If the previous arithmetic operation overflowed, then we
+    ! turn the result into a bignum and leave it in EAX.
+    "end" get JNO
+    ! There was an overflow. Recompute the original operand.
+    { "y" "x" } [ %untag-fixnum ] unique-operands
+    "x" operand "y" operand rot execute
+    "z" operand "x" operand "y" operand %allot-bignum-signed-1
+    "end" resolve-label ; inline
+
+: overflow-template ( word insn -- )
+    [ overflow-check ] curry T{ template
+        { input { { f "x" } { f "y" } } }
+        { scratch { { f "z" } } }
+        { output { "z" } }
+        { clobber { "x" "y" } }
+        { gc t }
+    } define-intrinsic ;
+
+\ fixnum+ \ ADD overflow-template
+\ fixnum- \ SUB overflow-template
+
+\ fixnum>bignum [
+    "x" operand %untag-fixnum
+    "x" operand dup "scratch" operand %allot-bignum-signed-1
+] T{ template
+    { input { { f "x" } } }
+    { scratch { { f "scratch" } } }
+    { output { "x" } }
+    { gc t }
+} define-intrinsic
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 0ebc696323..90807ff4ce 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -2,9 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types arrays cpu.x86.assembler
 cpu.x86.assembler.private cpu.architecture kernel kernel.private
-math memory namespaces make sequences words compiler.generator
-compiler.generator.registers compiler.generator.fixup system
-layouts combinators compiler.constants math.order ;
+math memory namespaces make sequences words system
+layouts combinators math.order locals compiler.constants
+compiler.cfg.registers compiler.cfg.instructions
+compiler.codegen.fixup ;
 IN: cpu.x86.architecture
 
 HOOK: ds-reg cpu ( -- reg )
@@ -63,8 +64,6 @@ M: fixnum load-literal
 M: x86 stack-frame-size ( n -- i )
     3 cells + align-stack ;
 
-M: x86 %save-word-xt ( -- ) ;
-
 : decr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
 
@@ -95,10 +94,10 @@ M: x86 %call ( label -- ) CALL ;
 
 M: x86 %jump-label ( label -- ) JMP ;
 
-M: x86 %jump-f ( label vreg -- )
+M: x86 %jump-f ( label reg -- )
     \ f tag-number CMP JE ;
 
-M: x86 %jump-t ( label vreg -- )
+M: x86 %jump-t ( label reg -- )
     \ f tag-number CMP JNE ;
 
 : code-alignment ( -- n )
@@ -107,27 +106,20 @@ M: x86 %jump-t ( label vreg -- )
 : align-code ( n -- )
     0 <repetition> % ;
 
-M: x86 %dispatch ( -- )
-    [
-        %epilogue-later
-        ! Load jump table base. We use a temporary register
-        ! since on AMD64 we have to load a 64-bit immediate. On
-        ! x86, this is redundant.
-        ! Untag and multiply to get a jump table offset
-        "n" operand fixnum>slot@
-        ! Add jump table base
-        "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
-        "n" operand "offset" operand ADD
-        "n" operand HEX: 7f [+] JMP
-        ! Fix up the displacement above
-        code-alignment dup bootstrap-cell 8 = 15 9 ? +
-        building get dup pop* push
-        align-code
-    ] H{
-        { +input+ { { f "n" } } }
-        { +scratch+ { { f "offset" } } }
-        { +clobber+ { "n" } }
-    } with-template ;
+M:: x86 %dispatch ( src temp -- )
+    ! Load jump table base. We use a temporary register
+    ! since on AMD64 we have to load a 64-bit immediate. On
+    ! x86, this is redundant.
+    ! Untag and multiply to get a jump table offset
+    src fixnum>slot@
+    ! Add jump table base
+    temp HEX: ffffffff MOV rc-absolute-cell rel-here
+    src temp ADD
+    src HEX: 7f [+] JMP
+    ! Fix up the displacement above
+    code-alignment dup bootstrap-cell 8 = 15 9 ? +
+    building get dup pop* push
+    align-code ;
 
 M: x86 %dispatch-label ( word -- )
     0 cell, rc-absolute-cell rel-word ;
@@ -142,6 +134,8 @@ M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
 
 M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
 
+M: x86 %copy ( dst src -- ) MOV ;
+
 M: x86 fp-shadows-int? ( -- ? ) f ;
 
 M: x86 value-structs? t ;
diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor
index f557bb4adc..e4f81993ca 100644
--- a/basis/cpu/x86/assembler/assembler.factor
+++ b/basis/cpu/x86/assembler/assembler.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays compiler.generator.fixup io.binary kernel
-combinators kernel.private math namespaces make sequences
-words system layouts math.order accessors
-cpu.x86.assembler.syntax ;
+USING: arrays cpu.architecture compiler.constants
+compiler.codegen.fixup io.binary kernel combinators
+kernel.private math namespaces make sequences words system
+layouts math.order accessors cpu.x86.assembler.syntax ;
 IN: cpu.x86.assembler
 
 ! A postfix assembler for x86 and AMD64.
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 026578b377..95e0072dc4 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.x86.assembler layouts compiler.units math
-math.private compiler.generator.fixup compiler.constants vocabs
+math.private compiler.constants vocabs
 slots.private words words.private ;
 IN: bootstrap.x86
 
diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor
index 3ef25a9075..2eea80b3eb 100644
--- a/basis/cpu/x86/intrinsics/intrinsics.factor
+++ b/basis/cpu/x86/intrinsics/intrinsics.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays alien.accessors
-compiler.backend kernel kernel.private math memory namespaces
-make sequences words system layouts combinators math.order
-math.private alien alien.c-types slots.private cpu.x86.assembler
-cpu.x86.assembler.private locals compiler.backend
+USING: accessors arrays byte-arrays alien.accessors kernel
+kernel.private math memory namespaces make sequences words
+system layouts combinators math.order math.private alien
+alien.c-types slots.private locals cpu.architecture
+cpu.x86.assembler cpu.x86.assembler.private cpu.x86.architecture
 compiler.codegen.fixup compiler.constants compiler.intrinsics
 compiler.cfg.builder compiler.cfg.registers compiler.cfg.stacks
 compiler.cfg.templates compiler.codegen ;
@@ -20,6 +20,20 @@ IN: cpu.x86.intrinsics
 } define-intrinsic
 
 ! Slots
+: %slot-literal-known-tag ( -- op )
+    "obj" operand
+    "n" literal cells
+    "obj" operand-tag - [+] ;
+
+: %slot-literal-any-tag ( -- op )
+    "obj" operand %untag
+    "obj" operand "n" literal cells [+] ;
+
+: %slot-any ( -- op )
+    "obj" operand %untag
+    "n" operand fixnum>slot@
+    "obj" operand "n" operand [+] ;
+
 \ slot {
     ! Slot number is literal and the tag is known
     {
@@ -124,9 +138,9 @@ IN: cpu.x86.intrinsics
 \ fixnum*fast {
     {
         [
-            "x" operand "y" get IMUL2
+            "x" operand "y" literal IMUL2
         ] T{ template
-            { input { { f "x" } { [ small-tagged? ] "y" } } }
+            { input { { f "x" } { small-tagged "y" } } }
             { output { "x" } }
         }
     } {
@@ -142,55 +156,27 @@ IN: cpu.x86.intrinsics
     }
 } define-intrinsics
 
-: %untag-fixnums ( seq -- )
-    [ %untag-fixnum ] unique-operands ;
-
 \ fixnum-shift-fast [
-    "x" operand "y" get
+    "x" operand "y" literal
     dup 0 < [ neg SAR ] [ SHL ] if
     ! Mask off low bits
     "x" operand %untag
 ] T{ template
-    { input { { f "x" } { [ ] "y" } } }
+    { input { { f "x" } { small-tagged "y" } } }
     { output { "x" } }
 } define-intrinsic
 
-: overflow-check ( word -- )
-    "end" define-label
-    "z" operand "x" operand MOV
-    "z" operand "y" operand pick execute
-    ! If the previous arithmetic operation overflowed, then we
-    ! turn the result into a bignum and leave it in EAX.
-    "end" get JNO
-    ! There was an overflow. Recompute the original operand.
-    { "y" "x" } %untag-fixnums
-    "x" operand "y" operand rot execute
-    "z" operand "x" operand "y" operand %allot-bignum-signed-1
-    "end" resolve-label ; inline
-
-: overflow-template ( word insn -- )
-    [ overflow-check ] curry T{ template
-        { input { { f "x" } { f "y" } } }
-        { scratch { { f "z" } } }
-        { output { "z" } }
-        { clobber { "x" "y" } }
-        { gc t }
-    } define-intrinsic ;
-
-\ fixnum+ \ ADD overflow-template
-\ fixnum- \ SUB overflow-template
-
 : fixnum-jump ( op inputs -- pair )
     >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
 
 : fixnum-value-jump ( op -- pair )
-    { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
+    { { f "x" } { small-tagged "y" } } fixnum-jump ;
 
 : fixnum-register-jump ( op -- pair )
     { { f "x" } { f "y" } } fixnum-jump ;
 
 : define-fixnum-jump ( word op -- )
-    [ fixnum-value-jump ] keep fixnum-register-jump
+    [ fixnum-value-jump ] [ fixnum-register-jump ] bi
     2array define-if-intrinsics ;
 
 {
@@ -203,16 +189,6 @@ IN: cpu.x86.intrinsics
     first2 define-fixnum-jump
 ] each
 
-\ fixnum>bignum [
-    "x" operand %untag-fixnum
-    "x" operand dup "scratch" operand %allot-bignum-signed-1
-] T{ template
-    { input { { f "x" } } }
-    { scratch { { f "scratch" } } }
-    { output { "x" } }
-    { gc t }
-} define-intrinsic
-
 \ bignum>fixnum [
     "nonzero" define-label
     "positive" define-label
diff --git a/basis/cpu/x86/sse2/sse2.factor b/basis/cpu/x86/sse2/sse2.factor
index 81108aa55a..e1bd0d2f63 100644
--- a/basis/cpu/x86/sse2/sse2.factor
+++ b/basis/cpu/x86/sse2/sse2.factor
@@ -1,11 +1,11 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays cpu.x86.assembler
-cpu.x86.architecture cpu.x86.intrinsics generic kernel
+USING: alien alien.accessors arrays generic kernel
 kernel.private math math.private memory namespaces sequences
-words compiler.generator compiler.generator.registers
-cpu.architecture math.floats.private layouts quotations
-system ;
+words math.floats.private layouts quotations locals
+system compiler.constants compiler.codegen compiler.cfg.templates
+compiler.cfg.registers compiler.cfg.builder cpu.architecture
+cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics ;
 IN: cpu.x86.sse2
 
 M: x86 %copy-float MOVSD ;
@@ -18,9 +18,9 @@ M: x86 %unbox-float ( dst src -- )
     float-offset [+] MOVSD ;
 
 : define-float-op ( word op -- )
-    [ "x" operand "y" operand ] swap suffix H{
-        { +input+ { { float "x" } { float "y" } } }
-        { +output+ { "x" } }
+    [ "x" operand "y" operand ] swap suffix T{ template
+        { input { { float "x" } { float "y" } } }
+        { output { "x" } }
     } define-intrinsic ;
 
 {
@@ -49,41 +49,41 @@ M: x86 %unbox-float ( dst src -- )
 \ float>fixnum [
     "out" operand "in" operand CVTTSD2SI
     "out" operand tag-bits get SHL
-] H{
-    { +input+ { { float "in" } } }
-    { +scratch+ { { f "out" } } }
-    { +output+ { "out" } }
+] T{ template
+    { input { { float "in" } } }
+    { scratch { { f "out" } } }
+    { output { "out" } }
 } define-intrinsic
 
 \ fixnum>float [
     "in" operand %untag-fixnum
     "out" operand "in" operand CVTSI2SD
-] H{
-    { +input+ { { f "in" } } }
-    { +scratch+ { { float "out" } } }
-    { +output+ { "out" } }
-    { +clobber+ { "in" } }
+] T{ template
+    { input { { f "in" } } }
+    { scratch { { float "out" } } }
+    { output { "out" } }
+    { clobber { "in" } }
 } define-intrinsic
 
 : alien-float-get-template
-    H{
-        { +input+ {
+    T{ template
+        { input {
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { float "value" } } }
-        { +output+ { "value" } }
-        { +clobber+ { "offset" } }
+        { scratch { { float "value" } } }
+        { output { "value" } }
+        { clobber { "offset" } }
     } ;
 
 : alien-float-set-template
-    H{
-        { +input+ {
+    T{ template
+        { input {
             { float "value" float }
             { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +clobber+ { "offset" } }
+        { clobber { "offset" } }
     } ;
 
 : define-alien-float-intrinsics ( word get-quot word set-quot -- )

From 0e4e05d5cd738ad9fd2b61dfde00eccca9047d31 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 8 Oct 2008 03:51:44 -0500
Subject: [PATCH 005/318] Debugging new codegen

---
 basis/compiler/cfg/builder/builder.factor     |  5 +-
 basis/compiler/cfg/stacks/stacks.factor       |  4 +-
 basis/compiler/codegen/codegen.factor         |  3 +-
 basis/compiler/tests/intrinsics.factor        | 18 ++++
 .../tree/finalization/finalization.factor     | 85 ++++++++++++++-----
 basis/cpu/architecture/architecture.factor    |  2 +-
 .../cpu/x86/architecture/architecture.factor  |  4 +-
 basis/stack-checker/branches/branches.factor  | 19 +++--
 8 files changed, 99 insertions(+), 41 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 85e49d080e..1a8eae0643 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -158,8 +158,6 @@ M: #if emit-node
             init-phantoms
             ##prologue
             [ emit-nodes ] with-node-iterator
-            ##epilogue
-            ##return
         ] with-cfg-builder
     ] keep ;
 
@@ -304,7 +302,8 @@ M: #return-recursive emit-node
     [ ##epilogue ##return ] unless stop-iterating ;
 
 ! #terminate
-M: #terminate emit-node drop stop-iterating ;
+M: #terminate emit-node
+    drop finalize-phantoms stop-iterating ;
 
 ! FFI
 : return-size ( ctype -- n )
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index beb301d97a..62663bdad0 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -305,9 +305,7 @@ M: loc lazy-store
 : set-value-classes ( classes -- )
     phantom-datastack get
     over length over add-locs
-    stack>> [
-        [ value-class class-and ] keep set-value-class
-    ] 2reverse-each ;
+    stack>> [ set-value-class ] 2reverse-each ;
 
 : finalize-phantoms ( -- )
     #! Commit all deferred stacking shuffling, and ensure the
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index f157ad1d15..d72d50c18d 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -144,7 +144,8 @@ M: _branch-t generate-insn
 
 M: ##dispatch-label generate-insn label>> %dispatch-label ;
 
-M: ##dispatch generate-insn drop %dispatch ;
+M: ##dispatch generate-insn
+    [ src>> v>operand ] [ temp>> v>operand ] bi %dispatch ;
 
 : dst/src ( insn -- dst src )
     [ dst>> v>operand ] [ src>> v>operand ] bi ;
diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor
index f5a1a86ae3..530705af46 100644
--- a/basis/compiler/tests/intrinsics.factor
+++ b/basis/compiler/tests/intrinsics.factor
@@ -461,3 +461,21 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
     ] compile-call
     b>>
 ] unit-test
+
+: mutable-value-bug-1 ( a b -- c )
+    swap [
+        { tuple } declare 1 slot
+    ] [
+        0 slot
+    ] if ;
+
+[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
+
+: mutable-value-bug-2 ( a b -- c )
+    swap [
+        0 slot
+    ] [
+        { tuple } declare 1 slot
+    ] if ;
+
+[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test
diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor
index c312cb68dc..e716849baa 100644
--- a/basis/compiler/tree/finalization/finalization.factor
+++ b/basis/compiler/tree/finalization/finalization.factor
@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel arrays accessors sequences sequences.private words
-fry namespaces make math math.order memoize classes.builtin
-classes.tuple.private slots.private combinators layouts
-byte-arrays alien.accessors
+fry namespaces make math math.private math.order memoize
+classes.builtin classes.tuple.private classes.algebra
+slots.private combinators layouts byte-arrays alien.accessors
 compiler.intrinsics
 compiler.tree
 compiler.tree.combinators
@@ -23,6 +23,10 @@ IN: compiler.tree.finalization
 
 GENERIC: finalize* ( node -- nodes )
 
+: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
+
+: splice-final ( quot -- nodes ) splice-quot finalize ;
+
 M: #copy finalize* drop f ;
 
 M: #shuffle finalize*
@@ -34,30 +38,30 @@ M: #shuffle finalize*
     word>> "predicating" word-prop builtin-class? ;
 
 MEMO: builtin-predicate-expansion ( word -- nodes )
-    def>> splice-quot ;
+    def>> splice-final ;
 
 : expand-builtin-predicate ( #call -- nodes )
     word>> builtin-predicate-expansion ;
 
-: first-literal ( #call -- obj ) node-input-infos first literal>> ;
-
-: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
-
 : expand-tuple-boa? ( #call -- ? )
     dup word>> \ <tuple-boa> eq? [
         last-literal tuple-layout?
     ] [ drop f ] if ;
 
-MEMO: (tuple-boa-expansion) ( n -- quot )
+MEMO: (tuple-boa-expansion) ( n -- nodes )
     [
-        [ 2 + ] map <reversed>
-        [ '[ [ _ set-slot ] keep ] % ] each
-    ] [ ] make ;
+        [ '[ _ (tuple) ] % ]
+        [
+            [ 2 + ] map <reversed>
+            [ '[ [ _ set-slot ] keep ] % ] each
+        ] bi
+    ] [ ] make '[ _ dip ] splice-final ;
 
 : tuple-boa-expansion ( layout -- quot )
     #! No memoization here since otherwise we'd hang on to
     #! tuple layout objects.
-    size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
+    size>> (tuple-boa-expansion)
+    [ over 1 set-slot ] splice-final append ;
 
 : expand-tuple-boa ( #call -- node )
     last-literal tuple-boa-expansion ;
@@ -65,14 +69,15 @@ MEMO: (tuple-boa-expansion) ( n -- quot )
 MEMO: <array>-expansion ( n -- quot )
     [
         [ swap (array) ] %
-        [ \ 2dup , , [ swap set-array-nth ] % ] each
+        [ '[ _ over 1 set-slot ] % ]
+        [ [ '[ 2dup _ swap set-array-nth ] % ] each ] bi
         \ nip ,
-    ] [ ] make splice-quot ;
+    ] [ ] make splice-final ;
 
 : expand-<array>? ( #call -- ? )
     dup word>> \ <array> eq? [
         first-literal dup integer?
-        [ 0 32 between? ] [ drop f ] if
+        [ 0 8 between? ] [ drop f ] if
     ] [ drop f ] if ;
 
 : expand-<array> ( #call -- node )
@@ -83,28 +88,62 @@ MEMO: <array>-expansion ( n -- quot )
 MEMO: <byte-array>-expansion ( n -- quot )
     [
         [ (byte-array) ] %
-        bytes>cells [ cell * ] map
-        [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
-    ] [ ] make splice-quot ;
+        [ '[ _ over 1 set-slot ] % ]
+        [
+            bytes>cells [
+                cell *
+                '[ 0 over _ set-alien-unsigned-cell ] %
+            ] each
+        ] bi
+    ] [ ] make splice-final ;
 
 : expand-<byte-array>? ( #call -- ? )
     dup word>> \ <byte-array> eq? [
         first-literal dup integer?
-        [ 0 128 between? ] [ drop f ] if
+        [ 0 32 between? ] [ drop f ] if
     ] [ drop f ] if ;
 
 : expand-<byte-array> ( #call -- nodes )
     first-literal <byte-array>-expansion ;
 
+MEMO: <ratio>-expansion ( -- quot )
+    [ (ratio) [ 1 set-slot ] keep [ 2 set-slot ] keep ] splice-final ;
+
+: expand-<ratio> ( #call -- nodes )
+    drop <ratio>-expansion ;
+
+MEMO: <complex>-expansion ( -- quot )
+    [ (complex) [ 1 set-slot ] keep [ 2 set-slot ] keep ] splice-final ;
+
+: expand-<complex> ( #call -- nodes )
+    drop <complex>-expansion ;
+
+MEMO: <wrapper>-expansion ( -- quot )
+    [ (wrapper) [ 1 set-slot ] keep ] splice-final ;
+
+: expand-<wrapper> ( #call -- nodes )
+    drop <wrapper>-expansion ;
+
+: expand-set-slot ( #call -- nodes )
+    dup in-d>> first node-value-info class>> immediate class<=
+    [ (set-slot) ] [ over >r (set-slot) r> (write-barrier) ] ?
+    splice-final ;
+
 M: #call finalize*
     {
         { [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
         { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
         { [ dup expand-<array>? ] [ expand-<array> ] }
         { [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
-        [ ]
+        [
+            dup word>> {
+                { \ <ratio> [ expand-<ratio> ] }
+                { \ <complex> [ expand-<complex> ] }
+                { \ <wrapper> [ expand-<wrapper> ] }
+                { \ set-slot [ expand-set-slot ] }
+                [ drop ]
+            } case
+        ]
     } cond ;
 
 M: node finalize* ;
-
-: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index f4243eb987..deed160cc3 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -63,7 +63,7 @@ HOOK: %jump-f cpu ( label vreg -- )
 ! Test if vreg is 't' or not
 HOOK: %jump-t cpu ( label vreg -- )
 
-HOOK: %dispatch cpu ( -- )
+HOOK: %dispatch cpu ( src temp -- )
 
 HOOK: %dispatch-label cpu ( word -- )
 
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 90807ff4ce..d08ef85173 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -69,9 +69,9 @@ M: x86 stack-frame-size ( n -- i )
 
 M: x86 %prologue ( n -- )
     temp-reg-1 0 MOV rc-absolute-cell rel-this
-    dup cell + PUSH
+    dup PUSH
     temp-reg-1 PUSH
-    stack-reg swap 2 cells - SUB ;
+    stack-reg swap 3 cells - SUB ;
 
 : incr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor
index 511dcc6bbd..87d3024475 100644
--- a/basis/stack-checker/branches/branches.factor
+++ b/basis/stack-checker/branches/branches.factor
@@ -78,21 +78,23 @@ SYMBOL: quotations
     V{ } clone meta-r set
     d-in [ ] change ;
 
-: infer-branch ( literal -- namespace )
+: infer-branch ( literal quot -- namespace )
     [
         copy-inference
         nest-visitor
-        [ value>> quotation set ] [ infer-literal-quot ] bi
+        [ [ value>> quotation set ] [ infer-literal-quot ] bi ] dip
         check->r
+        call
     ] H{ } make-assoc ; inline
 
-: infer-branches ( branches -- input children data )
-    [ pop-d ] dip
-    [ infer-branch ] map
-    [ stack-visitor branch-variable ] keep ;
+: infer-branches ( branches quot -- input children data )
+    [ pop-d ] 2dip
+    [ infer-branch ] curry map
+    [ stack-visitor branch-variable ] keep ; inline
 
 : (infer-if) ( branches -- )
-    infer-branches [ first2 #if, ] dip compute-phi-function ;
+    [ ] infer-branches
+    [ first2 #if, ] dip compute-phi-function ;
 
 : infer-if ( -- )
     2 consume-d
@@ -106,4 +108,5 @@ SYMBOL: quotations
 
 : infer-dispatch ( -- )
     pop-literal nip [ <literal> ] map
-    infer-branches [ #dispatch, ] dip compute-phi-function ;
+    [ f #return, ] infer-branches
+    [ #dispatch, ] dip compute-phi-function ;

From cf46a832e72ba6533e31734c42f196743fd48931 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 8 Oct 2008 23:42:53 -0500
Subject: [PATCH 006/318] Debugging register allocator and inline allocation

---
 basis/compiler/cfg/builder/builder.factor     |  6 +--
 .../linear-scan/allocation/allocation.factor  | 33 +++++++++--------
 .../cfg/linear-scan/linear-scan-tests.factor  | 16 ++++++++
 .../cfg/linear-scan/linear-scan.factor        | 10 ++---
 basis/compiler/cfg/stacks/stacks.factor       | 30 +++++++--------
 basis/cpu/architecture/architecture.factor    |  4 +-
 basis/cpu/x86/allot/allot.factor              | 37 ++++++++++---------
 7 files changed, 78 insertions(+), 58 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 1a8eae0643..50101c3cdf 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -250,9 +250,9 @@ M: #dispatch emit-node
 
 : emit-intrinsic ( word -- next )
     {
-        { \ (tuple) [ allot-size 2 cells + tuple tuple emit-allot ] }
-        { \ (array) [ allot-size 2 cells + array object emit-allot ] }
-        { \ (byte-array) [ allot-size cells 2 + byte-array object emit-allot ] }
+        { \ (tuple) [ allot-size 2 + cells tuple tuple emit-allot ] }
+        { \ (array) [ allot-size 2 + cells array object emit-allot ] }
+        { \ (byte-array) [ allot-size 2 cells + byte-array object emit-allot ] }
         { \ (complex) [ 3 cells complex complex emit-allot ] }
         { \ (ratio) [ 3 cells ratio ratio emit-allot ] }
         { \ (wrapper) [ 2 cells wrapper object emit-allot ] }
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 4d1d8543bf..5433908768 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -24,15 +24,21 @@ SYMBOL: active-intervals
 : delete-active ( live-interval -- )
     active-intervals get delete ;
 
+: expired-interval? ( n interval -- ? )
+    [ end>> ] [ start>> ] bi or > ;
+
 : expire-old-intervals ( n -- )
     active-intervals get
-    swap '[ end>> _ < ] partition
-    active-intervals set
-    [ deallocate-register ] each ;
+    [ expired-interval? ] with partition
+    [ [ deallocate-register ] each ] [ active-intervals set ] bi* ;
 
 : expire-old-uses ( n -- )
     active-intervals get
-    swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ;
+    swap '[
+        uses>> [
+            dup peek _ < [ pop* ] [ drop ] if
+        ] unless-empty
+    ] each ;
 
 : update-state ( live-interval -- )
     start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
@@ -59,13 +65,7 @@ SYMBOL: progress
     unhandled-intervals get heap-push-all ;
 
 : assign-free-register ( live-interval registers -- )
-    #! If the live interval does not have any uses, it means it
-    #! will be spilled immediately, so it still needs a register
-    #! to compute the new value, but we don't add the interval
-    #! to the active set and we don't remove the register from
-    #! the free list.
-    over uses>> empty?
-    [ peek >>reg drop ] [ pop >>reg add-active ] if ;
+    pop >>reg add-active ;
 
 ! Spilling
 SYMBOL: spill-counts
@@ -75,7 +75,9 @@ SYMBOL: spill-counts
 
 : interval-to-spill ( -- live-interval )
     #! We spill the interval with the most distant use location.
-    active-intervals get unclip-slice [
+    active-intervals get
+    [ uses>> empty? not ] filter
+    unclip-slice [
         [ [ uses>> peek ] bi@ > ] most
     ] reduce ;
 
@@ -95,15 +97,16 @@ SYMBOL: spill-counts
 
 : assign-spill ( before after -- before after )
     #! If it has been spilled already, reuse spill location.
-    over reload-from>> [ next-spill-location ] unless*
+    USE: cpu.architecture ! XXX
+    over reload-from>>
+    [ int-regs next-spill-location ] unless*
     tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
 
 : split-and-spill ( live-interval -- before after )
     dup split-interval [ record-split ] [ assign-spill ] 2bi ;
 
 : reuse-register ( new existing -- )
-    reg>> >>reg
-    dup uses>> empty? [ deallocate-register ] [ add-active ] if ;
+    reg>> >>reg add-active ;
 
 : spill-existing ( new existing -- )
     #! Our new interval will be used before the active interval
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 8f1378755d..f64534227e 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -2,6 +2,8 @@ IN: compiler.cfg.linear-scan.tests
 USING: tools.test random sorting sequences sets hashtables assocs
 kernel fry arrays splitting namespaces math accessors vectors
 math.order
+cpu.architecture
+compiler.cfg.instructions
 compiler.cfg.registers
 compiler.cfg.linear-scan
 compiler.cfg.linear-scan.live-intervals
@@ -103,3 +105,17 @@ SYMBOL: max-uses
 USING: math.private compiler.cfg.debugger ;
 
 [ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
+
+[ f ] [
+    T{ ##allot
+        f
+        T{ vreg f int-regs 1 }
+        40
+        array
+        object
+        T{ vreg f int-regs 2 }
+        T{ vreg f int-regs 3 }
+        f
+    } clone
+    1array (linear-scan) first regs>> values all-equal?
+] unit-test
diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index 046f2a7eff..4628728299 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -22,12 +22,12 @@ IN: compiler.cfg.linear-scan
 ! by Omri Traub, Glenn Holloway, Michael D. Smith
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
 
+: (linear-scan) ( insns -- insns' )
+    dup compute-live-intervals
+    machine-registers allocate-registers assign-registers ;
+
 : linear-scan ( mr -- mr' )
     [
-        [
-            dup compute-live-intervals
-            machine-registers allocate-registers
-            assign-registers
-        ] change-instructions
+        [ (linear-scan) ] change-instructions
         ! spill-counts get >>spill-counts
     ] with-scope ;
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index 62663bdad0..94557c9320 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -24,7 +24,7 @@ GENERIC: lazy-store ( dst src -- )
 GENERIC: minimal-ds-loc* ( min obj -- min )
 
 ! This will be a multimethod soon
-DEFER: %move
+DEFER: ##move
 
 PRIVATE>
 
@@ -62,7 +62,7 @@ M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
 M: cached (eager-load) >r vreg>> r> (eager-load) ;
 M: cached lazy-store
     2dup loc>> live-loc?
-    [ "live-locs" get at %move ] [ 2drop ] if ;
+    [ "live-locs" get at ##move ] [ 2drop ] if ;
 M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
 
 M: tagged move-spec drop f ;
@@ -78,9 +78,9 @@ M: unboxed-c-ptr move-spec class ;
 M: constant move-spec class ;
 
 ! Moving values between locations and registers
-: %move-bug ( -- * ) "Bug in generator.registers" throw ;
+: ##move-bug ( -- * ) "Bug in generator.registers" throw ;
 
-: %unbox-c-ptr ( dst src -- )
+: ##unbox-c-ptr ( dst src -- )
     dup value-class {
         { [ dup \ f class<= ] [ drop ##unbox-f ] }
         { [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
@@ -88,15 +88,15 @@ M: constant move-spec class ;
         [ drop ##unbox-any-c-ptr ]
     } cond ; inline
 
-: %move-via-temp ( dst src -- )
+: ##move-via-temp ( dst src -- )
     #! For many transfers, such as loc to unboxed-alien, we
     #! don't have an intrinsic, so we transfer the source to
     #! temp then temp to the destination.
-    int-regs next-vreg [ over %move value-class ] keep
+    int-regs next-vreg [ over ##move value-class ] keep
     tagged new
         swap >>vreg
         swap >>class
-    %move ;
+    ##move ;
 
 ! Operands holding pointers to freshly-allocated objects which
 ! are guaranteed to be in the nursery
@@ -106,7 +106,7 @@ SYMBOL: fresh-objects
 
 : fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
 
-: %move ( dst src -- )
+: ##move ( dst src -- )
     2dup [ move-spec ] bi@ 2array {
         { { f f } [ ##copy ] }
         { { unboxed-alien unboxed-alien } [ ##copy ] }
@@ -115,8 +115,8 @@ SYMBOL: fresh-objects
         { { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
         { { float float } [ ##copy-float ] }
 
-        { { f unboxed-c-ptr } [ %move-bug ] }
-        { { f unboxed-byte-array } [ %move-bug ] }
+        { { f unboxed-c-ptr } [ ##move-bug ] }
+        { { f unboxed-byte-array } [ ##move-bug ] }
 
         { { f constant } [ value>> ##load-literal ] }
 
@@ -128,10 +128,10 @@ SYMBOL: fresh-objects
         { { unboxed-alien f } [ ##unbox-alien ] }
         { { unboxed-byte-array f } [ ##unbox-byte-array ] }
         { { unboxed-f f } [ ##unbox-f ] }
-        { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
+        { { unboxed-c-ptr f } [ ##unbox-c-ptr ] }
         { { loc f } [ swap ##replace ] }
 
-        [ drop %move-via-temp ]
+        [ drop ##move-via-temp ]
     } case ;
 
 ! A compile-time stack
@@ -264,10 +264,10 @@ M: value (lazy-load)
 
 M: value (eager-load) ( value spec -- vreg )
     [ alloc-vreg-for ] [ drop ] 2bi
-    [ %move ] [ drop ] 2bi ;
+    [ ##move ] [ drop ] 2bi ;
 
 M: loc lazy-store
-    2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
+    2dup live-loc? [ "live-locs" get at ##move ] [ 2drop ] if ;
 
 : finalize-locs ( -- )
     #! Perform any deferred stack shuffling.
@@ -279,7 +279,7 @@ M: loc lazy-store
 : finalize-vregs ( -- )
     #! Store any vregs to their final stack locations.
     [
-        dup loc? over cached? or [ 2drop ] [ %move ] if
+        dup loc? over cached? or [ 2drop ] [ ##move ] if
     ] each-loc ;
 
 : clear-phantoms ( -- )
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index deed160cc3..230cc18814 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -88,7 +88,7 @@ HOOK: %copy-float cpu ( dst src -- )
 
 ! Box and unbox floats
 HOOK: %unbox-float cpu ( dst src -- )
-HOOK: %box-float cpu ( dst src -- )
+HOOK: %box-float cpu ( dst src temp -- )
 
 ! FFI stuff
 
@@ -184,7 +184,7 @@ HOOK: %unbox-f cpu ( dst src -- )
 
 HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 
-HOOK: %box-alien cpu ( dst src -- )
+HOOK: %box-alien cpu ( dst src temp1 temp2 -- )
 
 ! Allocation
 HOOK: %allot cpu ( dst size type tag temp -- )
diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor
index 7dfd1f4096..659f55af41 100644
--- a/basis/cpu/x86/allot/allot.factor
+++ b/basis/cpu/x86/allot/allot.factor
@@ -12,34 +12,34 @@ M:: x86 %write-barrier ( src temp -- )
     ! Mark the card
     src card-bits SHR
     "cards_offset" f temp %alien-global
-    temp temp [+] card-mark <byte> MOV
+    temp src [+] card-mark <byte> MOV
 
     ! Mark the card deck
-    temp deck-bits card-bits - SHR
+    src deck-bits card-bits - SHR
     "decks_offset" f temp %alien-global
-    temp temp [+] card-mark <byte> MOV ;
+    temp src [+] card-mark <byte> MOV ;
 
 : load-zone-ptr ( reg -- )
     #! Load pointer to start of zone array
     0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
 
-: load-allot-ptr ( temp -- )
-    [ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
+: load-allot-ptr ( nursery-ptr allot-ptr -- )
+    [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
 
-: inc-allot-ptr ( n temp -- )
-    [ POP ] [ cell [+] swap 8 align ADD ] bi ;
+: inc-allot-ptr ( nursery-ptr n -- )
+    [ cell [+] ] dip 8 align ADD ;
 
 : store-header ( temp type -- )
-    [ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
+    [ [] ] [ type-number tag-fixnum ] bi* MOV ;
 
-: store-tagged ( dst temp tag -- )
-    dupd tag-number OR MOV ;
+: store-tagged ( dst tag -- )
+    tag-number OR ;
 
-M:: x86 %allot ( dst size type tag temp -- )
-    temp load-allot-ptr
-    temp type store-header
-    temp size inc-allot-ptr
-    dst temp store-tagged ;
+M:: x86 %allot ( dst size type tag nursery-ptr -- )
+    nursery-ptr dst load-allot-ptr
+    dst type store-header
+    dst tag store-tagged
+    nursery-ptr size inc-allot-ptr ;
 
 M: x86 %gc ( -- )
     "end" define-label
@@ -130,10 +130,11 @@ M:: x86 %box-alien ( dst src temp -- )
 
 \ fixnum>bignum [
     "x" operand %untag-fixnum
-    "x" operand dup "scratch" operand %allot-bignum-signed-1
+    "y" operand "x" operand "scratch" operand %allot-bignum-signed-1
 ] T{ template
     { input { { f "x" } } }
-    { scratch { { f "scratch" } } }
-    { output { "x" } }
+    { scratch { { f "y" } { f "scratch" } } }
+    { output { "y" } }
+    { clobber { "x" } }
     { gc t }
 } define-intrinsic

From 70c6c64766ff12e62b2fcf56d780fd7faf14c112 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 8 Oct 2008 23:43:07 -0500
Subject: [PATCH 007/318] Debugging register allocator and inline allocation

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

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index d72d50c18d..70b72ae80c 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -164,9 +164,12 @@ M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
 
 M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
 
-M: ##box-float generate-insn dst/src %box-float ;
+: dst/src/temp ( insn -- dst src temp )
+    [ dst/src ] [ temp>> v>operand ] bi ;
 
-M: ##box-alien generate-insn dst/src %box-alien ;
+M: ##box-float generate-insn dst/src/temp %box-float ;
+
+M: ##box-alien generate-insn dst/src/temp %box-alien ;
 
 M: ##allot generate-insn
     {

From e5a55dafadaf58d881489770685b75d232856abf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 9 Oct 2008 17:03:30 -0500
Subject: [PATCH 008/318] Fix bignum inline allocator

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

diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor
index 659f55af41..58b6730694 100644
--- a/basis/cpu/x86/allot/allot.factor
+++ b/basis/cpu/x86/allot/allot.factor
@@ -71,7 +71,7 @@ M: x86 %gc ( -- )
         ! Allocate a bignum
         dst 4 cells bignum bignum temp %allot
         ! Write length
-        dst 1 bignum@ 2 MOV
+        dst 1 bignum@ 2 tag-fixnum MOV
         ! Test sign
         src 0 CMP
         "positive" get JGE

From 67dd303d2777b4f01989a8c640eb00b126d15c8d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Oct 2008 02:33:07 -0500
Subject: [PATCH 009/318] Fix excess recompilation

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

diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index 5235f68eca..53ac0aabb8 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -75,7 +75,7 @@ SYMBOL: +failed+
 
 : save-asm ( asm -- )
     [ [ code>> ] [ label>> ] bi compiled get set-at ]
-    [ calls>> [ queue-compile ] each ]
+    [ calls>> [ maybe-compile ] each ]
     bi ;
 
 : backend ( nodes word -- )

From 3e29808f171543ab8fedd4024defe170ef846214 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Oct 2008 02:33:32 -0500
Subject: [PATCH 010/318] Fix loop compilation

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

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 50101c3cdf..6b685dbc1c 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -40,6 +40,7 @@ SYMBOL: procedures
 SYMBOL: current-word
 SYMBOL: current-label
 SYMBOL: loops
+SYMBOL: first-basic-block
 
 ! Basic block after prologue, makes recursion faster
 SYMBOL: current-label-start
@@ -68,9 +69,6 @@ GENERIC: emit-node ( node -- next )
     [ current-node emit-node check-basic-block ] iterate-nodes
     finalize-phantoms ;
 
-: remember-loop ( label -- )
-    basic-block get swap loops get set-at ;
-
 : begin-word ( -- )
     #! We store the basic block after the prologue as a loop
     #! labelled by the current word, so that self-recursive
@@ -79,7 +77,7 @@ GENERIC: emit-node ( node -- next )
     ##prologue
     ##branch
     begin-basic-block
-    current-label get remember-loop ;
+    basic-block get first-basic-block set ;
 
 : (build-cfg) ( nodes word label -- )
     [
@@ -108,8 +106,9 @@ SYMBOL: +if-intrinsics+
 : emit-call ( word -- next )
     finalize-phantoms
     {
-        { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
         { [ dup loops get key? ] [ loops get at local-recursive-call ] }
+        { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
+        { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
         [ ##epilogue ##jump stop-iterating ]
     } cond ;
 
@@ -118,6 +117,9 @@ SYMBOL: +if-intrinsics+
     [ label>> id>> emit-call ]
     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
 
+: remember-loop ( label -- )
+    basic-block get swap loops get set-at ;
+
 : compile-loop ( node -- next )
     finalize-phantoms
     begin-basic-block
@@ -299,7 +301,7 @@ M: #return emit-node
 M: #return-recursive emit-node
     finalize-phantoms
     label>> id>> loops get key?
-    [ ##epilogue ##return ] unless stop-iterating ;
+    [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
 
 ! #terminate
 M: #terminate emit-node

From c98651043cc222115bb4e2670d6c1e95971aa3e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Oct 2008 02:33:47 -0500
Subject: [PATCH 011/318] Fix reversed polarity of FP comparisons

---
 basis/cpu/x86/sse2/sse2.factor | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/basis/cpu/x86/sse2/sse2.factor b/basis/cpu/x86/sse2/sse2.factor
index e1bd0d2f63..e7ab902e07 100644
--- a/basis/cpu/x86/sse2/sse2.factor
+++ b/basis/cpu/x86/sse2/sse2.factor
@@ -37,11 +37,11 @@ M: x86 %unbox-float ( dst src -- )
     { { float "x" } { float "y" } } define-if-intrinsic ;
 
 {
-    { float< JAE }
-    { float<= JA }
-    { float> JBE }
-    { float>= JB }
-    { float= JNE }
+    { float< JB }
+    { float<= JBE }
+    { float> JA }
+    { float>= JAE }
+    { float= JE }
 } [
     first2 define-float-jump
 ] each

From 3844cb62d8061e9a6b100a00d6113fd73f2e9b85 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 10 Oct 2008 03:16:26 -0500
Subject: [PATCH 012/318] Fix %write-barrier

---
 basis/compiler/cfg/builder/builder.factor         |  4 +++-
 .../compiler/cfg/instructions/instructions.factor |  5 +++--
 basis/compiler/codegen/codegen.factor             |  5 ++++-
 basis/cpu/architecture/architecture.factor        |  2 +-
 basis/cpu/x86/allot/allot.factor                  | 15 ++++++++-------
 5 files changed, 19 insertions(+), 12 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 6b685dbc1c..9ee63de7b7 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -247,7 +247,9 @@ M: #dispatch emit-node
 
 : emit-write-barrier ( -- )
     phantom-pop dup >vreg fresh-object? [ drop ] [
-        int-regs next-vreg ##write-barrier
+        int-regs next-vreg
+        int-regs next-vreg
+        ##write-barrier
     ] if ;
 
 : emit-intrinsic ( word -- next )
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 3014587edd..8edcab70c2 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -49,7 +49,7 @@ INSN: ##box-alien < ##unary temp ;
 
 ! Memory allocation
 INSN: ##allot < ##nullary size type tag temp ;
-INSN: ##write-barrier src temp ;
+INSN: ##write-barrier src card# table ;
 INSN: ##gc ;
 
 ! FFI
@@ -62,7 +62,8 @@ GENERIC: uses-vregs ( insn -- seq )
 
 M: ##nullary defs-vregs dst>> >vreg 1array ;
 M: ##unary defs-vregs dst>> >vreg 1array ;
-M: ##write-barrier defs-vregs temp>> >vreg 1array ;
+M: ##write-barrier defs-vregs
+    [ card#>> >vreg ] [ table>> >vreg ] bi 2array ;
 
 : allot-defs-vregs ( insn -- seq )
     [ dst>> >vreg ] [ temp>> >vreg ] bi 2array ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 70b72ae80c..fad62a97ee 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -182,7 +182,10 @@ M: ##allot generate-insn
     %allot ;
 
 M: ##write-barrier generate-insn
-    [ src>> v>operand ] [ temp>> v>operand ] bi %write-barrier ;
+    [ src>> v>operand ]
+    [ card#>> v>operand ]
+    [ table>> v>operand ]
+    tri %write-barrier ;
 
 M: ##gc generate-insn drop %gc ;
 
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 230cc18814..66d7b35518 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -189,7 +189,7 @@ HOOK: %box-alien cpu ( dst src temp1 temp2 -- )
 ! Allocation
 HOOK: %allot cpu ( dst size type tag temp -- )
 
-HOOK: %write-barrier cpu ( src temp -- )
+HOOK: %write-barrier cpu ( src card# table -- )
 
 ! GC check
 HOOK: %gc cpu ( -- )
diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor
index 58b6730694..425479dc89 100644
--- a/basis/cpu/x86/allot/allot.factor
+++ b/basis/cpu/x86/allot/allot.factor
@@ -7,17 +7,18 @@ compiler.constants compiler.cfg.templates compiler.cfg.builder
 compiler.codegen compiler.codegen.fixup ;
 IN: cpu.x86.allot
 
-M:: x86 %write-barrier ( src temp -- )
+M:: x86 %write-barrier ( src card# table -- )
     #! Mark the card pointed to by vreg.
     ! Mark the card
-    src card-bits SHR
-    "cards_offset" f temp %alien-global
-    temp src [+] card-mark <byte> MOV
+    card# src MOV
+    card# card-bits SHR
+    "cards_offset" f table %alien-global
+    table card# [+] card-mark <byte> MOV
 
     ! Mark the card deck
-    src deck-bits card-bits - SHR
-    "decks_offset" f temp %alien-global
-    temp src [+] card-mark <byte> MOV ;
+    card# deck-bits card-bits - SHR
+    "decks_offset" f table %alien-global
+    table card# [+] card-mark <byte> MOV ;
 
 : load-zone-ptr ( reg -- )
     #! Load pointer to start of zone array

From c54668596d6e3f7c66b86b48ae3098498d371543 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 11 Oct 2008 13:58:41 -0500
Subject: [PATCH 013/318] More efficient hi-tag accessor

---
 core/generic/standard/engines/tag/tag.factor | 2 +-
 core/kernel/kernel.factor                    | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index 50813f191c..5bb5b42243 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -46,7 +46,7 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
     "type" word-prop num-tags get - ;
 
 : hi-tag-quot ( -- quot )
-    [ 0 slot ] num-tags get [ fixnum-fast ] curry compose ;
+    \ hi-tag def>> num-tags get [ fixnum-fast ] curry compose ;
 
 M: hi-tag-dispatch-engine engine>quot
     methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 55ed67e0fa..a967eb6a74 100644
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -192,10 +192,10 @@ ERROR: assert got expect ;
 
 <PRIVATE
 
-: hi-tag ( obj -- n ) 0 slot ; inline
-
 : declare ( spec -- ) drop ;
 
+: hi-tag ( obj -- n ) { hi-tag } declare 0 slot ; inline
+
 : do-primitive ( number -- ) "Improper primitive call" throw ;
 
 PRIVATE>

From f979ae5b826964f123775e9d8653ad1c6a3b8cee Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 11 Oct 2008 14:05:15 -0500
Subject: [PATCH 014/318] Expand slot accessors further to avoid having to use
 complex template decision

---
 basis/compiler/cfg/registers/registers.factor | 14 ---------
 basis/compiler/cfg/stacks/stacks.factor       | 29 ++-----------------
 basis/compiler/intrinsics/intrinsics.factor   |  8 +++--
 .../tree/finalization/finalization.factor     | 22 ++++++++++++--
 4 files changed, 27 insertions(+), 46 deletions(-)

diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor
index 3a4a82f70b..dc109cf62e 100644
--- a/basis/compiler/cfg/registers/registers.factor
+++ b/basis/compiler/cfg/registers/registers.factor
@@ -38,20 +38,6 @@ TUPLE: rs-loc < loc ;
 
 INSTANCE: loc value
 
-! A stack location which has been loaded into a register. To
-! read the location, we just read the register, but when time
-! comes to save it back to the stack, we know the register just
-! contains a stack value so we don't have to redundantly write
-! it back.
-TUPLE: cached loc vreg ;
-C: <cached> cached
-
-M: cached set-value-class vreg>> set-value-class ;
-M: cached value-class* vreg>> value-class* ;
-M: cached >vreg vreg>> >vreg ;
-
-INSTANCE: cached value
-
 ! A tagged pointer
 TUPLE: tagged vreg class ;
 : <tagged> ( vreg -- tagged ) f tagged boa ;
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index 94557c9320..3da0281298 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -56,15 +56,6 @@ M: loc move-spec drop loc ;
 M: f move-spec drop loc ;
 M: f value-class* ;
 
-M: cached move-spec drop cached ;
-M: cached live-loc? loc>> live-loc? ;
-M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
-M: cached (eager-load) >r vreg>> r> (eager-load) ;
-M: cached lazy-store
-    2dup loc>> live-loc?
-    [ "live-locs" get at ##move ] [ 2drop ] if ;
-M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
-
 M: tagged move-spec drop f ;
 
 M: unboxed-alien move-spec class ;
@@ -278,9 +269,7 @@ M: loc lazy-store
 
 : finalize-vregs ( -- )
     #! Store any vregs to their final stack locations.
-    [
-        dup loc? over cached? or [ 2drop ] [ ##move ] if
-    ] each-loc ;
+    [ dup loc? [ 2drop ] [ ##move ] if ] each-loc ;
 
 : clear-phantoms ( -- )
     [ stack>> delete-all ] each-phantom ;
@@ -289,19 +278,6 @@ M: loc lazy-store
     finalize-locs finalize-vregs clear-phantoms ;
 
 ! Loading stacks to vregs
-: vreg-substitution ( value vreg -- pair )
-    dupd <cached> 2array ;
-
-: substitute-vreg? ( old new -- ? )
-    #! We don't substitute locs for float or alien vregs,
-    #! since in those cases the boxing overhead might kill us.
-    vreg>> tagged? >r loc? r> and ;
-
-: substitute-vregs ( values vregs -- )
-    [ vreg-substitution ] 2map
-    [ substitute-vreg? ] assoc-filter >hashtable
-    '[ stack>> _ substitute-here ] each-phantom ;
-
 : set-value-classes ( classes -- )
     phantom-datastack get
     over length over add-locs
@@ -350,5 +326,4 @@ M: loc lazy-store
     phantom-retainstack get phantom-input drop ;
 
 : phantom-pop ( -- vreg )
-    1 phantom-datastack get phantom-input dup first f (lazy-load)
-    [ 1array substitute-vregs ] keep ;
+    1 phantom-datastack get phantom-input first f (lazy-load) ;
diff --git a/basis/compiler/intrinsics/intrinsics.factor b/basis/compiler/intrinsics/intrinsics.factor
index 471c05ee59..2ce01d6659 100644
--- a/basis/compiler/intrinsics/intrinsics.factor
+++ b/basis/compiler/intrinsics/intrinsics.factor
@@ -36,9 +36,13 @@ ERROR: missing-intrinsic ;
 \ (wrapper) { } { wrapper } define-primitive
 \ (wrapper) make-flushable
 
-: (set-slot) ( val obj n -- ) missing-intrinsic ;
+: (slot) ( obj n tag# -- val ) missing-intrinsic ;
 
-\ (set-slot) { object object fixnum } { } define-primitive
+\ (slot) { object fixnum fixnum } { object } define-primitive
+
+: (set-slot) ( val obj n tag# -- ) missing-intrinsic ;
+
+\ (set-slot) { object object fixnum fixnum } { } define-primitive
 
 : (write-barrier) ( obj -- ) missing-intrinsic ;
 
diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor
index e716849baa..c9d9f7df01 100644
--- a/basis/compiler/tree/finalization/finalization.factor
+++ b/basis/compiler/tree/finalization/finalization.factor
@@ -124,10 +124,25 @@ MEMO: <wrapper>-expansion ( -- quot )
 : expand-<wrapper> ( #call -- nodes )
     drop <wrapper>-expansion ;
 
+MEMO: slot-expansion ( tag -- nodes )
+    '[ _ (slot) ] splice-final ;
+
+: value-tag ( node value -- n )
+    node-value-info class>> class-tag ;
+
+: expand-slot ( #call -- nodes )
+    dup dup in-d>> first value-tag [ slot-expansion ] [ ] ?if ;
+
+MEMO: set-slot-expansion ( write-barrier? tag# -- nodes )
+    [ '[ [ _ (set-slot) ] [ drop (write-barrier) ] 2bi ] ]
+    [ '[ _ (set-slot) ] ]
+    bi ? splice-final ;
+
 : expand-set-slot ( #call -- nodes )
-    dup in-d>> first node-value-info class>> immediate class<=
-    [ (set-slot) ] [ over >r (set-slot) r> (write-barrier) ] ?
-    splice-final ;
+    dup dup in-d>> second value-tag [
+        [ dup in-d>> first node-value-info class>> immediate class<= not ] dip
+        set-slot-expansion
+    ] when* ;
 
 M: #call finalize*
     {
@@ -141,6 +156,7 @@ M: #call finalize*
                 { \ <complex> [ expand-<complex> ] }
                 { \ <wrapper> [ expand-<wrapper> ] }
                 { \ set-slot [ expand-set-slot ] }
+                { \ slot [ expand-slot ] }
                 [ drop ]
             } case
         ]

From 048d8daf097f83b5a22c0cb090e42d7efe12c767 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 11 Oct 2008 14:05:24 -0500
Subject: [PATCH 015/318] Update intrinsics

---
 basis/cpu/x86/intrinsics/intrinsics.factor | 59 +++++++---------------
 1 file changed, 17 insertions(+), 42 deletions(-)

diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor
index 2eea80b3eb..2425a08922 100644
--- a/basis/cpu/x86/intrinsics/intrinsics.factor
+++ b/basis/cpu/x86/intrinsics/intrinsics.factor
@@ -20,69 +20,44 @@ IN: cpu.x86.intrinsics
 } define-intrinsic
 
 ! Slots
-: %slot-literal-known-tag ( -- op )
+: %constant-slot ( -- op )
     "obj" operand
-    "n" literal cells
-    "obj" operand-tag - [+] ;
+    "n" literal cells "tag" literal - [+] ;
 
-: %slot-literal-any-tag ( -- op )
-    "obj" operand %untag
-    "obj" operand "n" literal cells [+] ;
-
-: %slot-any ( -- op )
-    "obj" operand %untag
+: %computed-slot ( -- op )
     "n" operand fixnum>slot@
-    "obj" operand "n" operand [+] ;
+    "n" operand "obj" operand ADD
+    "n" operand "tag" literal neg [+] ;
 
-\ slot {
-    ! Slot number is literal and the tag is known
+\ (slot) {
     {
-        [ "val" operand %slot-literal-known-tag MOV ] T{ template
-            { input { { f "obj" known-tag } { small-slot "n" } } }
+        [ "val" operand %constant-slot MOV ] T{ template
+            { input { { f "obj" } { small-slot "n" } { small-slot "tag" } } }
             { scratch { { f "val" } } }
             { output { "val" } }
         }
     }
-    ! Slot number is literal
     {
-        [ "obj" operand %slot-literal-any-tag MOV ] T{ template
-            { input { { f "obj" } { small-slot "n" } } }
-            { output { "obj" } }
-        }
-    }
-    ! Slot number in a register
-    {
-        [ "obj" operand %slot-any MOV ] T{ template
-            { input { { f "obj" } { f "n" } } }
-            { output { "obj" } }
+        [ "val" operand %computed-slot MOV ] T{ template
+            { input { { f "obj" } { f "n" } { small-slot "tag" } } }
+            { scratch { { f "val" } } }
+            { output { "val" } }
             { clobber { "n" } }
         }
     }
 } define-intrinsics
 
 \ (set-slot) {
-    ! Slot number is literal and the tag is known
     {
-        [ %slot-literal-known-tag "val" operand MOV ] T{ template
-            { input { { f "val" } { f "obj" known-tag } { small-slot "n" } } }
-            { scratch { { f "scratch" } } }
+        [ %constant-slot "val" operand MOV ] T{ template
+            { input { { f "val" } { f "obj" } { small-slot "n" } { small-slot "tag" } } }
             { clobber { "obj" } }
         }
     }
-    ! Slot number is literal
     {
-        [ %slot-literal-any-tag "val" operand MOV ] T{ template
-            { input { { f "val" } { f "obj" } { small-slot "n" } } }
-            { scratch { { f "scratch" } } }
-            { clobber { "obj" } }
-        }
-    }
-    ! Slot number in a register
-    {
-        [ %slot-any "val" operand MOV ] T{ template
-            { input { { f "val" } { f "obj" } { f "n" } } }
-            { scratch { { f "scratch" } } }
-            { clobber { "obj" "n" } }
+        [ %computed-slot "val" operand MOV ] T{ template
+            { input { { f "val" } { f "obj" } { small-slot "n" } { small-slot "tag" } } }
+            { clobber { "n" } }
         }
     }
 } define-intrinsics

From 68c9b22cefa1a349a794d28f40bbbb0d76b4b447 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 11 Oct 2008 14:08:00 -0500
Subject: [PATCH 016/318] Don't need known-tag templates any more

---
 basis/compiler/cfg/stacks/stacks.factor       | 2 --
 basis/compiler/cfg/templates/templates.factor | 6 +-----
 2 files changed, 1 insertion(+), 7 deletions(-)

diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index 3da0281298..39d8109b05 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -9,8 +9,6 @@ IN: compiler.cfg.stacks
 
 ! Converting stack operations into register operations, while
 ! doing a bit of optimization along the way.
-SYMBOL: known-tag
-
 PREDICATE: small-slot < integer cells small-enough? ;
 
 PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
diff --git a/basis/compiler/cfg/templates/templates.factor b/basis/compiler/cfg/templates/templates.factor
index 0e8f49676c..33c0efae55 100644
--- a/basis/compiler/cfg/templates/templates.factor
+++ b/basis/compiler/cfg/templates/templates.factor
@@ -73,11 +73,7 @@ TUPLE: template input output scratch clobber gc ;
     } cond ;
 
 : class-matches? ( actual expected -- ? )
-    {
-        { f [ drop t ] }
-        { known-tag [ dup [ class-tag >boolean ] when ] }
-        [ class<= ]
-    } case ;
+    dup [ class<= ] [ 2drop t ] if ;
 
 : spec-matches? ( value spec -- ? )
     2dup first value-matches?

From 37047a3b8e315ee333382507c6fdfacaa2461e0b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 11 Oct 2008 14:08:26 -0500
Subject: [PATCH 017/318] Add experimental rice

---
 basis/float-arrays/float-arrays.factor | 40 ++++++++++++++++++++++++++
 1 file changed, 40 insertions(+)

diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor
index 411643ddc0..b5951997f0 100644
--- a/basis/float-arrays/float-arrays.factor
+++ b/basis/float-arrays/float-arrays.factor
@@ -64,6 +64,7 @@ M: float-array pprint-delims drop \ F{ \ } ;
 M: float-array >pprint-sequence ;
 M: float-array pprint* pprint-object ;
 
+! Rice
 USING: hints math.vectors arrays ;
 
 HINTS: vneg { float-array } { array } ;
@@ -81,3 +82,42 @@ HINTS: v. { float-array float-array } { array array } ;
 HINTS: norm-sq { float-array } { array } ;
 HINTS: norm { float-array } { array } ;
 HINTS: normalize { float-array } { array } ;
+
+! More rice. Experimental, currently causes a slowdown in raytracer
+! for some odd reason.
+
+! USING: words classes.algebra compiler.tree.propagation.info ;
+! 
+! { v+ v- v* v/ vmax vmin } [
+!     [
+!         [ class>> float-array class<= ] both?
+!         float-array object ? <class-info>
+!     ] "outputs" set-word-prop
+! ] each
+! 
+! { n*v n/v } [
+!     [
+!         nip class>> float-array class<= float-array object ? <class-info>
+!     ] "outputs" set-word-prop
+! ] each
+! 
+! { v*n v/n } [
+!     [
+!         drop class>> float-array class<= float-array object ? <class-info>
+!     ] "outputs" set-word-prop
+! ] each
+! 
+! { vneg normalize } [
+!     [
+!         class>> float-array class<= float-array object ? <class-info>
+!     ] "outputs" set-word-prop
+! ] each
+! 
+! \ norm-sq [
+!     class>> float-array class<= float object ? <class-info>
+! ] "outputs" set-word-prop
+! 
+! \ v. [
+!     [ class>> float-array class<= ] both?
+!     float object ? <class-info>
+! ] "outputs" set-word-prop

From 5f93ab74e4c8ec32b9c9a68be6c033d9fa476046 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 12 Oct 2008 16:46:59 -0500
Subject: [PATCH 018/318] Fix #dispatch generation

---
 basis/compiler/cfg/builder/builder.factor    | 14 +++++++++-----
 basis/compiler/cfg/iterator/iterator.factor  |  3 ---
 basis/stack-checker/branches/branches.factor | 15 +++++++--------
 3 files changed, 16 insertions(+), 16 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 9ee63de7b7..3cc2c13311 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -82,7 +82,8 @@ GENERIC: emit-node ( node -- next )
 : (build-cfg) ( nodes word label -- )
     [
         begin-word
-        [ emit-nodes ] with-node-iterator
+        V{ } clone node-stack set
+        emit-nodes
     ] with-cfg-builder ;
 
 : build-cfg ( nodes word -- procedures )
@@ -152,14 +153,17 @@ M: #if emit-node
 
 ! #dispatch
 : dispatch-branch ( nodes word -- label )
-    #! The order here is important, dispatch-branches must
-    #! run after ##dispatch, so that each branch gets the
-    #! correct register state
     gensym [
         [
+            V{ } clone node-stack set
             init-phantoms
             ##prologue
-            [ emit-nodes ] with-node-iterator
+            emit-nodes
+            basic-block get [
+                ##epilogue
+                ##return
+                end-basic-block
+            ] when
         ] with-cfg-builder
     ] keep ;
 
diff --git a/basis/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor
index 904da3f0c3..3444b517ac 100644
--- a/basis/compiler/cfg/iterator/iterator.factor
+++ b/basis/compiler/cfg/iterator/iterator.factor
@@ -19,9 +19,6 @@ SYMBOL: node-stack
         [ swap >node call node> drop ] keep iterate-nodes
     ] if ; inline recursive
 
-: with-node-iterator ( quot -- )
-    >r V{ } clone node-stack r> with-variable ; inline
-
 DEFER: (tail-call?)
 
 : tail-phi? ( cursor -- ? )
diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor
index 87d3024475..6b73661471 100644
--- a/basis/stack-checker/branches/branches.factor
+++ b/basis/stack-checker/branches/branches.factor
@@ -78,22 +78,21 @@ SYMBOL: quotations
     V{ } clone meta-r set
     d-in [ ] change ;
 
-: infer-branch ( literal quot -- namespace )
+: infer-branch ( literal -- namespace )
     [
         copy-inference
         nest-visitor
-        [ [ value>> quotation set ] [ infer-literal-quot ] bi ] dip
+        [ value>> quotation set ] [ infer-literal-quot ] bi
         check->r
-        call
     ] H{ } make-assoc ; inline
 
-: infer-branches ( branches quot -- input children data )
-    [ pop-d ] 2dip
-    [ infer-branch ] curry map
+: infer-branches ( branches -- input children data )
+    [ pop-d ] dip
+    [ infer-branch ] map
     [ stack-visitor branch-variable ] keep ; inline
 
 : (infer-if) ( branches -- )
-    [ ] infer-branches
+    infer-branches
     [ first2 #if, ] dip compute-phi-function ;
 
 : infer-if ( -- )
@@ -108,5 +107,5 @@ SYMBOL: quotations
 
 : infer-dispatch ( -- )
     pop-literal nip [ <literal> ] map
-    [ f #return, ] infer-branches
+    infer-branches
     [ #dispatch, ] dip compute-phi-function ;

From 2f4f86d288ebdf553b4fc721e07def4089aee225 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 12 Oct 2008 17:36:34 -0500
Subject: [PATCH 019/318] Fix (set-slot) template

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

diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor
index 2425a08922..b7a5b6063b 100644
--- a/basis/cpu/x86/intrinsics/intrinsics.factor
+++ b/basis/cpu/x86/intrinsics/intrinsics.factor
@@ -56,7 +56,7 @@ IN: cpu.x86.intrinsics
     }
     {
         [ %computed-slot "val" operand MOV ] T{ template
-            { input { { f "val" } { f "obj" } { small-slot "n" } { small-slot "tag" } } }
+            { input { { f "val" } { f "obj" } { f "n" } { small-slot "tag" } } }
             { clobber { "n" } }
         }
     }

From b2ade7f5562e21cf5b502c3e22a263a4e0ef1f09 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 12 Oct 2008 17:37:26 -0500
Subject: [PATCH 020/318] Fix callbacks and non-tailcalls to dispatch

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

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 3cc2c13311..df437024b7 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -178,11 +178,14 @@ M: #if emit-node
     [ finalize-phantoms ##epilogue ] 2dip ##dispatch
     dispatch-branches init-phantoms ;
 
+: <dispatch-block> ( -- word )
+    gensym dup t "inlined-block" set-word-prop ;
+
 M: #dispatch emit-node
     tail-call? [
         emit-dispatch stop-iterating
     ] [
-        current-word get gensym [
+        current-word get <dispatch-block> [
             [
                 begin-word
                 emit-dispatch
@@ -329,12 +332,9 @@ M: #terminate emit-node
         [ alien-parameters parameter-sizes drop >>params ] bi
         dup [ params>> ] [ return>> ] bi + >>size ;
 
-: alien-stack-frame ( node -- )
-    params>> <alien-stack-frame> ##stack-frame ;
-
 : emit-alien-node ( node quot -- next )
-    [ drop alien-stack-frame ]
-    [ [ params>> ] dip call ] 2bi
+    [ params>> ] dip
+    [ drop <alien-stack-frame> ##stack-frame ] [ call ] 2bi
     iterate-next ; inline
 
 M: #alien-invoke emit-node
@@ -344,7 +344,7 @@ M: #alien-indirect emit-node
     [ ##alien-indirect ] emit-alien-node ;
 
 M: #alien-callback emit-node
-    params>> dup xt>> dup
+    dup params>> xt>> dup
     [
         init-phantoms
         [ ##alien-callback ] emit-alien-node drop

From 8eacd0e58ba045f3bb925eba341f6ef3cb747de9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 12 Oct 2008 17:37:42 -0500
Subject: [PATCH 021/318] Add compile-dependencies? flag, can be switched off
 for debugging

---
 basis/compiler/compiler.factor | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index 53ac0aabb8..c94252e7ac 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -73,9 +73,14 @@ SYMBOL: +failed+
         ] [ drop ] if
     ] tri ;
 
+! Only switch this off for debugging.
+SYMBOL: compile-dependencies?
+
+t compile-dependencies? set-global
+
 : save-asm ( asm -- )
     [ [ code>> ] [ label>> ] bi compiled get set-at ]
-    [ calls>> [ maybe-compile ] each ]
+    [ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
     bi ;
 
 : backend ( nodes word -- )

From 749c77d6b1c4cf6489135bb2ca425e0dc7d69a1a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 12 Oct 2008 18:40:10 -0500
Subject: [PATCH 022/318] Fix linear scan test

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

diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index f64534227e..1784886154 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -114,7 +114,6 @@ USING: math.private compiler.cfg.debugger ;
         array
         object
         T{ vreg f int-regs 2 }
-        T{ vreg f int-regs 3 }
         f
     } clone
     1array (linear-scan) first regs>> values all-equal?

From ed27d839215ed6b82c63896ca547eb7cab537ddd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 12 Oct 2008 18:40:43 -0500
Subject: [PATCH 023/318] Add missing method

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

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index fad62a97ee..a35960117c 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -198,6 +198,8 @@ M: single-float-regs reg-size drop 4 ;
 
 M: double-float-regs reg-size drop 8 ;
 
+M: stack-params reg-size drop "void*" heap-size ;
+
 GENERIC: reg-class-variable ( register-class -- symbol )
 
 M: reg-class reg-class-variable ;

From 40c1529ce8a5908bec5dc84f359d9e104f4dc8f7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 12 Oct 2008 18:40:57 -0500
Subject: [PATCH 024/318] Add stack effect

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

diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 635dd42532..d7e82402d5 100644
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -173,7 +173,7 @@ C-STRUCT: rect
     { "float" "h" }
 ;
 
-: <rect>
+: <rect> ( x y w h -- rect )
     "rect" <c-object>
     [ set-rect-h ] keep
     [ set-rect-w ] keep

From ae3c4ae1b62451a8ff5dbee198fc5820c776738c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 12 Oct 2008 23:32:14 -0500
Subject: [PATCH 025/318] Fix some problems with callbacks

---
 basis/compiler/cfg/builder/builder.factor         | 12 +++++++++---
 .../compiler/cfg/instructions/instructions.factor |  1 +
 basis/compiler/codegen/codegen.factor             | 15 +++------------
 basis/cpu/architecture/architecture.factor        |  8 ++++++--
 basis/cpu/ppc/architecture/architecture.factor    |  4 ----
 basis/cpu/x86/32/32.factor                        | 13 +++++++++++--
 basis/cpu/x86/64/64.factor                        |  4 ----
 basis/cpu/x86/allot/allot.factor                  |  2 +-
 basis/cpu/x86/architecture/architecture.factor    |  2 +-
 9 files changed, 32 insertions(+), 29 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index df437024b7..3bc4a738c1 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -332,9 +332,12 @@ M: #terminate emit-node
         [ alien-parameters parameter-sizes drop >>params ] bi
         dup [ params>> ] [ return>> ] bi + >>size ;
 
+: alien-stack-frame ( params -- )
+    <alien-stack-frame> ##stack-frame ;
+
 : emit-alien-node ( node quot -- next )
-    [ params>> ] dip
-    [ drop <alien-stack-frame> ##stack-frame ] [ call ] 2bi
+    finalize-phantoms
+    [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
     iterate-next ; inline
 
 M: #alien-invoke emit-node
@@ -347,7 +350,10 @@ M: #alien-callback emit-node
     dup params>> xt>> dup
     [
         init-phantoms
-        [ ##alien-callback ] emit-alien-node drop
+        ##prologue
+        dup [ ##alien-callback ] emit-alien-node drop
+        ##epilogue
+        params>> ##callback-return
     ] with-cfg-builder
     iterate-next ;
 
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 8edcab70c2..d92520c77d 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -56,6 +56,7 @@ INSN: ##gc ;
 INSN: ##alien-invoke params ;
 INSN: ##alien-indirect params ;
 INSN: ##alien-callback params ;
+INSN: ##callback-return params ;
 
 GENERIC: defs-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index a35960117c..0a79d14778 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -428,23 +428,14 @@ TUPLE: callback-context ;
 
 : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
 
-: callback-unwind ( params -- n )
-    {
-        { [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
-        { [ dup return>> large-struct? ] [ drop 4 ] }
-        [ drop 0 ]
-    } cond ;
-
-: %callback-return ( params -- )
+M: ##callback-return generate-insn
     #! All the extra book-keeping for %unwind is only for x86.
     #! On other platforms its an alias for %return.
-    dup alien-return
-    [ %unnest-stacks ] [ %callback-value ] if-void
-    callback-unwind %unwind ;
+    params>> %callback-return ;
 
 M: ##alien-callback generate-insn
     params>>
     [ registers>objects ]
     [ wrap-callback-quot %alien-callback ]
-    [ %callback-return ]
+    [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
     tri ;
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 66d7b35518..31cd979025 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -137,14 +137,18 @@ M: object %prepare-var-args ;
 
 HOOK: %alien-invoke cpu ( function library -- )
 
-HOOK: %cleanup cpu ( alien-node -- )
+HOOK: %cleanup cpu ( params -- )
+
+M: object %cleanup ( params -- ) drop ;
 
 HOOK: %alien-callback cpu ( quot -- )
 
 HOOK: %callback-value cpu ( ctype -- )
 
 ! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind cpu ( n -- )
+HOOK: %callback-return cpu ( params -- )
+
+M: object %callback-return drop %return ;
 
 HOOK: %prepare-alien-indirect cpu ( -- )
 
diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor
index 117ab51fe2..f19b71f3e4 100644
--- a/basis/cpu/ppc/architecture/architecture.factor
+++ b/basis/cpu/ppc/architecture/architecture.factor
@@ -128,8 +128,6 @@ M: ppc %dispatch-label ( word -- )
 
 M: ppc %return ( -- ) %epilogue-later BLR ;
 
-M: ppc %unwind drop %return ;
-
 M: ppc %peek ( vreg loc -- )
     >r v>operand r> loc>operand LWZ ;
 
@@ -267,8 +265,6 @@ M: ppc %callback-value ( ctype -- )
      ! Unbox former top of data stack to return registers
      unbox-return ;
 
-M: ppc %cleanup ( alien-node -- ) drop ;
-
 : %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
 
 : %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 67809c4d91..a170878eec 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -244,7 +244,7 @@ M: x86.32 %callback-value ( ctype -- )
     ! Unbox EAX
     unbox-return ;
 
-M: x86.32 %cleanup ( alien-node -- )
+M: x86.32 %cleanup ( params -- )
     #! a) If we just called an stdcall function in Windows, it
     #! cleaned up the stack frame for us. But we don't want that
     #! so we 'undo' the cleanup since we do that in %epilogue.
@@ -261,7 +261,16 @@ M: x86.32 %cleanup ( alien-node -- )
         [ drop ]
     } cond ;
 
-M: x86.32 %unwind ( n -- ) RET ;
+M: x86.32 %callback-return ( n -- )
+    #! a) If the callback is stdcall, we have to clean up the
+    #! caller's stack frame.
+    #! b) If the callback is returning a large struct, we have
+    #! to fix ESP.
+    {
+        { [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
+        { [ dup return>> large-struct? ] [ drop 4 ] }
+        [ drop 0 ]
+    } cond RET ;
 
 os windows? [
     cell "longlong" c-type (>>align)
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 6a3d272dfb..07ee01270a 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -222,10 +222,6 @@ M: x86.64 %callback-value ( ctype -- )
     ! Unbox former top of data stack to return registers
     unbox-return ;
 
-M: x86.64 %cleanup ( alien-node -- ) drop ;
-
-M: x86.64 %unwind ( n -- ) drop 0 RET ;
-
 USE: cpu.x86.intrinsics
 
 ! On 64-bit systems, the result of reading 4 bytes from memory
diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor
index 425479dc89..13d81e0d89 100644
--- a/basis/cpu/x86/allot/allot.factor
+++ b/basis/cpu/x86/allot/allot.factor
@@ -100,7 +100,7 @@ M:: x86 %box-alien ( dst src temp -- )
         dst 3 alien@ src MOV
         "end" get JMP
         "f" resolve-label
-        \ f tag-number MOV
+        dst \ f tag-number MOV
         "end" resolve-label
     ] with-scope ;
 
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index d08ef85173..d4b5efd378 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -149,7 +149,7 @@ M: x86 small-enough? ( n -- ? )
 
 : %tag-fixnum ( reg -- ) tag-bits get SHL ;
 
-M: x86 %return ( -- ) 0 %unwind ;
+M: x86 %return ( -- ) 0 RET ;
 
 ! Alien intrinsics
 M: x86 %unbox-byte-array ( dst src -- )

From d8d3645d725a6250f237a028f2231e7fe2045c8f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 13 Oct 2008 12:49:20 -0500
Subject: [PATCH 026/318] Fixing more codegen bugs

---
 basis/compiler/tree/finalization/finalization.factor | 4 ++--
 basis/cpu/architecture/architecture.factor           | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor
index c9d9f7df01..5b09cfab63 100644
--- a/basis/compiler/tree/finalization/finalization.factor
+++ b/basis/compiler/tree/finalization/finalization.factor
@@ -107,13 +107,13 @@ MEMO: <byte-array>-expansion ( n -- quot )
     first-literal <byte-array>-expansion ;
 
 MEMO: <ratio>-expansion ( -- quot )
-    [ (ratio) [ 1 set-slot ] keep [ 2 set-slot ] keep ] splice-final ;
+    [ (ratio) [ 2 set-slot ] keep [ 1 set-slot ] keep ] splice-final ;
 
 : expand-<ratio> ( #call -- nodes )
     drop <ratio>-expansion ;
 
 MEMO: <complex>-expansion ( -- quot )
-    [ (complex) [ 1 set-slot ] keep [ 2 set-slot ] keep ] splice-final ;
+    [ (complex) [ 2 set-slot ] keep [ 1 set-slot ] keep ] splice-final ;
 
 : expand-<complex> ( #call -- nodes )
     drop <complex>-expansion ;
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 31cd979025..1931187779 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -188,7 +188,7 @@ HOOK: %unbox-f cpu ( dst src -- )
 
 HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 
-HOOK: %box-alien cpu ( dst src temp1 temp2 -- )
+HOOK: %box-alien cpu ( dst src temp -- )
 
 ! Allocation
 HOOK: %allot cpu ( dst size type tag temp -- )

From fedadc8032fbdf820c7dc9ea7cbf3e2d91417590 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 13 Oct 2008 13:08:28 -0500
Subject: [PATCH 027/318] Remove obsolete test file

---
 basis/compiler/tests/templates-early.factor | 220 --------------------
 1 file changed, 220 deletions(-)
 delete mode 100644 basis/compiler/tests/templates-early.factor

diff --git a/basis/compiler/tests/templates-early.factor b/basis/compiler/tests/templates-early.factor
deleted file mode 100644
index d3bc4a8a08..0000000000
--- a/basis/compiler/tests/templates-early.factor
+++ /dev/null
@@ -1,220 +0,0 @@
-! Testing templates machinery without compiling anything
-IN: compiler.tests
-USING: compiler compiler.generator compiler.generator.registers
-compiler.generator.registers.private tools.test namespaces
-sequences words kernel math effects definitions compiler.units
-accessors cpu.architecture make ;
-
-: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
-
-[
-    [ ] [ init-templates ] unit-test
-    
-    [ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test
-    
-    [ ] [ 0 <int-vreg> phantom-push ] unit-test
-    
-    [ ] [ compute-free-vregs ] unit-test
-    
-    [ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
-    
-    [ f ] [
-        [
-            copy-templates
-            1 <int-vreg> phantom-push
-            compute-free-vregs
-            1 <int-vreg> int-regs free-vregs member?
-        ] with-scope
-    ] unit-test
-    
-    [ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
-] with-scope
-
-[
-    [ ] [ init-templates ] unit-test
-    
-    [ ] [ T{ effect f 3 { 1 2 0 } f } phantom-shuffle ] unit-test
-    
-    [ 3 ] [ live-locs length ] unit-test
-    
-    [ ] [ T{ effect f 2 { 1 0 } f } phantom-shuffle ] unit-test
-    
-    [ 2 ] [ live-locs length ] unit-test
-] with-scope
-
-[
-    [ ] [ init-templates ] unit-test
-
-    H{ } clone compiled set
-
-    [ ] [ gensym gensym begin-compiling ] unit-test
-
-    [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-
-    3 fresh-object
-
-    [ f ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-[
-    [ ] [ init-templates ] unit-test
-    
-    H{
-        { +input+ { { f "x" } } }
-    } clone [
-        [ 1 0 ] [ +input+ get { } { } guess-vregs ] unit-test
-        [ ] [ finalize-contents ] unit-test
-        [ ] [ [ template-inputs ] { } make drop ] unit-test
-    ] bind
-] with-scope
-
-! Test template picking strategy
-SYMBOL: template-chosen
-
-: template-test ( a b -- c d ) ;
-
-\ template-test {
-    {
-        [
-            1 template-chosen get push
-        ] H{
-            { +input+ { { f "obj" } { [ ] "n" } } }
-            { +output+ { "obj" "obj" } }
-        }
-    }
-    {
-        [
-            2 template-chosen get push
-        ] H{
-            { +input+ { { f "obj" } { f "n" } } }
-            { +output+ { "obj" "n" } }
-        }
-    }
-} define-intrinsics
-
-[ V{ 2 } ] [
-    V{ } clone template-chosen set
-    0 0 [ template-test ] compile-call 2drop
-    template-chosen get
-] unit-test
-
-[ V{ 1 } ] [
-    V{ } clone template-chosen set
-    1 [ dup 0 template-test ] compile-call 3drop
-    template-chosen get
-] unit-test
-
-[ V{ 1 } ] [
-    V{ } clone template-chosen set
-    1 [ 0 template-test ] compile-call 2drop
-    template-chosen get
-] unit-test
-
-! Regression
-[
-    [ ] [ init-templates ] unit-test
-
-    ! dup dup
-    [ ] [
-        T{ effect f { "x" } { "x" "x" } } phantom-shuffle
-        T{ effect f { "x" } { "x" "x" } } phantom-shuffle
-    ] unit-test
-
-    ! This is not empty since a load instruction is emitted
-    [ f ] [
-        [ { { f "x" } } +input+ set load-inputs ] { } make
-        empty?
-    ] unit-test
-
-    ! This is empty since we already loaded the value
-    [ t ] [
-        [ { { f "x" } } +input+ set load-inputs ] { } make
-        empty?
-    ] unit-test
-
-    ! This is empty since we didn't change the stack
-    [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-! Regression
-[
-    [ ] [ init-templates ] unit-test
-
-    ! >r r>
-    [ ] [
-        1 phantom->r
-        1 phantom-r>
-    ] unit-test
-
-    ! This is empty since we didn't change the stack
-    [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-
-    ! >r r>
-    [ ] [
-        1 phantom->r
-        1 phantom-r>
-    ] unit-test
-
-    [ ] [ { object } set-operand-classes ] unit-test
-
-    ! This is empty since we didn't change the stack
-    [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-! Regression
-[
-    [ ] [ init-templates ] unit-test
-
-    [ ] [ { object object } set-operand-classes ] unit-test
-
-    ! 2dup
-    [ ] [
-        T{ effect f { "x" "y" } { "x" "y" "x" "y" } }
-        phantom-shuffle
-    ] unit-test
-
-    [ ] [
-        2 phantom-datastack get phantom-input
-        [ { { f "a" } { f "b" } } lazy-load ] { } make drop
-    ] unit-test
-    
-    [ t ] [
-        phantom-datastack get stack>> [ cached? ] all?
-    ] unit-test
-
-    ! >r
-    [ ] [
-        1 phantom->r
-    ] unit-test
-
-    ! This should not fail
-    [ ] [ [ end-basic-block ] { } make drop ] unit-test
-] with-scope
-
-! Regression
-SYMBOL: templates-chosen
-
-V{ } clone templates-chosen set
-
-: template-choice-1 ;
-
-\ template-choice-1
-[ "template-choice-1" templates-chosen get push ]
-H{
-    { +input+ { { f "obj" } { [ ] "n" } } }
-    { +output+ { "obj" } }
-} define-intrinsic
-
-: template-choice-2 ;
-
-\ template-choice-2
-[ "template-choice-2" templates-chosen get push drop ]
-{ { f "x" } { f "y" } } define-if-intrinsic
-
-[ ] [
-    [ 2 template-choice-1 template-choice-2 ]
-    [ define-temp ] with-compilation-unit drop
-] unit-test
-
-[ V{ "template-choice-1" "template-choice-2" } ]
-[ templates-chosen get ] unit-test

From a222168f74b6255099810bd7f7e4577e6cf23037 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 13 Oct 2008 14:01:33 -0500
Subject: [PATCH 028/318] Fix bootstrap

---
 basis/cocoa/messages/messages.factor         | 10 +++++-----
 basis/tools/disassembler/disassembler.factor |  2 +-
 2 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 09601ef8cc..10883830fd 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -1,11 +1,11 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.strings arrays assocs
-combinators compiler kernel math namespaces make parser
-prettyprint prettyprint.sections quotations sequences strings
-words cocoa.runtime io macros memoize debugger
-io.encodings.ascii effects compiler.generator libc libc.private
-parser lexer init core-foundation ;
+combinators compiler compiler.alien kernel math namespaces make
+parser prettyprint prettyprint.sections quotations sequences
+strings words cocoa.runtime io macros memoize debugger
+io.encodings.ascii effects libc libc.private parser lexer init
+core-foundation ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor
index dabdaaaa7c..76e1f0f1b8 100644
--- a/basis/tools/disassembler/disassembler.factor
+++ b/basis/tools/disassembler/disassembler.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files io words alien kernel math.parser alien.syntax
 io.launcher system assocs arrays sequences namespaces make
-qualified system math compiler.generator.fixup
+qualified system math compiler.codegen.fixup
 io.encodings.ascii accessors generic tr ;
 IN: tools.disassembler
 

From 740b6ef3f26d9ca6520dbc8beb7fc2b7a1ad4341 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 13 Oct 2008 14:03:21 -0500
Subject: [PATCH 029/318] Free up a register on x86.64

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

diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 07ee01270a..fec3f453ae 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -11,7 +11,7 @@ IN: cpu.x86.64
 
 M: x86.64 machine-registers
     {
-        { int-regs { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
+        { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
         { double-float-regs {
             XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
             XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15

From f2c6f8de5bfb8369714b67fde739aa067747cc0c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 13 Oct 2008 16:43:58 -0500
Subject: [PATCH 030/318] Using fry in cpu.x86, working on alien intrinsics

---
 basis/cpu/x86/allot/allot.factor              |  4 +-
 .../cpu/x86/architecture/architecture.factor  |  1 -
 basis/cpu/x86/assembler/syntax/syntax.factor  |  4 +-
 basis/cpu/x86/intrinsics/intrinsics.factor    | 78 +++++++++++--------
 basis/cpu/x86/sse2/sse2.factor                |  6 +-
 5 files changed, 53 insertions(+), 40 deletions(-)

diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor
index 13d81e0d89..a1180755db 100644
--- a/basis/cpu/x86/allot/allot.factor
+++ b/basis/cpu/x86/allot/allot.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words kernel.private namespaces math math.private
-sequences generic arrays system layouts alien locals
+sequences generic arrays system layouts alien locals fry
 cpu.architecture cpu.x86.assembler cpu.x86.architecture
 compiler.constants compiler.cfg.templates compiler.cfg.builder
 compiler.codegen compiler.codegen.fixup ;
@@ -118,7 +118,7 @@ M:: x86 %box-alien ( dst src temp -- )
     "end" resolve-label ; inline
 
 : overflow-template ( word insn -- )
-    [ overflow-check ] curry T{ template
+    '[ _ overflow-check ] T{ template
         { input { { f "x" } { f "y" } } }
         { scratch { { f "z" } } }
         { output { "z" } }
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index d4b5efd378..83876d72f8 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -49,7 +49,6 @@ HOOK: temp-reg-1 cpu ( -- reg )
 HOOK: temp-reg-2 cpu ( -- reg )
 
 HOOK: fixnum>slot@ cpu ( op -- )
-
 HOOK: prepare-division cpu ( -- )
 
 M: f load-literal
diff --git a/basis/cpu/x86/assembler/syntax/syntax.factor b/basis/cpu/x86/assembler/syntax/syntax.factor
index 5940663d42..d267baaf4f 100644
--- a/basis/cpu/x86/assembler/syntax/syntax.factor
+++ b/basis/cpu/x86/assembler/syntax/syntax.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences lexer parser ;
+USING: kernel words sequences lexer parser fry ;
 IN: cpu.x86.assembler.syntax
 
 : define-register ( name num size -- )
@@ -9,7 +9,7 @@ IN: cpu.x86.assembler.syntax
     "register-size" set-word-prop ;
 
 : define-registers ( names size -- )
-    >r dup length r> [ define-register ] curry 2each ;
+    '[ _ define-register ] each-index ;
 
 : REGISTERS: ( -- )
     scan-word ";" parse-tokens swap define-registers ; parsing
diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor
index b7a5b6063b..a42e5a2bc2 100644
--- a/basis/cpu/x86/intrinsics/intrinsics.factor
+++ b/basis/cpu/x86/intrinsics/intrinsics.factor
@@ -3,7 +3,7 @@
 USING: accessors arrays byte-arrays alien.accessors kernel
 kernel.private math memory namespaces make sequences words
 system layouts combinators math.order math.private alien
-alien.c-types slots.private locals cpu.architecture
+alien.c-types slots.private locals fry cpu.architecture
 cpu.x86.assembler cpu.x86.assembler.private cpu.x86.architecture
 compiler.codegen.fixup compiler.constants compiler.intrinsics
 compiler.cfg.builder compiler.cfg.registers compiler.cfg.stacks
@@ -51,7 +51,6 @@ IN: cpu.x86.intrinsics
     {
         [ %constant-slot "val" operand MOV ] T{ template
             { input { { f "val" } { f "obj" } { small-slot "n" } { small-slot "tag" } } }
-            { clobber { "obj" } }
         }
     }
     {
@@ -62,16 +61,6 @@ IN: cpu.x86.intrinsics
     }
 } define-intrinsics
 
-! Sometimes, we need to do stuff with operands which are
-! less than the word size. Instead of teaching the register
-! allocator about the different sized registers, with all
-! the complexity this entails, we just push/pop a register
-! which is guaranteed to be unused (the tempreg)
-: small-reg cell 8 = RBX EBX ? ; inline
-: small-reg-8 BL ; inline
-: small-reg-16 BX ; inline
-: small-reg-32 EBX ; inline
-
 ! Fixnums
 : fixnum-op ( op hash -- pair )
     >r [ "x" operand "y" operand ] swap suffix r> 2array ;
@@ -219,17 +208,38 @@ IN: cpu.x86.intrinsics
 } define-intrinsic
 
 ! Alien intrinsics
-: %alien-accessor ( quot -- )
+
+! Sometimes, we need to do stuff with operands which are
+! less than the word size. Instead of teaching the register
+! allocator about the different sized registers, with all
+! the complexity this entails, we just push/pop a register
+! which is guaranteed to be unused (the tempreg)
+: small-reg cell 8 = RAX EAX ? ; inline
+: small-reg-8 AL ; inline
+: small-reg-16 AX ; inline
+: small-reg-32 EAX ; inline
+
+: %prepare-alien-accessor ( -- )
     "offset" operand %untag-fixnum
-    "offset" operand "alien" operand ADD
+    "offset" operand "alien" operand ADD ;
+
+: (%alien-accessor) ( quot -- )
     "offset" operand [] swap call ; inline
 
-: %alien-integer-get ( quot reg -- )
-    small-reg PUSH
-    swap %alien-accessor
-    "value" operand small-reg MOV
-    "value" operand %tag-fixnum
-    small-reg POP ; inline
+: %alien-accessor ( quot -- )
+    %prepare-alien-accessor (%alien-accessor) ; inline
+
+: %alien-integer-get ( reg quot -- )
+    %prepare-alien-accessor
+    "value" operand small-reg = [
+        (%alien-accessor)
+    ] [
+        small-reg PUSH
+        (%alien-accessor)
+        "value" operand small-reg MOV
+        small-reg POP
+    ] if
+    "value" operand %tag-fixnum ; inline
 
 : alien-integer-get-template
     T{ template
@@ -242,23 +252,28 @@ IN: cpu.x86.intrinsics
         { clobber { "offset" } }
     } ;
 
-: define-getter ( word quot reg -- )
-    [ %alien-integer-get ] 2curry
+: define-getter ( word reg quot -- )
+    '[ _ _ %alien-integer-get ]
     alien-integer-get-template
     define-intrinsic ;
 
 : define-unsigned-getter ( word reg -- )
-    [ small-reg dup XOR MOV ] swap define-getter ;
+    [ small-reg dup XOR MOV ] define-getter ;
 
 : define-signed-getter ( word reg -- )
-    [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
+    dup '[ MOV small-reg _ MOVSX ] define-getter ;
 
-: %alien-integer-set ( quot reg -- )
-    small-reg PUSH
-    small-reg "value" operand MOV
-    small-reg %untag-fixnum
-    swap %alien-accessor
-    small-reg POP ; inline
+: %alien-integer-set ( reg quot -- )
+    "value" operand %untag-fixnum
+    %prepare-alien-accessor
+    small-reg "value" operand = [
+        (%alien-accessor)
+    ] [
+        small-reg PUSH
+        small-reg "value" operand MOV
+        (%alien-accessor)
+        small-reg POP
+    ] if ; inline
 
 : alien-integer-set-template
     T{ template
@@ -271,8 +286,7 @@ IN: cpu.x86.intrinsics
     } ;
 
 : define-setter ( word reg -- )
-    [ swap MOV ] swap
-    [ %alien-integer-set ] 2curry
+    '[ _ [ swap MOV ] %alien-integer-set ]
     alien-integer-set-template
     define-intrinsic ;
 
diff --git a/basis/cpu/x86/sse2/sse2.factor b/basis/cpu/x86/sse2/sse2.factor
index e7ab902e07..856cf3c519 100644
--- a/basis/cpu/x86/sse2/sse2.factor
+++ b/basis/cpu/x86/sse2/sse2.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.accessors arrays generic kernel
 kernel.private math math.private memory namespaces sequences
-words math.floats.private layouts quotations locals
+words math.floats.private layouts quotations locals fry
 system compiler.constants compiler.codegen compiler.cfg.templates
 compiler.cfg.registers compiler.cfg.builder cpu.architecture
 cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics ;
@@ -87,10 +87,10 @@ M: x86 %unbox-float ( dst src -- )
     } ;
 
 : define-alien-float-intrinsics ( word get-quot word set-quot -- )
-    [ "value" operand swap %alien-accessor ] curry
+    '[ "value" operand _ %alien-accessor ]
     alien-float-set-template
     define-intrinsic
-    [ "value" operand swap %alien-accessor ] curry
+    '[ "value" operand _ %alien-accessor ]
     alien-float-get-template
     define-intrinsic ;
 

From fe2c20882aba3194a0b25211e763c90263c80576 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 13 Oct 2008 22:43:32 -0500
Subject: [PATCH 031/318] Fix alien accessor intrinsics; a bit more complex now
 that we don't reserve a tempreg

---
 basis/cpu/x86/64/64.factor                 | 65 ++++++++++++++++++++--
 basis/cpu/x86/assembler/assembler.factor   |  8 +++
 basis/cpu/x86/intrinsics/intrinsics.factor | 46 +++++++--------
 basis/cpu/x86/sse2/sse2.factor             | 32 ++++++-----
 4 files changed, 109 insertions(+), 42 deletions(-)

diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index fec3f453ae..a78b4d8d92 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -6,7 +6,8 @@ layouts alien alien.accessors alien.structs slots splitting
 assocs combinators cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
 cpu.x86.allot cpu.architecture compiler.constants
-compiler.codegen compiler.codegen.fixup compiler.cfg.instructions ;
+compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
+compiler.cfg.builder ;
 IN: cpu.x86.64
 
 M: x86.64 machine-registers
@@ -224,10 +225,64 @@ M: x86.64 %callback-value ( ctype -- )
 
 USE: cpu.x86.intrinsics
 
+: (%alien-get-4) ( -- )
+    small-reg-32 "offset" operand [] MOV ; inline
+
+: %alien-unsigned-4 ( -- )
+    %prepare-alien-accessor
+    "value" operand small-reg = [
+        (%alien-get-4)
+    ] [
+        small-reg PUSH
+        (%alien-get-4)
+        "value" operand small-reg MOV
+        small-reg POP
+    ] if
+    "value" operand %tag-fixnum ; inline
+
+: (%alien-signed-4) ( -- )
+    (%alien-get-4)
+    "value" operand small-reg-32 MOVSX ;
+
+: %alien-signed-4 ( -- )
+    %prepare-alien-accessor
+    "value" operand small-reg = [
+        (%alien-signed-4)
+    ] [
+        small-reg PUSH
+        (%alien-signed-4)
+        small-reg POP
+    ] if
+    "value" operand %tag-fixnum ; inline
+
+: define-alien-unsigned-4-getter ( word -- )
+    [ %alien-unsigned-4 ] alien-integer-get-template define-intrinsic ;
+
+: define-alien-signed-4-getter ( word -- )
+    [ %alien-signed-4 ] alien-integer-get-template define-intrinsic ;
+
+: %set-alien-4 ( -- )
+    "value" operand "offset" operand = [
+        "value" operand %untag-fixnum
+    ] unless
+    %prepare-alien-accessor
+    small-reg "offset" operand = [
+        "value" operand "offset" operand XCHG
+        "value" operand [] small-reg-32 MOV
+    ] [
+        small-reg PUSH
+        small-reg "value" operand MOV
+        "offset" operand [] small-reg-32 MOV
+        small-reg POP
+    ] if ; inline
+
+: define-alien-4-setter ( word -- )
+    [ %set-alien-4 ] alien-integer-set-template define-intrinsic ;
+
 ! On 64-bit systems, the result of reading 4 bytes from memory
 ! is a fixnum.
-\ alien-unsigned-4 small-reg-32 define-unsigned-getter
-\ set-alien-unsigned-4 small-reg-32 define-setter
+\ alien-unsigned-4 define-alien-unsigned-4-getter
+\ set-alien-unsigned-4 define-alien-4-setter
 
-\ alien-signed-4 small-reg-32 define-signed-getter
-\ set-alien-signed-4 small-reg-32 define-setter
+\ alien-signed-4 define-alien-signed-4-getter
+\ set-alien-signed-4 define-alien-4-setter
diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor
index e4f81993ca..91e4e8ca69 100644
--- a/basis/cpu/x86/assembler/assembler.factor
+++ b/basis/cpu/x86/assembler/assembler.factor
@@ -378,6 +378,8 @@ GENERIC: CMP ( dst src -- )
 M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
 M: operand CMP OCT: 070 2-operand ;
 
+: XCHG ( dst src -- ) OCT: 207 2-operand ;
+
 : NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
 : NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
 : MUL  ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
@@ -406,6 +408,12 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
     swapd
     (2-operand) ;
 
+: MOVZX ( dst src -- )
+    OCT: 266 extended-opcode
+    over register-16? [ BIN: 1 opcode-or ] when
+    swapd
+    (2-operand) ;
+
 ! Conditional move
 : MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
 
diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor
index a42e5a2bc2..e5f13f4a9d 100644
--- a/basis/cpu/x86/intrinsics/intrinsics.factor
+++ b/basis/cpu/x86/intrinsics/intrinsics.factor
@@ -214,29 +214,26 @@ IN: cpu.x86.intrinsics
 ! allocator about the different sized registers, with all
 ! the complexity this entails, we just push/pop a register
 ! which is guaranteed to be unused (the tempreg)
-: small-reg cell 8 = RAX EAX ? ; inline
-: small-reg-8 AL ; inline
-: small-reg-16 AX ; inline
-: small-reg-32 EAX ; inline
+: small-reg cell 8 = RDX EDX ? ; inline
+: small-reg-8 DL ; inline
+: small-reg-16 DX ; inline
+: small-reg-32 EDX ; inline
 
 : %prepare-alien-accessor ( -- )
     "offset" operand %untag-fixnum
     "offset" operand "alien" operand ADD ;
 
-: (%alien-accessor) ( quot -- )
-    "offset" operand [] swap call ; inline
-
-: %alien-accessor ( quot -- )
-    %prepare-alien-accessor (%alien-accessor) ; inline
+:: (%alien-integer-get) ( reg quot -- )
+    reg "offset" operand [] MOV
+    "value" operand reg quot call ; inline
 
 : %alien-integer-get ( reg quot -- )
     %prepare-alien-accessor
     "value" operand small-reg = [
-        (%alien-accessor)
+        (%alien-integer-get)
     ] [
         small-reg PUSH
-        (%alien-accessor)
-        "value" operand small-reg MOV
+        (%alien-integer-get)
         small-reg POP
     ] if
     "value" operand %tag-fixnum ; inline
@@ -258,20 +255,23 @@ IN: cpu.x86.intrinsics
     define-intrinsic ;
 
 : define-unsigned-getter ( word reg -- )
-    [ small-reg dup XOR MOV ] define-getter ;
+    [ MOVZX ] define-getter ;
 
 : define-signed-getter ( word reg -- )
-    dup '[ MOV small-reg _ MOVSX ] define-getter ;
+    [ MOVSX ] define-getter ;
 
-: %alien-integer-set ( reg quot -- )
-    "value" operand %untag-fixnum
+: %alien-integer-set ( reg -- )
+    "value" operand "offset" operand = [
+        "value" operand %untag-fixnum
+    ] unless
     %prepare-alien-accessor
-    small-reg "value" operand = [
-        (%alien-accessor)
+    small-reg "offset" operand = [
+        "value" operand "offset" operand XCHG
+        "value" operand [] swap MOV
     ] [
         small-reg PUSH
         small-reg "value" operand MOV
-        (%alien-accessor)
+        "offset" operand [] swap MOV
         small-reg POP
     ] if ; inline
 
@@ -286,7 +286,7 @@ IN: cpu.x86.intrinsics
     } ;
 
 : define-setter ( word reg -- )
-    '[ _ [ swap MOV ] %alien-integer-set ]
+    '[ _ %alien-integer-set ]
     alien-integer-set-template
     define-intrinsic ;
 
@@ -303,7 +303,8 @@ IN: cpu.x86.intrinsics
 \ set-alien-signed-2 small-reg-16 define-setter
 
 \ alien-cell [
-    "value" operand [ MOV ] %alien-accessor
+    %prepare-alien-accessor
+    "value" operand "offset" operand [] MOV
 ] T{ template
     { input {
         { unboxed-c-ptr "alien" c-ptr }
@@ -315,7 +316,8 @@ IN: cpu.x86.intrinsics
 } define-intrinsic
 
 \ set-alien-cell [
-    "value" operand [ swap MOV ] %alien-accessor
+    %prepare-alien-accessor
+    "offset" operand [] "value" operand MOV
 ] T{ template
     { input {
         { unboxed-c-ptr "value" pinned-c-ptr }
diff --git a/basis/cpu/x86/sse2/sse2.factor b/basis/cpu/x86/sse2/sse2.factor
index 856cf3c519..9650a4ce11 100644
--- a/basis/cpu/x86/sse2/sse2.factor
+++ b/basis/cpu/x86/sse2/sse2.factor
@@ -86,22 +86,24 @@ M: x86 %unbox-float ( dst src -- )
         { clobber { "offset" } }
     } ;
 
-: define-alien-float-intrinsics ( word get-quot word set-quot -- )
-    '[ "value" operand _ %alien-accessor ]
-    alien-float-set-template
-    define-intrinsic
-    '[ "value" operand _ %alien-accessor ]
+: define-float-getter ( word get-quot -- )
+    '[
+        %prepare-alien-accessor
+        "value" operand "offset" operand [] @
+    ]
     alien-float-get-template
     define-intrinsic ;
 
-\ alien-double
-[ MOVSD ]
-\ set-alien-double
-[ swap MOVSD ]
-define-alien-float-intrinsics
+: define-float-setter ( word set-quot -- )
+    '[
+        %prepare-alien-accessor
+        "offset" operand [] "value" operand @
+    ]
+    alien-float-set-template
+    define-intrinsic ;
 
-\ alien-float
-[ dupd MOVSS dup CVTSS2SD ]
-\ set-alien-float
-[ swap dup dup CVTSD2SS MOVSS ]
-define-alien-float-intrinsics
+\ alien-double [ MOVSD ] define-float-getter
+\ set-alien-double [ MOVSD ] define-float-setter
+
+\ alien-float [ dupd MOVSS dup CVTSS2SD ] define-float-getter
+\ set-alien-float [ dup dup CVTSD2SS MOVSS ] define-float-setter

From 239578353f0adf584d813ecffb366f2eae4e7e31 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 17 Oct 2008 15:35:04 -0500
Subject: [PATCH 032/318] Simplifying vregs work in progress

---
 basis/compiler/cfg/builder/builder.factor     |  2 +-
 .../cfg/instructions/instructions.factor      | 60 ++++++-------
 basis/compiler/cfg/stacks/stacks.factor       | 85 +++++++++----------
 basis/compiler/cfg/templates/templates.factor | 19 ++---
 basis/compiler/codegen/codegen.factor         |  2 +-
 5 files changed, 80 insertions(+), 88 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 3bc4a738c1..8b5202dd63 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -253,7 +253,7 @@ M: #dispatch emit-node
     type tagged boa phantom-push ;
 
 : emit-write-barrier ( -- )
-    phantom-pop dup >vreg fresh-object? [ drop ] [
+    phantom-pop dup fresh-object? [ drop ] [
         int-regs next-vreg
         int-regs next-vreg
         ##write-barrier
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index d92520c77d..fd7d071518 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -1,21 +1,21 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors arrays kernel sequences namespaces
+USING: assocs accessors arrays kernel sequences namespaces words
 math compiler.cfg.registers compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
 ! Virtual CPU instructions, used by CFG and machine IRs
 
-TUPLE: ##cond-branch < insn src ;
-TUPLE: ##unary < insn dst src ;
-TUPLE: ##nullary < insn dst ;
+TUPLE: ##cond-branch < insn { src vreg } ;
+TUPLE: ##unary < insn { dst vreg } { src vreg } ;
+TUPLE: ##nullary < insn { dst vreg } ;
 
 ! Stack operations
 INSN: ##load-literal < ##nullary obj ;
-INSN: ##peek < ##nullary loc ;
-INSN: ##replace src loc ;
-INSN: ##inc-d n ;
-INSN: ##inc-r n ;
+INSN: ##peek < ##nullary { loc loc } ;
+INSN: ##replace { src vreg } { loc loc } ;
+INSN: ##inc-d { n integer } ;
+INSN: ##inc-r { n integer } ;
 
 ! Subroutine calls
 TUPLE: stack-frame
@@ -33,8 +33,8 @@ INSN: ##return ;
 INSN: ##intrinsic quot defs-vregs uses-vregs ;
 
 ! Jump tables
-INSN: ##dispatch-label label ;
 INSN: ##dispatch src temp ;
+INSN: ##dispatch-label label ;
 
 ! Boxing and unboxing
 INSN: ##copy < ##unary ;
@@ -44,12 +44,12 @@ INSN: ##unbox-f < ##unary ;
 INSN: ##unbox-alien < ##unary ;
 INSN: ##unbox-byte-array < ##unary ;
 INSN: ##unbox-any-c-ptr < ##unary ;
-INSN: ##box-float < ##unary temp ;
-INSN: ##box-alien < ##unary temp ;
+INSN: ##box-float < ##unary { temp vreg } ;
+INSN: ##box-alien < ##unary { temp vreg } ;
 
 ! Memory allocation
-INSN: ##allot < ##nullary size type tag temp ;
-INSN: ##write-barrier src card# table ;
+INSN: ##allot < ##nullary size type tag { temp vreg } ;
+INSN: ##write-barrier { src vreg } card# table ;
 INSN: ##gc ;
 
 ! FFI
@@ -61,28 +61,28 @@ INSN: ##callback-return params ;
 GENERIC: defs-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
-M: ##nullary defs-vregs dst>> >vreg 1array ;
-M: ##unary defs-vregs dst>> >vreg 1array ;
+M: ##nullary defs-vregs dst>> 1array ;
+M: ##unary defs-vregs dst>> 1array ;
 M: ##write-barrier defs-vregs
-    [ card#>> >vreg ] [ table>> >vreg ] bi 2array ;
+    [ card#>> ] [ table>> ] bi 2array ;
 
 : allot-defs-vregs ( insn -- seq )
-    [ dst>> >vreg ] [ temp>> >vreg ] bi 2array ;
+    [ dst>> ] [ temp>> ] bi 2array ;
 
 M: ##box-float defs-vregs allot-defs-vregs ;
 M: ##box-alien defs-vregs allot-defs-vregs ;
 M: ##allot defs-vregs allot-defs-vregs ;
-M: ##dispatch defs-vregs temp>> >vreg 1array ;
+M: ##dispatch defs-vregs temp>> 1array ;
 M: insn defs-vregs drop f ;
 
-M: ##replace uses-vregs src>> >vreg 1array ;
-M: ##unary uses-vregs src>> >vreg 1array ;
-M: ##write-barrier uses-vregs src>> >vreg 1array ;
-M: ##dispatch uses-vregs src>> >vreg 1array ;
+M: ##replace uses-vregs src>> 1array ;
+M: ##unary uses-vregs src>> 1array ;
+M: ##write-barrier uses-vregs src>> 1array ;
+M: ##dispatch uses-vregs src>> 1array ;
 M: insn uses-vregs drop f ;
 
 : intrinsic-vregs ( assoc -- seq' )
-    [ nip >vreg ] { } assoc>map sift ;
+    values sift ;
 
 : intrinsic-defs-vregs ( insn -- seq )
     defs-vregs>> intrinsic-vregs ;
@@ -102,7 +102,7 @@ INSN: ##branch-f < ##cond-branch ;
 INSN: ##branch-t < ##cond-branch ;
 INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
 
-M: ##cond-branch uses-vregs src>> >vreg 1array ;
+M: ##cond-branch uses-vregs src>> 1array ;
 
 M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
 M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
@@ -113,20 +113,20 @@ INSN: _epilogue stack-frame ;
 
 INSN: _label id ;
 
-TUPLE: _cond-branch < insn src label ;
+TUPLE: _cond-branch < insn { src vreg } label ;
 
 INSN: _branch label ;
 INSN: _branch-f < _cond-branch ;
 INSN: _branch-t < _cond-branch ;
 INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
 
-M: _cond-branch uses-vregs src>> >vreg 1array ;
+M: _cond-branch uses-vregs src>> 1array ;
 
 M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
 M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
 
-INSN: _spill-integer src n ;
-INSN: _reload-integer dst n ;
+INSN: _spill-integer { src vreg } n ;
+INSN: _reload-integer { dst vreg } n ;
 
-INSN: _spill-float src n ;
-INSN: _reload-float dst n ;
+INSN: _spill-float { src vreg } n ;
+INSN: _reload-float { dst vreg } n ;
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index 39d8109b05..8d0537c64d 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -16,10 +16,7 @@ PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
 ! Value protocol
 GENERIC: move-spec ( obj -- spec )
 GENERIC: live-loc? ( actual current -- ? )
-GENERIC# (lazy-load) 1 ( value spec -- value )
-GENERIC# (eager-load) 1 ( value spec -- value )
 GENERIC: lazy-store ( dst src -- )
-GENERIC: minimal-ds-loc* ( min obj -- min )
 
 ! This will be a multimethod soon
 DEFER: ##move
@@ -28,7 +25,6 @@ PRIVATE>
 
 ! Default implementation
 M: value live-loc? 2drop f ;
-M: value minimal-ds-loc* drop ;
 M: value lazy-store 2drop ;
 
 M: vreg move-spec reg-class>> move-spec ;
@@ -40,7 +36,6 @@ M: int-regs value-class* drop object ;
 M: float-regs move-spec drop float ;
 M: float-regs value-class* drop float ;
 
-M: ds-loc minimal-ds-loc* n>> min ;
 M: ds-loc live-loc?
     over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
 
@@ -67,14 +62,14 @@ M: unboxed-c-ptr move-spec class ;
 M: constant move-spec class ;
 
 ! Moving values between locations and registers
-: ##move-bug ( -- * ) "Bug in generator.registers" throw ;
+: ##move-bug ( -- * ) "Bug in compiler.cfg.stacks" throw ;
 
 : ##unbox-c-ptr ( dst src -- )
     dup value-class {
-        { [ dup \ f class<= ] [ drop ##unbox-f ] }
-        { [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
-        { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
-        [ drop ##unbox-any-c-ptr ]
+        { [ dup \ f class<= ] [ drop [ >vreg ] bi@ ##unbox-f ] }
+        { [ dup simple-alien class<= ] [ drop [ >vreg ] bi@ ##unbox-alien ] }
+        { [ dup byte-array class<= ] [ drop [ >vreg ] bi@ ##unbox-byte-array ] }
+        [ drop [ >vreg ] bi@ ##unbox-any-c-ptr ]
     } cond ; inline
 
 : ##move-via-temp ( dst src -- )
@@ -97,28 +92,28 @@ SYMBOL: fresh-objects
 
 : ##move ( dst src -- )
     2dup [ move-spec ] bi@ 2array {
-        { { f f } [ ##copy ] }
-        { { unboxed-alien unboxed-alien } [ ##copy ] }
-        { { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
-        { { unboxed-f unboxed-f } [ ##copy ] }
-        { { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
-        { { float float } [ ##copy-float ] }
+        { { f f } [ [ >vreg ] bi@ ##copy ] }
+        { { unboxed-alien unboxed-alien } [ [ >vreg ] bi@ ##copy ] }
+        { { unboxed-byte-array unboxed-byte-array } [ [ >vreg ] bi@ ##copy ] }
+        { { unboxed-f unboxed-f } [ [ >vreg ] bi@ ##copy ] }
+        { { unboxed-c-ptr unboxed-c-ptr } [ [ >vreg ] bi@ ##copy ] }
+        { { float float } [ [ >vreg ] bi@ ##copy-float ] }
 
         { { f unboxed-c-ptr } [ ##move-bug ] }
         { { f unboxed-byte-array } [ ##move-bug ] }
 
-        { { f constant } [ value>> ##load-literal ] }
+        { { f constant } [ [ >vreg ] [ value>> ] bi* ##load-literal ] }
 
-        { { f float } [ int-regs next-vreg ##box-float t fresh-object ] }
-        { { f unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] }
-        { { f loc } [ ##peek ] }
+        { { f float } [ [ >vreg ] bi@ int-regs next-vreg ##box-float t fresh-object ] }
+        { { f unboxed-alien } [ [ >vreg ] bi@ int-regs next-vreg ##box-alien t fresh-object ] }
+        { { f loc } [ [ >vreg ] dip ##peek ] }
 
-        { { float f } [ ##unbox-float ] }
-        { { unboxed-alien f } [ ##unbox-alien ] }
-        { { unboxed-byte-array f } [ ##unbox-byte-array ] }
-        { { unboxed-f f } [ ##unbox-f ] }
+        { { float f } [ [ >vreg ] bi@ ##unbox-float ] }
+        { { unboxed-alien f } [ [ >vreg ] bi@ ##unbox-alien ] }
+        { { unboxed-byte-array f } [ [ >vreg ] bi@ ##unbox-byte-array ] }
+        { { unboxed-f f } [ [ >vreg ] bi@ ##unbox-f ] }
         { { unboxed-c-ptr f } [ ##unbox-c-ptr ] }
-        { { loc f } [ swap ##replace ] }
+        { { loc f } [ >vreg swap ##replace ] }
 
         [ drop ##move-via-temp ]
     } case ;
@@ -168,7 +163,7 @@ M: phantom-retainstack finalize-height
 
 : phantom-locs ( n phantom -- locs )
     #! A sequence of n ds-locs or rs-locs indexing the stack.
-    >r <reversed> r> '[ _ <loc> ] map ;
+    [ <reversed> ] dip '[ _ <loc> ] map ;
 
 : phantom-locs* ( phantom -- locs )
     [ stack>> length ] keep phantom-locs ;
@@ -209,15 +204,6 @@ M: phantom-retainstack finalize-height
 
 : finalize-heights ( -- ) [ finalize-height ] each-phantom ;
 
-: (live-locs) ( phantom -- seq )
-    #! Discard locs which haven't moved
-    [ phantom-locs* ] [ stack>> ] bi zip
-    [ live-loc? ] assoc-filter
-    values ;
-
-: live-locs ( -- seq )
-    [ (live-locs) ] each-phantom append prune ;
-
 : reg-spec>class ( spec -- class )
     float eq? double-float-regs int-regs ? ;
 
@@ -231,6 +217,14 @@ M: phantom-retainstack finalize-height
         [ drop ]
     } case ;
 
+: alloc-vreg-for ( value spec -- vreg )
+    alloc-vreg swap value-class
+    over tagged? [ >>class ] [ drop ] if ;
+
+: (eager-load) ( value spec -- vreg )
+    [ alloc-vreg-for ] [ drop ] 2bi
+    [ ##move ] [ drop >vreg ] 2bi ;
+
 : compatible? ( value spec -- ? )
     >r move-spec r> {
         { [ 2dup = ] [ t ] }
@@ -240,20 +234,21 @@ M: phantom-retainstack finalize-height
         [ f ]
     } cond 2nip ;
 
-: alloc-vreg-for ( value spec -- vreg )
-    alloc-vreg swap value-class
-    over tagged? [ >>class ] [ drop ] if ;
-
-M: value (lazy-load)
+: (lazy-load) ( value spec -- value )
     {
-        { [ dup { small-slot small-tagged } memq? ] [ drop ] }
-        { [ 2dup compatible? ] [ drop ] }
+        { [ dup { small-slot small-tagged } memq? ] [ drop >vreg ] }
+        { [ 2dup compatible? ] [ drop >vreg ] }
         [ (eager-load) ]
     } cond ;
 
-M: value (eager-load) ( value spec -- vreg )
-    [ alloc-vreg-for ] [ drop ] 2bi
-    [ ##move ] [ drop ] 2bi ;
+: (live-locs) ( phantom -- seq )
+    #! Discard locs which haven't moved
+    [ phantom-locs* ] [ stack>> ] bi zip
+    [ live-loc? ] assoc-filter
+    values ;
+
+: live-locs ( -- seq )
+    [ (live-locs) ] each-phantom append prune ;
 
 M: loc lazy-store
     2dup live-loc? [ "live-locs" get at ##move ] [ 2drop ] if ;
diff --git a/basis/compiler/cfg/templates/templates.factor b/basis/compiler/cfg/templates/templates.factor
index 33c0efae55..9446d66683 100644
--- a/basis/compiler/cfg/templates/templates.factor
+++ b/basis/compiler/cfg/templates/templates.factor
@@ -7,14 +7,6 @@ IN: compiler.cfg.templates
 
 TUPLE: template input output scratch clobber gc ;
 
-: phantom&spec ( phantom specs -- phantom' specs' )
-    >r stack>> r>
-    [ length f pad-left ] keep
-    [ <reversed> ] bi@ ; inline
-
-: phantom&spec-agree? ( phantom spec quot -- ? )
-    >r phantom&spec r> 2all? ; inline
-
 : live-vregs ( -- seq )
     [ stack>> [ >vreg ] map sift ] each-phantom append ;
 
@@ -41,7 +33,7 @@ TUPLE: template input output scratch clobber gc ;
     ] with-scope ;
 
 : alloc-scratch ( template -- assoc )
-    scratch>> [ swap alloc-vreg ] assoc-map ;
+    scratch>> [ swap alloc-vreg >vreg ] assoc-map ;
 
 : do-template-inputs ( template -- defs uses )
     #! Load input values into registers and allocates scratch
@@ -60,6 +52,11 @@ TUPLE: template input output scratch clobber gc ;
         [ do-template-outputs ] 2keep
     ] dip call ; inline
 
+: phantom&spec ( phantom specs -- phantom' specs' )
+    >r stack>> r>
+    [ length f pad-left ] keep
+    [ <reversed> ] bi@ ; inline
+
 : value-matches? ( value spec -- ? )
     #! If the spec is a quotation and the value is a literal
     #! fixnum, see if the quotation yields true when applied
@@ -80,8 +77,8 @@ TUPLE: template input output scratch clobber gc ;
     >r >r value-class 2 r> ?nth class-matches? r> and ;
 
 : template-matches? ( template -- ? )
-    input>> phantom-datastack get swap
-    [ spec-matches? ] phantom&spec-agree? ;
+    input>> phantom-datastack get swap phantom&spec
+    [ spec-matches? ] 2all? ;
 
 : find-template ( templates -- pair/f )
     #! Pair has shape { quot assoc }
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 0a79d14778..44e2fd6bac 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -24,7 +24,7 @@ M: constant v>operand
     value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
 
 M: value v>operand
-    >vreg [ registers get at ] [ "Bad value" throw ] if* ;
+    registers get at [ "Bad value" throw ] unless* ;
 
 : generate-insns ( insns -- code )
     [

From a57320997a2ef65229c43469dfaaa57f7af35564 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 17 Oct 2008 15:35:33 -0500
Subject: [PATCH 033/318] Float array type inference rules

---
 basis/float-arrays/float-arrays.factor | 70 +++++++++++++-------------
 1 file changed, 35 insertions(+), 35 deletions(-)

diff --git a/basis/float-arrays/float-arrays.factor b/basis/float-arrays/float-arrays.factor
index b5951997f0..ab3eef62a5 100644
--- a/basis/float-arrays/float-arrays.factor
+++ b/basis/float-arrays/float-arrays.factor
@@ -86,38 +86,38 @@ HINTS: normalize { float-array } { array } ;
 ! More rice. Experimental, currently causes a slowdown in raytracer
 ! for some odd reason.
 
-! USING: words classes.algebra compiler.tree.propagation.info ;
-! 
-! { v+ v- v* v/ vmax vmin } [
-!     [
-!         [ class>> float-array class<= ] both?
-!         float-array object ? <class-info>
-!     ] "outputs" set-word-prop
-! ] each
-! 
-! { n*v n/v } [
-!     [
-!         nip class>> float-array class<= float-array object ? <class-info>
-!     ] "outputs" set-word-prop
-! ] each
-! 
-! { v*n v/n } [
-!     [
-!         drop class>> float-array class<= float-array object ? <class-info>
-!     ] "outputs" set-word-prop
-! ] each
-! 
-! { vneg normalize } [
-!     [
-!         class>> float-array class<= float-array object ? <class-info>
-!     ] "outputs" set-word-prop
-! ] each
-! 
-! \ norm-sq [
-!     class>> float-array class<= float object ? <class-info>
-! ] "outputs" set-word-prop
-! 
-! \ v. [
-!     [ class>> float-array class<= ] both?
-!     float object ? <class-info>
-! ] "outputs" set-word-prop
+USING: words classes.algebra compiler.tree.propagation.info ;
+
+{ v+ v- v* v/ vmax vmin } [
+    [
+        [ class>> float-array class<= ] both?
+        float-array object ? <class-info>
+    ] "outputs" set-word-prop
+] each
+
+{ n*v n/v } [
+    [
+        nip class>> float-array class<= float-array object ? <class-info>
+    ] "outputs" set-word-prop
+] each
+
+{ v*n v/n } [
+    [
+        drop class>> float-array class<= float-array object ? <class-info>
+    ] "outputs" set-word-prop
+] each
+
+{ vneg normalize } [
+    [
+        class>> float-array class<= float-array object ? <class-info>
+    ] "outputs" set-word-prop
+] each
+
+\ norm-sq [
+    class>> float-array class<= float object ? <class-info>
+] "outputs" set-word-prop
+
+\ v. [
+    [ class>> float-array class<= ] both?
+    float object ? <class-info>
+] "outputs" set-word-prop

From 627dfd1ff5e5b66d6231115f4e222a7022ab4262 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 17 Oct 2008 20:03:59 -0500
Subject: [PATCH 034/318] Finish vreg simplification

---
 basis/compiler/cfg/instructions/instructions.factor | 2 +-
 basis/compiler/cfg/registers/registers.factor       | 4 +++-
 basis/compiler/cfg/templates/templates.factor       | 7 ++++---
 3 files changed, 8 insertions(+), 5 deletions(-)

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index fd7d071518..1335a082bf 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -82,7 +82,7 @@ M: ##dispatch uses-vregs src>> 1array ;
 M: insn uses-vregs drop f ;
 
 : intrinsic-vregs ( assoc -- seq' )
-    values sift ;
+    [ nip dup vreg? swap and ] { } assoc>map sift ;
 
 : intrinsic-defs-vregs ( insn -- seq )
     defs-vregs>> intrinsic-vregs ;
diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor
index dc109cf62e..64712297e2 100644
--- a/basis/compiler/cfg/registers/registers.factor
+++ b/basis/compiler/cfg/registers/registers.factor
@@ -13,7 +13,6 @@ GENERIC: value-class* ( operand -- class )
 
 : value-class ( operand -- class ) value-class* object or ;
 
-M: value >vreg drop f ;
 M: value set-value-class 2drop ;
 M: value value-class* drop f ;
 
@@ -29,6 +28,8 @@ INSTANCE: vreg value
 ! Stack locations
 TUPLE: loc n class ;
 
+M: loc >vreg drop f ;
+
 ! A data stack location.
 TUPLE: ds-loc < loc ;
 : <ds-loc> ( n -- loc ) f ds-loc boa ;
@@ -85,5 +86,6 @@ TUPLE: constant value ;
 C: <constant> constant
 
 M: constant value-class* value>> class ;
+M: constant >vreg ;
 
 INSTANCE: constant value
diff --git a/basis/compiler/cfg/templates/templates.factor b/basis/compiler/cfg/templates/templates.factor
index 9446d66683..289c420f8f 100644
--- a/basis/compiler/cfg/templates/templates.factor
+++ b/basis/compiler/cfg/templates/templates.factor
@@ -33,7 +33,7 @@ TUPLE: template input output scratch clobber gc ;
     ] with-scope ;
 
 : alloc-scratch ( template -- assoc )
-    scratch>> [ swap alloc-vreg >vreg ] assoc-map ;
+    scratch>> [ swap alloc-vreg ] assoc-map ;
 
 : do-template-inputs ( template -- defs uses )
     #! Load input values into registers and allocates scratch
@@ -44,12 +44,13 @@ TUPLE: template input output scratch clobber gc ;
     [ output>> ] 2dip assoc-union '[ _ at ] map
     phantom-datastack get phantom-append ;
 
-: apply-template ( pair quot -- vregs )
+: apply-template ( pair quot -- )
     [
         first2
         dup gc>> [ t fresh-object ] when
         dup do-template-inputs
-        [ do-template-outputs ] 2keep
+        [ do-template-outputs ]
+        [ [ [ >vreg ] assoc-map ] dip ] 2bi
     ] dip call ; inline
 
 : phantom&spec ( phantom specs -- phantom' specs' )

From b3f30fb807942ff5cf3b6467e57575714c059cbc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 17 Oct 2008 20:04:08 -0500
Subject: [PATCH 035/318] Fix load error

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

diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 5c2de0e2f8..09b2255913 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -5,7 +5,7 @@ combinators compiler compiler.alien kernel math namespaces make
 parser prettyprint prettyprint.sections quotations sequences
 strings words cocoa.runtime io macros memoize debugger
 io.encodings.ascii effects libc libc.private parser lexer init
-core-foundation ;
+core-foundation fry ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )

From c0d89b061e574b2adc6a6b2eff9460b3116be2e0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 19 Oct 2008 01:10:21 -0500
Subject: [PATCH 036/318] Fixing register allocator prspilling

---
 basis/compiler/cfg/builder/builder.factor     |   3 +-
 basis/compiler/cfg/cfg.factor                 |   4 +-
 basis/compiler/cfg/debugger/debugger.factor   |   4 +-
 .../cfg/instructions/instructions.factor      |  14 +-
 .../linear-scan/allocation/allocation.factor  | 103 ++++----
 .../linear-scan/assignment/assignment.factor  |  18 +-
 .../cfg/linear-scan/linear-scan-tests.factor  | 222 ++++++++++++++++--
 .../cfg/linear-scan/linear-scan.factor        |  11 +-
 .../live-intervals/live-intervals.factor      |  21 +-
 .../cfg/stack-frame/stack-frame.factor        |  29 +--
 .../expressions/expressions.factor            |  23 ++
 .../cfg/value-numbering/graph/graph.factor    |  32 +++
 .../value-numbering/liveness/liveness.factor  |  38 +++
 .../propagate/propagate.factor                |  58 +++++
 .../value-numbering/value-numbering.factor    |  46 ++++
 basis/compiler/codegen/codegen.factor         |  20 +-
 basis/compiler/compiler.factor                |  24 +-
 17 files changed, 519 insertions(+), 151 deletions(-)
 create mode 100644 basis/compiler/cfg/value-numbering/expressions/expressions.factor
 create mode 100644 basis/compiler/cfg/value-numbering/graph/graph.factor
 create mode 100644 basis/compiler/cfg/value-numbering/liveness/liveness.factor
 create mode 100644 basis/compiler/cfg/value-numbering/propagate/propagate.factor
 create mode 100644 basis/compiler/cfg/value-numbering/value-numbering.factor

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 8b5202dd63..e5f91d19df 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -329,8 +329,7 @@ M: #terminate emit-node
     stack-frame new
         swap
         [ return>> return-size >>return ]
-        [ alien-parameters parameter-sizes drop >>params ] bi
-        dup [ params>> ] [ return>> ] bi + >>size ;
+        [ alien-parameters parameter-sizes drop >>params ] bi ;
 
 : alien-stack-frame ( params -- )
     <alien-stack-frame> ##stack-frame ;
diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index e32ad47890..8ce3260153 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sequences sets fry ;
+USING: kernel arrays accessors namespaces assocs sequences sets fry ;
 IN: compiler.cfg
 
 TUPLE: cfg entry word label ;
@@ -19,7 +19,7 @@ successors ;
         V{ } clone >>instructions
         V{ } clone >>successors ;
 
-TUPLE: mr instructions word label ;
+TUPLE: mr { instructions array } word label spill-counts ;
 
 : <mr> ( instructions word label -- mr )
     mr new
diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index f7591ba105..a04670ddab 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -4,7 +4,7 @@ USING: kernel words sequences quotations namespaces io
 accessors prettyprint prettyprint.config
 compiler.tree.builder compiler.tree.optimizer
 compiler.cfg.builder compiler.cfg.linearization
-compiler.cfg.stack-frame ;
+compiler.cfg.stack-frame compiler.cfg.linear-scan ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -16,7 +16,7 @@ M: word test-cfg
     [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
 
 : test-mr ( quot -- mrs )
-    test-cfg [ build-mr build-stack-frame ] map ;
+    test-cfg [ build-mr ] map ;
 
 : mr. ( mrs -- )
     [
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 1335a082bf..689650f0a4 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -19,10 +19,10 @@ INSN: ##inc-r { n integer } ;
 
 ! Subroutine calls
 TUPLE: stack-frame
-{ size integer }
 { params integer }
 { return integer }
-{ total-size integer } ;
+{ total-size integer }
+spill-counts ;
 
 INSN: ##stack-frame stack-frame ;
  : ##simple-stack-frame ( -- ) T{ stack-frame } ##stack-frame ;
@@ -125,8 +125,8 @@ M: _cond-branch uses-vregs src>> 1array ;
 M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
 M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
 
-INSN: _spill-integer { src vreg } n ;
-INSN: _reload-integer { dst vreg } n ;
-
-INSN: _spill-float { src vreg } n ;
-INSN: _reload-float { dst vreg } n ;
+! These instructions operate on machine registers and not
+! virtual registers
+INSN: _spill src class n ;
+INSN: _reload dst class n ;
+INSN: _spill-counts counts ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 5433908768..1b49609387 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences math math.order kernel assocs
-accessors vectors fry heaps cpu.architecture
+accessors vectors fry heaps cpu.architecture combinators
 compiler.cfg.registers
 compiler.cfg.linear-scan.live-intervals ;
 IN: compiler.cfg.linear-scan.allocation
@@ -24,25 +24,11 @@ SYMBOL: active-intervals
 : delete-active ( live-interval -- )
     active-intervals get delete ;
 
-: expired-interval? ( n interval -- ? )
-    [ end>> ] [ start>> ] bi or > ;
-
 : expire-old-intervals ( n -- )
     active-intervals get
-    [ expired-interval? ] with partition
+    [ end>> > ] with partition
     [ [ deallocate-register ] each ] [ active-intervals set ] bi* ;
 
-: expire-old-uses ( n -- )
-    active-intervals get
-    swap '[
-        uses>> [
-            dup peek _ < [ pop* ] [ drop ] if
-        ] unless-empty
-    ] each ;
-
-: update-state ( live-interval -- )
-    start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
-
 ! Minheap of live intervals which still need a register allocation
 SYMBOL: unhandled-intervals
 
@@ -64,8 +50,25 @@ SYMBOL: progress
     [ [ start>> ] keep ] { } map>assoc
     unhandled-intervals get heap-push-all ;
 
-: assign-free-register ( live-interval registers -- )
-    pop >>reg add-active ;
+! Splitting
+: find-use ( live-interval n quot -- i elt )
+    [ uses>> ] 2dip curry find ; inline
+
+: split-before ( live-interval i -- before )
+    [ clone dup uses>> ] dip
+    [ head >>uses ] [ 1- swap nth >>end ] 2bi ;
+
+: split-after ( live-interval i -- after )
+    [ clone dup uses>> ] dip
+    [ tail >>uses ] [ swap nth >>start ] 2bi
+    f >>reg ;
+
+: split-interval ( live-interval n -- before after )
+    [ drop ] [ [ > ] find-use drop ] 2bi
+    [ split-before ] [ split-after ] 2bi ;
+
+: record-split ( live-interval before after -- )
+    [ >>split-before ] [ >>split-after ] bi* drop ;
 
 ! Spilling
 SYMBOL: spill-counts
@@ -73,37 +76,20 @@ SYMBOL: spill-counts
 : next-spill-location ( reg-class -- n )
     spill-counts get [ dup 1+ ] change-at ;
 
-: interval-to-spill ( -- live-interval )
+: interval-to-spill ( active-intervals current -- live-interval )
     #! We spill the interval with the most distant use location.
-    active-intervals get
-    [ uses>> empty? not ] filter
-    unclip-slice [
-        [ [ uses>> peek ] bi@ > ] most
-    ] reduce ;
-
-: check-split ( live-interval -- )
-    [ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ;
-
-: split-interval ( live-interval -- before after )
-    #! Split the live interval at the location of its first use.
-    #! 'Before' now starts and ends on the same instruction.
-    [ check-split ]
-    [ clone [ uses>> delete-all ] [ dup start>> >>end ] bi ]
-    [ clone f >>reg dup uses>> peek >>start ]
-    tri ;
-
-: record-split ( live-interval before after -- )
-    [ >>split-before ] [ >>split-after ] bi* drop ;
+    start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
+    unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
 
 : assign-spill ( before after -- before after )
     #! If it has been spilled already, reuse spill location.
-    USE: cpu.architecture ! XXX
     over reload-from>>
-    [ int-regs next-spill-location ] unless*
+    [ over vreg>> reg-class>> next-spill-location ] unless*
     tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
 
-: split-and-spill ( live-interval -- before after )
-    dup split-interval [ record-split ] [ assign-spill ] 2bi ;
+: split-and-spill ( new existing -- before after )
+    dup rot start>> split-interval
+    [ record-split ] [ assign-spill ] 2bi ;
 
 : reuse-register ( new existing -- )
     reg>> >>reg add-active ;
@@ -114,30 +100,30 @@ SYMBOL: spill-counts
     #! interval, then process the new interval and the tail end
     #! of the existing interval again.
     [ reuse-register ]
-    [ delete-active ]
-    [ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ;
+    [ nip delete-active ]
+    [ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
 
 : spill-new ( new existing -- )
     #! Our new interval will be used after the active interval
     #! with the most distant use location. Split the new
     #! interval, then process both parts of the new interval
     #! again.
-    [ split-and-spill add-unhandled ] dip spill-existing ;
+    [ dup split-and-spill add-unhandled ] dip spill-existing ;
 
 : spill-existing? ( new existing -- ? )
-    over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ;
+    #! Test if 'new' will be used before 'existing'.
+    over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
 
-: assign-blocked-register ( live-interval -- )
-    interval-to-spill
-    2dup spill-existing?
-    [ spill-existing ] [ spill-new ] if ;
+: assign-blocked-register ( new -- )
+    [ active-intervals get ] keep interval-to-spill
+    2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
 
-: assign-register ( live-interval -- )
-    dup vreg>> free-registers-for [
-        assign-blocked-register
-    ] [
-        assign-free-register
-    ] if-empty ;
+: assign-free-register ( new registers -- )
+    pop >>reg add-active ;
+
+: assign-register ( new -- )
+    dup vreg>> free-registers-for
+    [ assign-blocked-register ] [ assign-free-register ] if-empty ;
 
 ! Main loop
 : init-allocator ( registers -- )
@@ -148,7 +134,10 @@ SYMBOL: spill-counts
     -1 progress set ;
 
 : handle-interval ( live-interval -- )
-    [ start>> progress set ] [ update-state ] [ assign-register ] tri ;
+    [ start>> progress set ]
+    [ start>> expire-old-intervals ]
+    [ assign-register ]
+    tri ;
 
 : (allocate-registers) ( -- )
     unhandled-intervals get [ handle-interval ] slurp-heap ;
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 541ab606a2..876bb6ba6c 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -35,13 +35,8 @@ SYMBOL: unhandled-intervals
     [ add-unhandled ] each ;
 
 : insert-spill ( live-interval -- )
-    [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri
-    over [
-        {
-            { int-regs [ _spill-integer ] }
-            { double-float-regs [ _spill-float ] }
-        } case
-    ] [ 3drop ] if ;
+    [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri
+    dup [ _spill ] [ 3drop ] if ;
 
 : expire-old-intervals ( n -- )
     active-intervals get
@@ -50,13 +45,8 @@ SYMBOL: unhandled-intervals
     [ insert-spill ] each ;
 
 : insert-reload ( live-interval -- )
-    [ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri
-    over [
-        {
-            { int-regs [ _reload-integer ] }
-            { double-float-regs [ _reload-float ] }
-        } case
-    ] [ 3drop ] if ;
+    [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri
+    dup [ _reload ] [ 3drop ] if ;
 
 : activate-new-intervals ( n -- )
     #! Any live intervals which start on the current instruction
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 1784886154..88d7bcdbcf 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -7,49 +7,209 @@ compiler.cfg.instructions
 compiler.cfg.registers
 compiler.cfg.linear-scan
 compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.debugger ;
 
+[ 7 ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+        { start 0 }
+        { end 10 }
+        { uses V{ 0 1 3 7 10 } }
+    }
+    4 [ >= ] find-use nip
+] unit-test
+
+[ 4 ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+        { start 0 }
+        { end 10 }
+        { uses V{ 0 1 3 4 10 } }
+    }
+    4 [ >= ] find-use nip
+] unit-test
+
+[ f ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+        { start 0 }
+        { end 10 }
+        { uses V{ 0 1 3 4 10 } }
+    }
+    100 [ >= ] find-use nip
+] unit-test
+
+[
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 0 }
+        { end 1 }
+        { uses V{ 0 1 } }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 5 }
+        { end 5 }
+        { uses V{ 5 } }
+    }
+] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 0 }
+        { end 5 }
+        { uses V{ 0 1 5 } }
+    } 2 split-interval
+] unit-test
+
+[
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 0 }
+        { end 0 }
+        { uses V{ 0 } }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 1 }
+        { end 5 }
+        { uses V{ 1 5 } }
+    }
+] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 0 }
+        { end 5 }
+        { uses V{ 0 1 5 } }
+    } 0 split-interval
+] unit-test
+
+[
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 3 }
+        { end 10 }
+        { uses V{ 3 10 } }
+    }
+] [
+    {
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+            { start 1 }
+            { end 15 }
+            { uses V{ 1 3 7 10 15 } }
+        }
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+            { start 3 }
+            { end 8 }
+            { uses V{ 3 4 8 } }
+        }
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+            { start 3 }
+            { end 10 }
+            { uses V{ 3 10 } }
+        }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 5 }
+        { end 5 }
+        { uses V{ 5 } }
+    }
+    interval-to-spill
+] unit-test
+
+[ t ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 5 }
+        { end 15 }
+        { uses V{ 5 10 15 } }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 1 }
+        { end 20 }
+        { uses V{ 1 20 } }
+    }
+    spill-existing?
+] unit-test
+
+[ f ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 5 }
+        { end 15 }
+        { uses V{ 5 10 15 } }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 1 }
+        { end 20 }
+        { uses V{ 1 7 20 } }
+    }
+    spill-existing?
+] unit-test
+
+[ t ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 5 }
+        { end 5 }
+        { uses V{ 5 } }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 1 }
+        { end 20 }
+        { uses V{ 1 7 20 } }
+    }
+    spill-existing?
+] unit-test
+
 [ ] [
     {
-        T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
+        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
     }
-    H{ { f { "A" } } }
+    H{ { int-regs { "A" } } }
     check-linear-scan
 ] unit-test
 
 [ ] [
     {
-        T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 10 } { uses V{ 10 } } }
-        T{ live-interval { vreg T{ vreg { n 2 } } } { start 11 } { end 20 } { uses V{ 20 } } }
+        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
     }
-    H{ { f { "A" } } }
+    H{ { int-regs { "A" } } }
     check-linear-scan
 ] unit-test
 
 [ ] [
     {
-        T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
-        T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 60 } { uses V{ 60 } } }
+        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
     }
-    H{ { f { "A" } } }
+    H{ { int-regs { "A" } } }
     check-linear-scan
 ] unit-test
 
 [ ] [
     {
-        T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
-        T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 200 } { uses V{ 200 } } }
+        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
     }
-    H{ { f { "A" } } }
+    H{ { int-regs { "A" } } }
     check-linear-scan
 ] unit-test
 
 [
     {
-        T{ live-interval { vreg T{ vreg { n 1 } } } { start 0 } { end 100 } { uses V{ 100 } } }
-        T{ live-interval { vreg T{ vreg { n 2 } } } { start 30 } { end 100 } { uses V{ 100 } } }
+        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } }
     }
-    H{ { f { "A" } } }
+    H{ { int-regs { "A" } } }
     check-linear-scan
 ] must-fail
 
@@ -81,15 +241,15 @@ SYMBOL: max-uses
         max-insns get [ dup ] H{ } map>assoc available set
         [
             live-interval new
-                swap f swap vreg boa >>vreg
+                swap int-regs swap vreg boa >>vreg
                 max-uses get random 2 max [ not-taken ] replicate natural-sort
-                unclip [ >vector >>uses ] [ >>start ] bi*
-                dup uses>> first >>end
+                [ >>uses ] [ first >>start ] bi
+                dup uses>> peek >>end
         ] map
     ] with-scope ;
 
 : random-test ( num-intervals max-uses max-registers max-insns -- )
-    over >r random-live-intervals r> f associate check-linear-scan ;
+    over >r random-live-intervals r> int-regs associate check-linear-scan ;
 
 [ ] [ 30 2 1 60 random-test ] unit-test
 [ ] [ 60 2 2 60 random-test ] unit-test
@@ -118,3 +278,29 @@ USING: math.private compiler.cfg.debugger ;
     } clone
     1array (linear-scan) first regs>> values all-equal?
 ] unit-test
+
+[ 0 1 ] [
+    {
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+            { start 0 }
+            { end 5 }
+            { uses V{ 0 1 5 } }
+        }
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+            { start 3 }
+            { end 4 }
+            { uses V{ 3 4 } }
+        }
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+            { start 2 }
+            { end 6 }
+            { uses V{ 2 4 6 } }
+        }
+    } [ clone ] map
+    H{ { int-regs { "A" "B" } } }
+    allocate-registers
+    first split-before>> [ start>> ] [ end>> ] bi
+] unit-test
diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index 4628728299..855f2a6648 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces
+USING: kernel accessors namespaces make
 cpu.architecture
 compiler.cfg
+compiler.cfg.instructions
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.assignment ;
@@ -28,6 +29,10 @@ IN: compiler.cfg.linear-scan
 
 : linear-scan ( mr -- mr' )
     [
-        [ (linear-scan) ] change-instructions
-        ! spill-counts get >>spill-counts
+        [
+            [
+                (linear-scan) %
+                spill-counts get _spill-counts
+            ] { } make
+        ] change-instructions
     ] with-scope ;
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index a0699b80bd..3ab7e03783 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -4,16 +4,20 @@ USING: namespaces kernel assocs accessors sequences math fry
 compiler.cfg.instructions compiler.cfg.registers ;
 IN: compiler.cfg.linear-scan.live-intervals
 
-TUPLE: live-interval < identity-tuple
+TUPLE: live-interval
 vreg
 reg spill-to reload-from split-before split-after
 start end uses ;
 
+: add-use ( n live-interval -- )
+    [ (>>end) ] [ uses>> push ] 2bi ;
+
 : <live-interval> ( start vreg -- live-interval )
     live-interval new
+        V{ } clone >>uses
         swap >>vreg
-        swap >>start
-        V{ } clone >>uses ;
+        over >>start
+        [ add-use ] keep ;
 
 M: live-interval hashcode*
     nip [ start>> ] [ end>> 1000 * ] bi + ;
@@ -24,25 +28,18 @@ M: live-interval clone
 ! Mapping from vreg to live-interval
 SYMBOL: live-intervals
 
-: add-use ( n vreg live-intervals -- )
-    at [ (>>end) ] [ uses>> push ] 2bi ;
-
 : new-live-interval ( n vreg live-intervals -- )
     2dup key? [ "Multiple defs" throw ] when
     [ [ <live-interval> ] keep ] dip set-at ;
 
 : compute-live-intervals* ( insn n -- )
     live-intervals get
-    [ [ uses-vregs ] 2dip '[ _ swap _ add-use ] each ]
+    [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
     [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
     3bi ;
 
-: finalize-live-intervals ( assoc -- seq' )
-    #! Reverse uses lists so that we can pop values off.
-    values dup [ uses>> reverse-here ] each ;
-
 : compute-live-intervals ( instructions -- live-intervals )
     H{ } clone [
         live-intervals set
         [ compute-live-intervals* ] each-index
-    ] keep finalize-live-intervals ;
+    ] keep values ;
diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index 7a419779a3..4443ea64f7 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math.order assocs kernel sequences
-combinators make compiler.cfg.instructions
+combinators make cpu.architecture compiler.cfg.instructions
 compiler.cfg.instructions.syntax compiler.cfg.registers ;
 IN: compiler.cfg.stack-frame
 
@@ -9,35 +9,31 @@ SYMBOL: frame-required?
 
 SYMBOL: spill-counts
 
-: init-stack-frame-builder ( -- )
-    frame-required? off
-    T{ stack-frame } clone stack-frame set ;
-
 GENERIC: compute-stack-frame* ( insn -- )
 
 : max-stack-frame ( frame1 frame2 -- frame3 )
-    {
-        [ [ size>> ] bi@ max ]
-        [ [ params>> ] bi@ max ]
-        [ [ return>> ] bi@ max ]
-        [ [ total-size>> ] bi@ max ]
-    } 2cleave
-    stack-frame boa ;
+    [ stack-frame new ] 2dip
+        [ [ params>> ] bi@ max >>params ]
+        [ [ return>> ] bi@ max >>return ]
+        2bi ;
 
 M: ##stack-frame compute-stack-frame*
     frame-required? on
     stack-frame>> stack-frame [ max-stack-frame ] change ;
 
-M: _spill-integer compute-stack-frame*
+M: _spill compute-stack-frame*
     drop frame-required? on ;
 
-M: _spill-float compute-stack-frame*
-    drop frame-required? on ;
+M: _spill-counts compute-stack-frame*
+    counts>> stack-frame get (>>spill-counts) ;
 
 M: insn compute-stack-frame* drop ;
 
 : compute-stack-frame ( insns -- )
-    [ compute-stack-frame* ] each ;
+    frame-required? off
+    T{ stack-frame } clone stack-frame set
+    [ compute-stack-frame* ] each
+    stack-frame get dup stack-frame-size >>total-size drop ;
 
 GENERIC: insert-pro/epilogues* ( insn -- )
 
@@ -56,7 +52,6 @@ M: insn insert-pro/epilogues* , ;
 
 : build-stack-frame ( mr -- mr )
     [
-        init-stack-frame-builder
         [
             [ compute-stack-frame ]
             [ insert-pro/epilogues ]
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
new file mode 100644
index 0000000000..f8fb0aab29
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -0,0 +1,23 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.cfg.value-numbering.expressions
+
+! Referentially-transparent expressions.
+
+TUPLE: expr op ;
+
+! op is always %peek
+TUPLE: peek-expr < expr loc ;
+TUPLE: unary-expr < expr in ;
+TUPLE: load-literal-expr < expr obj ;
+
+GENERIC: >expr ( insn -- expr )
+
+M: ##peek >expr
+    [ class ] [ loc>> ] bi peek-expr boa ;
+
+M: ##load-literal >expr
+    [ class ] [ obj>> ] bi load-literal-expr boa ;
+
+M: ##unary >expr
+    [ class ] [ src>> vreg>vn ] bi unary-expr boa ;
diff --git a/basis/compiler/cfg/value-numbering/graph/graph.factor b/basis/compiler/cfg/value-numbering/graph/graph.factor
new file mode 100644
index 0000000000..b0ae044fb7
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/graph/graph.factor
@@ -0,0 +1,32 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.cfg.value-numbering.graph
+
+SYMBOL: vn-counter
+
+: next-vn ( -- vn ) vn-counter [ dup 1 + ] change ;
+
+! biassoc mapping expressions to value numbers
+SYMBOL: exprs>vns
+
+: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
+
+: vn>expr ( vn -- expr ) exprs>vns get value-at ;
+
+! biassoc mapping vregs to value numbers
+SYMBOL: vregs>vns
+
+: vreg>vn ( vreg -- vn ) vregs>vns get at ;
+
+: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
+
+: set-vn ( vn vreg -- ) vregs>vns get set-at ;
+
+: init-value-graph ( -- )
+    0 vn-counter set
+    <bihash> exprs>vns set
+    <bihash> vregs>vns set ;
+
+: reset-value-graph ( -- )
+    exprs>vns get clear-assoc
+    vregs>vns get clear-assoc ;
diff --git a/basis/compiler/cfg/value-numbering/liveness/liveness.factor b/basis/compiler/cfg/value-numbering/liveness/liveness.factor
new file mode 100644
index 0000000000..c445c0835d
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/liveness/liveness.factor
@@ -0,0 +1,38 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.cfg.value-numbering.liveness
+
+! A set of VNs which are (transitively) used by side-effecting
+! instructions.
+SYMBOL: live-vns
+
+GENERIC: live-expr ( expr -- )
+
+: live-vn ( vn -- )
+    #! Mark a VN and all VNs used in its computation as live.
+    dup live-vns get key? [ drop ] [
+        [ live-vns get conjoin ] [ vn>expr live-expr ] bi
+    ] if ;
+
+M: peek-expr live-expr drop ;
+M: unary-expr live-expr in>> live-vn ;
+M: load-literal-expr live-expr in>> live-vn ;
+
+: live-vreg ( vreg -- ) vreg>vn live-vn ;
+
+: live? ( vreg -- ? )
+    dup vreg>vn tuck vn>vreg =
+    [ live-vns get key? ] [ drop f ] if ;
+
+: init-liveness ( -- )
+    H{ } clone live-vns set ;
+
+GENERIC: eliminate ( insn -- insn/f )
+
+: (eliminate) ( insn -- insn/f )
+    dup dst>> >vreg live? [ drop f ] unless ;
+
+M: ##peek eliminate (eliminate) ;
+M: ##unary eliminate (eliminate) ;
+M: ##load-literal eliminate (eliminate) ;
+M: insn eliminate ;
diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
new file mode 100644
index 0000000000..758d3f95e6
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
@@ -0,0 +1,58 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.cfg.value-numbering.propagate
+
+! If two vregs compute the same value, replace references to
+! the latter with the former.
+
+: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
+
+GENERIC: propogate ( insn -- insn )
+
+M: ##cond-branch propagate [ resolve ] change-src ;
+
+M: ##unary propogate [ resolve ] change-src ;
+
+M: ##nullary propagate ;
+
+M: ##replace propagate [ resolve ] change-src ;
+
+M: ##inc-d propagate ;
+
+M: ##inc-r propagate ;
+
+M: ##stack-frame propagate ;
+
+M: ##call propagate ;
+
+M: ##jump propagate ;
+
+M: ##return propagate ;
+
+M: ##intrinsic propagate
+    [ [ resolve ] assoc-map ] change-defs-vregs
+    [ [ resolve ] assoc-map ] change-uses-vregs ;
+
+M: ##dispatch propagate [ resolve ] change-src ;
+
+M: ##dispatch-label propagate ;
+
+M: ##write-barrier propagate [ resolve ] change-src ;
+
+M: ##alien-invoke propagate ;
+
+M: ##alien-indirect propagate ;
+
+M: ##alien-callback propagate ;
+
+M: ##callback-return propagate ;
+
+M: ##prologue propagate ;
+
+M: ##epilogue propagate ;
+
+M: ##branch propagate ;
+
+M: ##if-intrinsic propagate
+    [ [ resolve ] assoc-map ] change-defs-vregs
+    [ [ resolve ] assoc-map ] change-uses-vregs ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
new file mode 100644
index 0000000000..81e8c40afd
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -0,0 +1,46 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.cfg.value-numbering
+
+: insn>vn ( insn -- vn ) >expr simplify ; inline
+
+GENERIC: make-value-node ( insn -- )
+
+M: ##cond-branch make-value-node src>> live-vreg ;
+M: ##unary make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
+M: ##nullary make-value-node drop ;
+M: ##load-literal make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
+M: ##peek make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
+M: ##replace make-value-node reset-value-graph ;
+M: ##inc-d make-value-node reset-value-graph ;
+M: ##inc-r make-value-node reset-value-graph ;
+M: ##stack-frame make-value-node reset-value-graph ;
+M: ##call make-value-node reset-value-graph ;
+M: ##jump make-value-node reset-value-graph ;
+M: ##return make-value-node reset-value-graph ;
+M: ##intrinsic make-value-node uses-vregs [ live-vreg ] each ;
+M: ##dispatch make-value-node reset-value-graph ;
+M: ##dispatch-label make-value-node reset-value-graph ;
+M: ##allot make-value-node drop ;
+M: ##write-barrier make-value-node drop ;
+M: ##gc make-value-node reset-value-graph ;
+M: ##replace make-value-node reset-value-graph ;
+M: ##alien-invoke make-value-node reset-value-graph ;
+M: ##alien-indirect make-value-node reset-value-graph ;
+M: ##alien-callback make-value-node reset-value-graph ;
+M: ##callback-return make-value-node reset-value-graph ;
+M: ##prologue make-value-node reset-value-graph ;
+M: ##epilogue make-value-node reset-value-graph ;
+M: ##branch make-value-node reset-value-graph ;
+M: ##if-intrinsic make-value-node uses-vregs [ live-vreg ] each ;
+
+: init-value-numbering ( -- )
+    init-value-graph
+    init-expressions
+    init-liveness ;
+
+: value-numbering ( instructions -- instructions )
+    init-value-numbering
+    [ [ make-value-node ] [ propagate ] bi ] map
+    [ eliminate ] map
+    sift ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 44e2fd6bac..6c83c38355 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -72,11 +72,7 @@ M: _label generate-insn
     id>> lookup-label , ;
 
 M: _prologue generate-insn
-    stack-frame>>
-    [ stack-frame set ]
-    [ dup size>> stack-frame-size >>total-size drop ]
-    [ total-size>> %prologue ]
-    tri ;
+    stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
 
 M: _epilogue generate-insn
     stack-frame>> total-size>> %epilogue ;
@@ -439,3 +435,17 @@ M: ##alien-callback generate-insn
     [ wrap-callback-quot %alien-callback ]
     [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
     tri ;
+
+M: _spill generate-insn
+    [ src>> ] [ n>> ] [ class>> ] tri {
+        { int-regs [ %spill-integer ] }
+        { double-float-regs [ %spill-float ] }
+    } case ;
+
+M: _reload generate-insn
+    [ dst>> ] [ n>> ] [ class>> ] tri {
+        { int-regs [ %reload-integer ] }
+        { double-float-regs [ %reload-float ] }
+    } case ;
+
+M: _spill-counts generate-insn drop ;
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index c94252e7ac..c02c1e8fda 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -61,18 +61,6 @@ SYMBOL: +failed+
 : frontend ( word -- effect nodes )
     [ build-tree-from-word ] [ fail ] recover optimize-tree ;
 
-: finish ( effect word -- )
-    [ swap save-effect ]
-    [ compiled-unxref ]
-    [
-        dup crossref?
-        [
-            dependencies get >alist
-            generic-dependencies get >alist
-            compiled-xref
-        ] [ drop ] if
-    ] tri ;
-
 ! Only switch this off for debugging.
 SYMBOL: compile-dependencies?
 
@@ -92,6 +80,18 @@ t compile-dependencies? set-global
         save-asm
     ] each ;
 
+: finish ( effect word -- )
+    [ swap save-effect ]
+    [ compiled-unxref ]
+    [
+        dup crossref?
+        [
+            dependencies get >alist
+            generic-dependencies get >alist
+            compiled-xref
+        ] [ drop ] if
+    ] tri ;
+
 : (compile) ( word -- )
     '[
         _ {

From 774ecf61e9f388f54ab7f3ae26f823c75b7ea871 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 19 Oct 2008 01:10:45 -0500
Subject: [PATCH 037/318] Implement spilling on x86

---
 basis/cpu/architecture/architecture.factor    | 11 ++++++-
 basis/cpu/x86/32/32.factor                    |  5 ++-
 .../cpu/x86/architecture/architecture.factor  | 33 +++++++++++++++----
 basis/cpu/x86/sse2/sse2.factor                |  6 ++++
 4 files changed, 46 insertions(+), 9 deletions(-)

diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 1931187779..2d3f8a8b40 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -43,7 +43,7 @@ GENERIC# load-literal 1 ( obj reg -- )
 
 HOOK: load-indirect cpu ( obj reg -- )
 
-HOOK: stack-frame-size cpu ( frame-size -- n )
+HOOK: stack-frame-size cpu ( stack-frame -- n )
 
 ! Set up caller stack frame
 HOOK: %prologue cpu ( n -- )
@@ -197,3 +197,12 @@ HOOK: %write-barrier cpu ( src card# table -- )
 
 ! GC check
 HOOK: %gc cpu ( -- )
+
+! Spilling
+HOOK: %spill-integer cpu ( src n -- )
+
+HOOK: %spill-float cpu ( src n -- )
+
+HOOK: %reload-integer cpu ( dst n -- )
+
+HOOK: %reload-float cpu ( dst n -- )
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index a170878eec..e7e654c8f7 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -267,7 +267,10 @@ M: x86.32 %callback-return ( n -- )
     #! b) If the callback is returning a large struct, we have
     #! to fix ESP.
     {
-        { [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
+        { [ dup abi>> "stdcall" = ] [
+            <alien-stack-frame>
+            [ params>> ] [ return>> ] bi +
+        ] }
         { [ dup return>> large-struct? ] [ drop 4 ] }
         [ drop 0 ]
     } cond RET ;
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 83876d72f8..bfcb79d41d 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -1,10 +1,11 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays cpu.x86.assembler
-cpu.x86.assembler.private cpu.architecture kernel kernel.private
-math memory namespaces make sequences words system
-layouts combinators math.order locals compiler.constants
-compiler.cfg.registers compiler.cfg.instructions
+USING: accessors assocs alien alien.c-types arrays
+cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
+kernel kernel.private math memory namespaces make sequences
+words system layouts combinators math.order locals
+compiler.constants compiler.cfg.registers
+compiler.cfg.instructions compiler.codegen
 compiler.codegen.fixup ;
 IN: cpu.x86.architecture
 
@@ -14,6 +15,13 @@ HOOK: stack-reg cpu ( -- reg )
 
 : stack@ ( n -- op ) stack-reg swap [+] ;
 
+: spill-integer@ ( n -- op )
+    cells stack-frame get [ params>> ] [ return>> ] bi + + stack@ ;
+
+: spill-float@ ( n -- op )
+    #! XXX
+    cells stack-frame get [ params>> ] [ return>> ] bi + + stack@ ;
+
 : next-stack@ ( n -- operand )
     #! nth parameter from the next stack frame. Used to box
     #! input values to callbacks; the callback has its own
@@ -60,8 +68,13 @@ M: fixnum load-literal
 : align-stack ( n -- n' )
     os macosx? cpu x86.64? or [ 16 align ] when ;
 
-M: x86 stack-frame-size ( n -- i )
-    3 cells + align-stack ;
+M: x86 stack-frame-size ( stack-frame -- i )
+    [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+    [ params>> ]
+    [ return>> ]
+    tri + +
+    3 cells +
+    align-stack ;
 
 : decr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
@@ -193,3 +206,9 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
     rs-reg POP
     ! Restore ds-reg
     ds-reg POP ;
+
+M: x86 %spill-integer ( src n -- )
+    spill-integer@ swap MOV ;
+
+M: x86 %reload-integer ( dst n -- )
+    spill-integer@ MOV ;
diff --git a/basis/cpu/x86/sse2/sse2.factor b/basis/cpu/x86/sse2/sse2.factor
index 9650a4ce11..1f3090fcbd 100644
--- a/basis/cpu/x86/sse2/sse2.factor
+++ b/basis/cpu/x86/sse2/sse2.factor
@@ -8,6 +8,12 @@ compiler.cfg.registers compiler.cfg.builder cpu.architecture
 cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics ;
 IN: cpu.x86.sse2
 
+M: x86 %spill-float ( src n -- )
+    spill-float@ swap MOVSD ;
+
+M: x86 %reload-float ( dst n -- )
+    spill-float@ MOVSD ;
+
 M: x86 %copy-float MOVSD ;
 
 M:: x86 %box-float ( dst src temp -- )

From 14d8696f40c20b2d7107eddedf879a2881b6da1e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 19 Oct 2008 03:34:42 -0500
Subject: [PATCH 038/318] Oops, don't mix register classes in active set

---
 basis/compiler/cfg/debugger/debugger.factor   |  2 +-
 .../linear-scan/allocation/allocation.factor  | 24 +++--
 basis/compiler/tests/templates.factor         | 91 ++++++++++++++++++-
 .../cpu/x86/architecture/architecture.factor  | 18 +++-
 4 files changed, 121 insertions(+), 14 deletions(-)

diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index a04670ddab..6665564c91 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -16,7 +16,7 @@ M: word test-cfg
     [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
 
 : test-mr ( quot -- mrs )
-    test-cfg [ build-mr ] map ;
+    test-cfg [ build-mr linear-scan build-stack-frame ] map ;
 
 : mr. ( mrs -- )
     [
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 1b49609387..9402e4d841 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -18,16 +18,22 @@ SYMBOL: free-registers
 ! Vector of active live intervals
 SYMBOL: active-intervals
 
+: active-intervals-for ( vreg -- seq )
+    reg-class>> active-intervals get at ;
+
 : add-active ( live-interval -- )
-    active-intervals get push ;
+    dup vreg>> active-intervals-for push ;
 
 : delete-active ( live-interval -- )
-    active-intervals get delete ;
+    dup vreg>> active-intervals-for delq ;
 
 : expire-old-intervals ( n -- )
-    active-intervals get
-    [ end>> > ] with partition
-    [ [ deallocate-register ] each ] [ active-intervals set ] bi* ;
+    active-intervals swap '[
+        [
+            [ end>> _ < ] partition
+            [ [ deallocate-register ] each ] dip
+        ] assoc-map
+    ] change ;
 
 ! Minheap of live intervals which still need a register allocation
 SYMBOL: unhandled-intervals
@@ -115,7 +121,7 @@ SYMBOL: spill-counts
     over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
 
 : assign-blocked-register ( new -- )
-    [ active-intervals get ] keep interval-to-spill
+    [ dup vreg>> active-intervals-for ] keep interval-to-spill
     2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
 
 : assign-free-register ( new registers -- )
@@ -126,11 +132,13 @@ SYMBOL: spill-counts
     [ assign-blocked-register ] [ assign-free-register ] if-empty ;
 
 ! Main loop
+: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
+
 : init-allocator ( registers -- )
-    V{ } clone active-intervals set
     <min-heap> unhandled-intervals set
     [ reverse >vector ] assoc-map free-registers set
-    H{ { int-regs 0 } { double-float-regs 0 } } clone spill-counts set
+    reg-classes [ 0 ] { } map>assoc spill-counts set
+    reg-classes [ V{ } clone ] { } map>assoc active-intervals set
     -1 progress set ;
 
 : handle-interval ( live-interval -- )
diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/templates.factor
index c8baaea164..a979a19e83 100644
--- a/basis/compiler/tests/templates.factor
+++ b/basis/compiler/tests/templates.factor
@@ -101,7 +101,6 @@ unit-test
     ] [ define-temp ] with-compilation-unit drop
 ] unit-test
 
-
 ! Test how dispatch handles the end of a basic block
 : try-breaking-dispatch ( n a b -- a b str )
     float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
@@ -189,7 +188,7 @@ TUPLE: my-tuple ;
 ] unit-test
 
 ! Regression
-: a-dummy ( -- ) drop "hi" print ;
+: a-dummy ( a -- ) drop "hi" print ;
 
 [ ] [
     1 [
@@ -245,8 +244,96 @@ TUPLE: my-tuple ;
         [ dup float+ ]
     } cleave ;
 
+[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
+[ 1.0 float-spill-bug ] unit-test
+
 [ t ] [ \ float-spill-bug compiled>> ] unit-test
 
+: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
+    {
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+    } cleave ;
+
+[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
+[ 1.0 float-fixnum-spill-bug ] unit-test
+
+[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
+
 ! Regression
 : dispatch-alignment-regression ( -- c )
     { tuple vector } 3 slot { word } declare
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index bfcb79d41d..3b48610fe7 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -15,12 +15,24 @@ HOOK: stack-reg cpu ( -- reg )
 
 : stack@ ( n -- op ) stack-reg swap [+] ;
 
+: spill-integer-base ( stack-frame -- n )
+    [ params>> ] [ return>> ] bi + ;
+
 : spill-integer@ ( n -- op )
-    cells stack-frame get [ params>> ] [ return>> ] bi + + stack@ ;
+    cells
+    stack-frame get spill-integer-base
+    + stack@ ;
+
+: spill-float-base ( stack-frame -- n )
+    [ spill-counts>> int-regs swap at int-regs reg-size * ]
+    [ params>> ]
+    [ return>> ]
+    tri + + ;
 
 : spill-float@ ( n -- op )
-    #! XXX
-    cells stack-frame get [ params>> ] [ return>> ] bi + + stack@ ;
+    double-float-regs reg-size *
+    stack-frame get spill-float-base
+    + stack@ ;
 
 : next-stack@ ( n -- operand )
     #! nth parameter from the next stack frame. Used to box

From 4ae66793f028ad54beb524476a7d403e07a5cd3f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 19 Oct 2008 03:51:01 -0500
Subject: [PATCH 039/318] Fixing unit tests

---
 basis/compiler/tests/templates.factor | 51 ++++++++++++++++++++++-----
 1 file changed, 42 insertions(+), 9 deletions(-)

diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/templates.factor
index a979a19e83..6bcbb8baea 100644
--- a/basis/compiler/tests/templates.factor
+++ b/basis/compiler/tests/templates.factor
@@ -1,11 +1,15 @@
-! Black box testing of templating optimization
-USING: accessors arrays compiler kernel kernel.private math
-hashtables.private math.private namespaces sequences
-sequences.private tools.test namespaces.private slots.private
-sequences.private byte-arrays alien alien.accessors layouts
-words definitions compiler.units io combinators vectors ;
+USING: generalizations accessors arrays compiler kernel
+kernel.private math hashtables.private math.private namespaces
+sequences sequences.private tools.test namespaces.private
+slots.private sequences.private byte-arrays alien
+alien.accessors layouts words definitions compiler.units io
+combinators vectors ;
 IN: compiler.tests
 
+! Originally, this file did black box testing of templating
+! optimization. We now have a different codegen, but the tests
+! in here are still useful.
+
 ! Oops!
 [ 5000 ] [ [ 5000 ] compile-call ] unit-test
 [ "hi" ] [ [ "hi" ] compile-call ] unit-test
@@ -102,7 +106,7 @@ unit-test
 ] unit-test
 
 ! Test how dispatch handles the end of a basic block
-: try-breaking-dispatch ( n a b -- a b str )
+: try-breaking-dispatch ( n a b -- x str )
     float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
 
 : try-breaking-dispatch-2 ( -- ? )
@@ -121,7 +125,7 @@ unit-test
 ] unit-test
 
 ! Regression
-: hellish-bug-1 2drop ;
+: hellish-bug-1 ( a b -- ) 2drop ;
 
 : hellish-bug-2 ( i array x -- x ) 
     2dup 1 slot eq? [ 2drop ] [ 
@@ -131,7 +135,7 @@ unit-test
                 pick 2dup hellish-bug-1 3drop
             ] 2keep
         ] unless >r 2 fixnum+fast r> hellish-bug-2
-    ] if ; inline
+    ] if ; inline recursive
 
 : hellish-bug-3 ( hash array -- ) 
     0 swap hellish-bug-2 drop ;
@@ -334,6 +338,35 @@ TUPLE: my-tuple ;
 
 [ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
 
+: resolve-spill-bug ( a b -- c )
+    [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
+        nip 2 fixnum+fast
+    ] [
+        drop {
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+        } cleave
+        16 narray
+    ] if ;
+
+[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+
+[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
+
 ! Regression
 : dispatch-alignment-regression ( -- c )
     { tuple vector } 3 slot { word } declare

From f092622facb1eb55cea39d3ec5c864b566577503 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 20 Oct 2008 01:56:28 -0500
Subject: [PATCH 040/318] CFG IR is now pure SSA

---
 .../compiler/cfg/builder/builder-tests.factor |   2 +
 basis/compiler/cfg/builder/builder.factor     | 125 +-----
 basis/compiler/cfg/builder/calls/calls.factor | 360 ++++++++++++++++++
 basis/compiler/cfg/builder/hats/hats.factor   |  62 +++
 .../cfg/{ => builder}/stacks/authors.txt      |   0
 .../cfg/{ => builder}/stacks/stacks.factor    | 177 ++-------
 basis/compiler/cfg/debugger/debugger.factor   |  17 +-
 basis/compiler/cfg/def-use/def-use.factor     |  31 ++
 .../cfg/instructions/instructions.factor      | 192 +++++++---
 .../linear-scan/assignment/assignment.factor  |   1 +
 .../live-intervals/live-intervals.factor      |   3 +-
 .../cfg/linearization/linearization.factor    |  19 +-
 basis/compiler/cfg/registers/registers.factor |  88 +----
 basis/compiler/cfg/templates/templates.factor |  86 -----
 .../value-numbering/liveness/liveness.factor  |   2 +-
 .../propagate/propagate.factor                |   4 +-
 .../value-numbering/value-numbering.factor    |   4 +-
 basis/compiler/codegen/codegen.factor         | 219 ++++++-----
 basis/compiler/codegen/fixup/fixup.factor     |   5 +-
 basis/compiler/tests/simple.factor            |   8 +-
 basis/compiler/tests/templates.factor         |   5 +
 basis/compiler/tree/builder/builder.factor    |   2 +-
 .../tree/combinators/combinators.factor       |   2 +-
 basis/compiler/tree/debugger/debugger.factor  |   2 +-
 .../known-words/known-words.factor            |   2 +-
 basis/cpu/architecture/architecture.factor    | 180 +++++----
 basis/cpu/ppc/allot/allot.factor              |   2 +-
 basis/cpu/x86/32/32.factor                    |   6 +-
 basis/cpu/x86/64/64.factor                    |  11 +-
 .../cpu/x86/architecture/architecture.factor  |  16 +-
 30 files changed, 923 insertions(+), 710 deletions(-)
 create mode 100644 basis/compiler/cfg/builder/calls/calls.factor
 create mode 100644 basis/compiler/cfg/builder/hats/hats.factor
 rename basis/compiler/cfg/{ => builder}/stacks/authors.txt (100%)
 rename basis/compiler/cfg/{ => builder}/stacks/stacks.factor (52%)
 create mode 100644 basis/compiler/cfg/def-use/def-use.factor
 delete mode 100644 basis/compiler/cfg/templates/templates.factor

diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index a9f3f2eaa9..4ac25a3c30 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -4,6 +4,8 @@ words sequences.private fry prettyprint alien
 math.private compiler.tree.builder compiler.tree.optimizer
 compiler.cfg.builder compiler.cfg.debugger  ;
 
+\ build-cfg must-infer
+
 ! Just ensure that various CFGs build correctly.
 {
     [ ]
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index e5f91d19df..7fd65fb05e 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -2,24 +2,23 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators hashtables kernel
 math fry namespaces make sequences words byte-arrays
-locals layouts alien.c-types alien.structs
-stack-checker.inlining
-cpu.architecture
-compiler.intrinsics
+layouts alien.c-types alien.structs
+stack-checker.inlining cpu.architecture
 compiler.tree
 compiler.tree.builder
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.cfg
-compiler.cfg.stacks
-compiler.cfg.templates
 compiler.cfg.iterator
-compiler.cfg.instructions
 compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.builder.hats
+compiler.cfg.builder.calls
+compiler.cfg.builder.stacks
 compiler.alien ;
 IN: compiler.cfg.builder
 
-! Convert tree SSA IR to CFG (not quite SSA yet) IR.
+! Convert tree SSA IR to CFG SSA IR.
 
 : set-basic-block ( basic-block -- )
     [ basic-block set ] [ instructions>> building set ] bi ;
@@ -93,12 +92,6 @@ GENERIC: emit-node ( node -- next )
         ] with-variable
     ] keep ;
 
-SYMBOL: +intrinsics+
-SYMBOL: +if-intrinsics+
-
-: if-intrinsics ( #call -- quot )
-    word>> +if-intrinsics+ word-prop ;
-
 : local-recursive-call ( basic-block -- next )
     ##branch
     basic-block get successors>> push
@@ -131,22 +124,22 @@ M: #recursive emit-node
     dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
 
 ! #if
-: emit-branch ( obj quot -- final-bb )
-    '[
+: emit-branch ( obj -- final-bb )
+    [
         begin-basic-block copy-phantoms
-        @
+        emit-nodes
         basic-block get dup [ ##branch ] when
     ] with-scope ;
 
-: emit-branches ( seq quot -- )
-    '[ _ emit-branch ] map
+: emit-if ( node -- )
+    children>>  [ emit-branch ] map
     end-basic-block
     begin-basic-block
     basic-block get '[ [ _ swap successors>> push ] when* ] each
     init-phantoms ;
 
-: emit-if ( node -- next )
-    children>> [ emit-nodes ] emit-branches ;
+: ##branch-t ( vreg -- )
+    \ f tag-number cc/= ##binary-imm-branch ;
 
 M: #if emit-node
     phantom-pop ##branch-t emit-if iterate-next ;
@@ -194,100 +187,16 @@ M: #dispatch emit-node
     ] if ;
 
 ! #call
-: define-intrinsics ( word intrinsics -- )
-    +intrinsics+ set-word-prop ;
-
-: define-intrinsic ( word quot assoc -- )
-    2array 1array define-intrinsics ;
-
-: define-if-intrinsics ( word intrinsics -- )
-    [ template new swap >>input ] assoc-map
-    +if-intrinsics+ set-word-prop ;
-
-: define-if-intrinsic ( word quot inputs -- )
-    2array 1array define-if-intrinsics ;
-
-: find-intrinsic ( #call -- pair/f )
-    word>> +intrinsics+ word-prop find-template ;
-
-: find-boolean-intrinsic ( #call -- pair/f )
-    word>> +if-intrinsics+ word-prop find-template ;
-
-: find-if-intrinsic ( #call -- pair/f )
-    node@ {
-        { [ dup length 2 < ] [ 2drop f ] }
-        { [ dup second #if? ] [ drop find-boolean-intrinsic ] }
-        [ 2drop f ]
-    } cond ;
-
-: do-if-intrinsic ( pair -- next )
-    [ ##if-intrinsic ] apply-template skip-next emit-if
-    iterate-next ;
-
-: do-boolean-intrinsic ( pair -- next )
-    [ ##if-intrinsic ] apply-template
-    { t f } [
-        <constant> phantom-push finalize-phantoms
-    ] emit-branches
-    iterate-next ;
-
-: do-intrinsic ( pair -- next )
-    [ ##intrinsic ] apply-template iterate-next ;
-
-: setup-value-classes ( #call -- )
-    node-input-infos [ class>> ] map set-value-classes ;
-
-{
-    (tuple) (array) (byte-array)
-    (complex) (ratio) (wrapper)
-    (write-barrier)
-} [ t "intrinsic" set-word-prop ] each
-
-: allot-size ( -- n )
-    1 phantom-datastack get phantom-input first value>> ;
-
-:: emit-allot ( size type tag -- )
-    int-regs next-vreg
-    dup fresh-object
-    dup size type tag int-regs next-vreg ##allot
-    type tagged boa phantom-push ;
-
-: emit-write-barrier ( -- )
-    phantom-pop dup fresh-object? [ drop ] [
-        int-regs next-vreg
-        int-regs next-vreg
-        ##write-barrier
-    ] if ;
-
-: emit-intrinsic ( word -- next )
-    {
-        { \ (tuple) [ allot-size 2 + cells tuple tuple emit-allot ] }
-        { \ (array) [ allot-size 2 + cells array object emit-allot ] }
-        { \ (byte-array) [ allot-size 2 cells + byte-array object emit-allot ] }
-        { \ (complex) [ 3 cells complex complex emit-allot ] }
-        { \ (ratio) [ 3 cells ratio ratio emit-allot ] }
-        { \ (wrapper) [ 2 cells wrapper object emit-allot ] }
-        { \ (write-barrier) [ emit-write-barrier ] }
-    } case
-    iterate-next ;
-
 M: #call emit-node
-    dup setup-value-classes
-    dup find-if-intrinsic [ do-if-intrinsic ] [
-        dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
-            dup find-intrinsic [ do-intrinsic ] [
-                word>> dup "intrinsic" word-prop
-                [ emit-intrinsic ] [ emit-call ] if
-            ] ?if
-        ] ?if
-    ] ?if ;
+    dup word>> dup "intrinsic" word-prop
+    [ emit-intrinsic iterate-next ] [ nip emit-call ] if ;
 
 ! #call-recursive
 M: #call-recursive emit-node label>> id>> emit-call ;
 
 ! #push
 M: #push emit-node
-    literal>> <constant> phantom-push iterate-next ;
+    literal>> ^^load-literal phantom-push iterate-next ;
 
 ! #shuffle
 M: #shuffle emit-node
diff --git a/basis/compiler/cfg/builder/calls/calls.factor b/basis/compiler/cfg/builder/calls/calls.factor
new file mode 100644
index 0000000000..86ebdf575b
--- /dev/null
+++ b/basis/compiler/cfg/builder/calls/calls.factor
@@ -0,0 +1,360 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: qualified kernel words sequences layouts namespaces
+accessors fry arrays byte-arrays locals math combinators alien
+classes.algebra cpu.architecture compiler.tree.propagation.info
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.builder.hats
+compiler.cfg.builder.stacks ;
+QUALIFIED: compiler.intrinsics
+QUALIFIED: kernel.private
+QUALIFIED: slots.private
+QUALIFIED: math.private
+QUALIFIED: alien.accessors
+IN: compiler.cfg.builder.calls
+
+{
+    kernel.private:tag
+    math.private:fixnum+fast
+    math.private:fixnum-fast
+    math.private:fixnum-bitand
+    math.private:fixnum-bitor 
+    math.private:fixnum-bitxor
+    math.private:fixnum-shift-fast
+    math.private:fixnum-bitnot
+    math.private:fixnum*fast
+    math.private:fixnum< 
+    math.private:fixnum<=
+    math.private:fixnum>=
+    math.private:fixnum>
+    math.private:bignum>fixnum
+    math.private:fixnum>bignum
+    eq?
+    compiler.intrinsics:(slot)
+    compiler.intrinsics:(set-slot)
+    compiler.intrinsics:(tuple)
+    compiler.intrinsics:(array)
+    compiler.intrinsics:(byte-array)
+    compiler.intrinsics:(complex)
+    compiler.intrinsics:(ratio)
+    compiler.intrinsics:(wrapper)
+    compiler.intrinsics:(write-barrier)
+    alien.accessors:alien-unsigned-1
+    alien.accessors:set-alien-unsigned-1
+    alien.accessors:alien-signed-1
+    alien.accessors:set-alien-signed-1
+    alien.accessors:alien-unsigned-2
+    alien.accessors:set-alien-unsigned-2
+    alien.accessors:alien-signed-2
+    alien.accessors:set-alien-signed-2
+    alien.accessors:alien-cell
+    alien.accessors:set-alien-cell
+} [ t "intrinsic" set-word-prop ] each
+
+: enable-alien-4-intrinsics ( -- )
+    {
+        alien.accessors:alien-unsigned-4
+        alien.accessors:set-alien-unsigned-4
+        alien.accessors:alien-signed-4
+        alien.accessors:set-alien-signed-4
+    } [ t "intrinsic" set-word-prop ] each ;
+
+: enable-float-intrinsics ( -- )
+    {
+        math.private:float+
+        math.private:float-
+        math.private:float*
+        math.private:float/f
+        math.private:fixnum>float
+        math.private:float>fixnum
+        alien.accessors:alien-float
+        alien.accessors:set-alien-float
+        alien.accessors:alien-double
+        alien.accessors:set-alien-double
+    } [ t "intrinsic" set-word-prop ] each ;
+
+: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ;
+
+: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ;
+
+: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ;
+
+: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ;
+
+: emit-tag ( -- )
+    phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ;
+
+: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ;
+
+: (emit-slot) ( infos -- dst )
+    [ 2phantom-pop ] [ third literal>> ] bi*
+    ^^slot ;
+
+: (emit-slot-imm) ( infos -- dst )
+    1 phantom-drop
+    [ phantom-pop ^^offset>slot ]
+    [ [ second literal>> ] [ third literal>> ] bi ] bi*
+    ^^slot-imm ;
+
+: value-info-small-tagged? ( value-info -- ? )
+    dup literal?>> [ literal>> small-tagged? ] [ drop f ] if ;
+
+: emit-slot ( node -- )
+    node-input-infos
+    dup second value-info-small-tagged?
+    [ (emit-slot-imm) ] [ (emit-slot) ] if
+    phantom-push ;
+
+: (emit-set-slot) ( infos -- )
+    [ 3phantom-pop ] [ fourth literal>> ] bi*
+    ##set-slot ;
+
+: (emit-set-slot-imm) ( infos -- )
+    1 phantom-drop
+    [ 2phantom-pop ^^offset>slot ]
+    [ [ third literal>> ] [ fourth literal>> ] bi ] bi*
+    ##set-slot-imm ;
+
+: emit-set-slot ( node -- )
+    1 phantom-drop
+    node-input-infos
+    dup third value-info-small-tagged?
+    [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if ;
+
+: (emit-fixnum-imm-op) ( infos insn -- dst )
+    1 phantom-drop
+    [ phantom-pop ] [ second literal>> tag-fixnum ] [ ] tri*
+    call ; inline
+
+: (emit-fixnum-op) ( insn -- dst )
+    [ 2phantom-pop ] dip call ; inline
+
+:: emit-fixnum-op ( node insn imm-insn -- )
+    [let | infos [ node node-input-infos ] |
+        infos second value-info-small-tagged?
+        [ infos imm-insn (emit-fixnum-imm-op) ]
+        [ insn (emit-fixnum-op) ]
+        if
+    ] ; inline
+
+: emit-primitive ( node -- )
+    word>> ##simple-stack-frame ##call ;
+
+: emit-fixnum-shift-fast ( node -- )
+    dup node-input-infos dup second value-info-small-tagged? [
+        nip
+        [ 1 phantom-drop phantom-pop ] dip
+        second literal>> dup sgn {
+            { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
+            {  0 [ drop ] }
+            {  1 [ ^^shl-imm ] }
+        } case
+        phantom-push
+    ] [ drop emit-primitive ] if ;
+
+: emit-fixnum-bitnot ( -- )
+    phantom-pop ^^not tag-mask get ^^xor-imm phantom-push ;
+
+: (emit-fixnum*fast) ( -- dst )
+    2phantom-pop ^^untag-fixnum ^^mul ;
+
+: (emit-fixnum*fast-imm) ( infos -- dst )
+    1 phantom-drop
+    [ phantom-pop ] [ second literal>> ] bi* ^^mul-imm ;
+
+: emit-fixnum*fast ( node -- )
+    node-input-infos
+    dup second value-info-small-tagged?
+    [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
+    phantom-push ;
+
+: emit-fixnum-comparison ( node cc -- )
+    [ '[ _ ##boolean ] ] [ '[ _ ##boolean-imm ] ] bi
+    emit-fixnum-op ;
+
+: emit-bignum>fixnum ( -- )
+    phantom-pop ^^bignum>integer ^^tag-fixnum phantom-push ;
+
+: emit-fixnum>bignum ( -- )
+    phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ;
+
+: emit-float-op ( insn -- )
+    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float ; inline
+
+: emit-float-comparison ( cc -- )
+    '[ _ ##boolean ] emit-float-op ;
+
+: emit-float>fixnum ( -- )
+    phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ;
+
+: emit-fixnum>float ( -- )
+    phantom-pop ^^untag-fixnum ^^integer>float ^^box-float phantom-push ;
+
+: pop-literal ( node -- n )
+    1 phantom-drop dup in-d>> first node-value-info literal>> ; 
+
+: emit-allot ( size type tag -- )
+    ^^allot [ fresh-object ] [ phantom-push ] bi ;
+
+: emit-write-barrier ( -- )
+    phantom-pop dup fresh-object? [ drop ] [ ^^write-barrier ] if ;
+
+: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
+    1 phantom-drop [ phantom-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
+
+: (prepare-alien-accessor) ( class -- offset-vreg )
+    [ 2phantom-pop ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+
+: prepare-alien-accessor ( infos -- offset-vreg )
+    <reversed> [ second class>> ] [ first ] bi
+    dup value-info-small-tagged? [
+        1 phantom-drop
+        literal>> (prepare-alien-accessor-imm)
+    ] [ drop (prepare-alien-accessor) ] if ;
+
+:: inline-alien ( node quot test -- )
+    [let | infos [ node node-input-infos ] |
+        infos test call
+        [ infos prepare-alien-accessor quot call ]
+        [ node emit-primitive ]
+        if
+    ] ; inline
+
+: inline-alien-getter? ( infos -- ? )
+    [ first class>> c-ptr class<= ]
+    [ second class>> fixnum class<= ]
+    bi and ;
+
+: inline-alien-getter ( node quot -- )
+    '[ @ phantom-push ]
+    [ inline-alien-getter? ] inline-alien ; inline
+
+: inline-alien-setter? ( infos class -- ? )
+    '[ first class>> _ class<= ]
+    [ second class>> c-ptr class<= ]
+    [ third class>> fixnum class<= ]
+    tri and and ;
+
+: inline-alien-integer-setter ( node quot -- )
+    '[ phantom-pop ^^untag-fixnum @ ]
+    [ fixnum inline-alien-setter? ]
+    inline-alien ; inline
+
+: inline-alien-cell-setter ( node quot -- )
+    [ dup node-input-infos first class>> ] dip
+    '[ phantom-pop _ ^^unbox-c-ptr @ ]
+    [ pinned-c-ptr inline-alien-setter? ]
+    inline-alien ; inline
+
+: inline-alien-float-setter ( node quot -- )
+    '[ phantom-pop ^^unbox-float @ ]
+    [ 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
+    ] inline-alien-getter ;
+
+: emit-alien-signed-getter ( node n -- )
+    '[
+        _ {
+            { 1 [ ^^alien-signed-1 ] }
+            { 2 [ ^^alien-signed-2 ] }
+            { 4 [ ^^alien-signed-4 ] }
+        } case ^^tag-fixnum
+    ] 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 reg-class -- )
+    '[
+        _ {
+            { single-float-regs [ ^^alien-float ] }
+            { double-float-regs [ ^^alien-double ] }
+        } case ^^box-float
+    ] inline-alien-getter ;
+
+: emit-alien-float-setter ( node reg-class -- )
+    '[
+        _ {
+            { single-float-regs [ ##set-alien-float ] }
+            { double-float-regs [ ##set-alien-double ] }
+        } case
+    ] inline-alien-float-setter ;
+
+: emit-intrinsic ( node word -- )
+    {
+        { \ kernel.private:tag [ drop emit-tag ] }
+        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
+        { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+        { \ math.private:fixnum*fast [ emit-fixnum*fast ] }
+        { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
+        { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
+        { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
+        { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
+        { \ eq? [ cc= emit-fixnum-comparison ] }
+        { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
+        { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
+        { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+        { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+        { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+        { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+        { \ math.private:float< [ drop cc< emit-float-comparison ] }
+        { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
+        { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
+        { \ math.private:float> [ drop cc> emit-float-comparison ] }
+        { \ math.private:float= [ drop cc> emit-float-comparison ] }
+        { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
+        { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
+        { \ compiler.intrinsics:(slot) [ emit-slot ] }
+        { \ compiler.intrinsics:(set-slot) [ emit-set-slot ] }
+        { \ compiler.intrinsics:(tuple) [ pop-literal 2 + cells tuple tuple emit-allot ] }
+        { \ compiler.intrinsics:(array) [ pop-literal 2 + cells array object emit-allot ] }
+        { \ compiler.intrinsics:(byte-array) [ pop-literal 2 cells + byte-array object emit-allot ] }
+        { \ compiler.intrinsics:(complex) [ drop 3 cells complex complex emit-allot ] }
+        { \ compiler.intrinsics:(ratio) [ drop 3 cells ratio ratio emit-allot ] }
+        { \ compiler.intrinsics:(wrapper) [ drop 2 cells wrapper object emit-allot ] }
+        { \ compiler.intrinsics:(write-barrier) [ drop emit-write-barrier ] }
+        { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+        { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+        { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
+        { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
+    } case ;
diff --git a/basis/compiler/cfg/builder/hats/hats.factor b/basis/compiler/cfg/builder/hats/hats.factor
new file mode 100644
index 0000000000..4ac7f92ea3
--- /dev/null
+++ b/basis/compiler/cfg/builder/hats/hats.factor
@@ -0,0 +1,62 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel cpu.architecture compiler.cfg.registers
+compiler.cfg.instructions ;
+IN: compiler.cfg.builder.hats
+
+: i int-regs next-vreg ; inline
+: ^^i i dup ; inline
+: ^^i1 [ ^^i ] dip ; inline
+: ^^i2 [ ^^i ] 2dip ; inline
+: ^^i3 [ ^^i ] 3dip ; inline
+
+: d double-float-regs next-vreg ; inline
+: ^^d d dup ; inline
+: ^^d1 [ ^^d ] dip ; inline
+: ^^d2 [ ^^d ] 2dip ; inline
+: ^^d3 [ ^^d ] 3dip ; inline
+
+: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
+: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
+: ^^slot ( obj slot tag -- dst ) ^^i3 ##slot ; inline
+: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
+: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
+: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
+: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
+: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
+: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
+: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
+: ^^and ( input mask -- output ) ^^i2 ##and ; inline
+: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline
+: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline
+: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
+: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
+: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
+: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
+: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
+: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
+: ^^not ( src -- dst ) ^^i1 ##not ; inline
+: ^^bignum>integer ( src -- dst ) ^^i1 ##bignum>integer ; inline
+: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
+: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
+: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
+: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
+: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
+: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
+: ^^integer>float ( src -- dst ) ^^d1 i ##integer>float ; inline
+: ^^allot ( size type tag -- dst ) ^^i3 i ##allot ; inline
+: ^^write-barrier ( src -- ) i i ##write-barrier ; inline
+: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
+: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
+: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
+: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
+: ^^unbox-c-ptr ( src class -- dst ) ^^i2 ##unbox-c-ptr ;
+: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
+: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
+: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
+: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
+: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
+: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-3 ; inline
+: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
+: ^^alien-float ( src -- dst ) ^^i1 ##alien-float ; inline
+: ^^alien-double ( src -- dst ) ^^i1 ##alien-double ; inline
diff --git a/basis/compiler/cfg/stacks/authors.txt b/basis/compiler/cfg/builder/stacks/authors.txt
similarity index 100%
rename from basis/compiler/cfg/stacks/authors.txt
rename to basis/compiler/cfg/builder/stacks/authors.txt
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/builder/stacks/stacks.factor
similarity index 52%
rename from basis/compiler/cfg/stacks/stacks.factor
rename to basis/compiler/cfg/builder/stacks/stacks.factor
index 8d0537c64d..e1119e18d6 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/builder/stacks/stacks.factor
@@ -3,9 +3,11 @@
 USING: arrays assocs classes classes.private classes.algebra
 combinators hashtables kernel layouts math fry namespaces
 quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order cpu.architecture
-compiler.cfg.instructions compiler.cfg.registers ;
-IN: compiler.cfg.stacks
+byte-arrays accessors sets math.order
+combinators.short-circuit cpu.architecture
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.builder.hats ;
+IN: compiler.cfg.builder.stacks
 
 ! Converting stack operations into register operations, while
 ! doing a bit of optimization along the way.
@@ -13,75 +15,6 @@ PREDICATE: small-slot < integer cells small-enough? ;
 
 PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
 
-! Value protocol
-GENERIC: move-spec ( obj -- spec )
-GENERIC: live-loc? ( actual current -- ? )
-GENERIC: lazy-store ( dst src -- )
-
-! This will be a multimethod soon
-DEFER: ##move
-
-PRIVATE>
-
-! Default implementation
-M: value live-loc? 2drop f ;
-M: value lazy-store 2drop ;
-
-M: vreg move-spec reg-class>> move-spec ;
-M: vreg value-class* reg-class>> value-class* ;
-
-M: int-regs move-spec drop f ;
-M: int-regs value-class* drop object ;
-
-M: float-regs move-spec drop float ;
-M: float-regs value-class* drop float ;
-
-M: ds-loc live-loc?
-    over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-M: rs-loc live-loc?
-    over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-M: loc value-class* class>> ;
-M: loc set-value-class (>>class) ;
-M: loc move-spec drop loc ;
-
-M: f move-spec drop loc ;
-M: f value-class* ;
-
-M: tagged move-spec drop f ;
-
-M: unboxed-alien move-spec class ;
-
-M: unboxed-byte-array move-spec class ;
-
-M: unboxed-f move-spec class ;
-
-M: unboxed-c-ptr move-spec class ;
-
-M: constant move-spec class ;
-
-! Moving values between locations and registers
-: ##move-bug ( -- * ) "Bug in compiler.cfg.stacks" throw ;
-
-: ##unbox-c-ptr ( dst src -- )
-    dup value-class {
-        { [ dup \ f class<= ] [ drop [ >vreg ] bi@ ##unbox-f ] }
-        { [ dup simple-alien class<= ] [ drop [ >vreg ] bi@ ##unbox-alien ] }
-        { [ dup byte-array class<= ] [ drop [ >vreg ] bi@ ##unbox-byte-array ] }
-        [ drop [ >vreg ] bi@ ##unbox-any-c-ptr ]
-    } cond ; inline
-
-: ##move-via-temp ( dst src -- )
-    #! For many transfers, such as loc to unboxed-alien, we
-    #! don't have an intrinsic, so we transfer the source to
-    #! temp then temp to the destination.
-    int-regs next-vreg [ over ##move value-class ] keep
-    tagged new
-        swap >>vreg
-        swap >>class
-    ##move ;
-
 ! Operands holding pointers to freshly-allocated objects which
 ! are guaranteed to be in the nursery
 SYMBOL: fresh-objects
@@ -90,34 +23,6 @@ SYMBOL: fresh-objects
 
 : fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
 
-: ##move ( dst src -- )
-    2dup [ move-spec ] bi@ 2array {
-        { { f f } [ [ >vreg ] bi@ ##copy ] }
-        { { unboxed-alien unboxed-alien } [ [ >vreg ] bi@ ##copy ] }
-        { { unboxed-byte-array unboxed-byte-array } [ [ >vreg ] bi@ ##copy ] }
-        { { unboxed-f unboxed-f } [ [ >vreg ] bi@ ##copy ] }
-        { { unboxed-c-ptr unboxed-c-ptr } [ [ >vreg ] bi@ ##copy ] }
-        { { float float } [ [ >vreg ] bi@ ##copy-float ] }
-
-        { { f unboxed-c-ptr } [ ##move-bug ] }
-        { { f unboxed-byte-array } [ ##move-bug ] }
-
-        { { f constant } [ [ >vreg ] [ value>> ] bi* ##load-literal ] }
-
-        { { f float } [ [ >vreg ] bi@ int-regs next-vreg ##box-float t fresh-object ] }
-        { { f unboxed-alien } [ [ >vreg ] bi@ int-regs next-vreg ##box-alien t fresh-object ] }
-        { { f loc } [ [ >vreg ] dip ##peek ] }
-
-        { { float f } [ [ >vreg ] bi@ ##unbox-float ] }
-        { { unboxed-alien f } [ [ >vreg ] bi@ ##unbox-alien ] }
-        { { unboxed-byte-array f } [ [ >vreg ] bi@ ##unbox-byte-array ] }
-        { { unboxed-f f } [ [ >vreg ] bi@ ##unbox-f ] }
-        { { unboxed-c-ptr f } [ ##unbox-c-ptr ] }
-        { { loc f } [ >vreg swap ##replace ] }
-
-        [ drop ##move-via-temp ]
-    } case ;
-
 ! A compile-time stack
 TUPLE: phantom-stack height stack ;
 
@@ -204,42 +109,13 @@ M: phantom-retainstack finalize-height
 
 : finalize-heights ( -- ) [ finalize-height ] each-phantom ;
 
-: reg-spec>class ( spec -- class )
-    float eq? double-float-regs int-regs ? ;
+GENERIC: lazy-load ( loc/vreg -- vreg )
+M: loc lazy-load ^^peek ;
+M: vreg lazy-load ;
 
-: alloc-vreg ( spec -- reg )
-    [ reg-spec>class next-vreg ] keep {
-        { f [ <tagged> ] }
-        { unboxed-alien [ <unboxed-alien> ] }
-        { unboxed-byte-array [ <unboxed-byte-array> ] }
-        { unboxed-f [ <unboxed-f> ] }
-        { unboxed-c-ptr [ <unboxed-c-ptr> ] }
-        [ drop ]
-    } case ;
-
-: alloc-vreg-for ( value spec -- vreg )
-    alloc-vreg swap value-class
-    over tagged? [ >>class ] [ drop ] if ;
-
-: (eager-load) ( value spec -- vreg )
-    [ alloc-vreg-for ] [ drop ] 2bi
-    [ ##move ] [ drop >vreg ] 2bi ;
-
-: compatible? ( value spec -- ? )
-    >r move-spec r> {
-        { [ 2dup = ] [ t ] }
-        { [ dup unboxed-c-ptr eq? ] [
-            over { unboxed-byte-array unboxed-alien } member?
-        ] }
-        [ f ]
-    } cond 2nip ;
-
-: (lazy-load) ( value spec -- value )
-    {
-        { [ dup { small-slot small-tagged } memq? ] [ drop >vreg ] }
-        { [ 2dup compatible? ] [ drop >vreg ] }
-        [ (eager-load) ]
-    } cond ;
+GENERIC: live-loc? ( actual current -- ? )
+M: vreg live-loc? 2drop f ;
+M: loc live-loc? { [ [ class ] bi@ = ] [ [ n>> ] bi@ = not ] } 2&& ;
 
 : (live-locs) ( phantom -- seq )
     #! Discard locs which haven't moved
@@ -250,19 +126,26 @@ M: phantom-retainstack finalize-height
 : live-locs ( -- seq )
     [ (live-locs) ] each-phantom append prune ;
 
+GENERIC: lazy-store ( dst src -- )
+
+M: vreg lazy-store 2drop ;
+
 M: loc lazy-store
-    2dup live-loc? [ "live-locs" get at ##move ] [ 2drop ] if ;
+    2dup live-loc? [
+        \ live-locs get at swap ##replace
+    ] [ 2drop ] if ;
 
 : finalize-locs ( -- )
     #! Perform any deferred stack shuffling.
-    live-locs [ dup f (lazy-load) ] H{ } map>assoc
+    live-locs [ dup lazy-load ] H{ } map>assoc
     dup assoc-empty? [ drop ] [
-        "live-locs" set [ lazy-store ] each-loc
+        \ live-locs set
+        [ lazy-store ] each-loc
     ] if ;
 
 : finalize-vregs ( -- )
     #! Store any vregs to their final stack locations.
-    [ dup loc? [ 2drop ] [ ##move ] if ] each-loc ;
+    [ dup loc? [ 2drop ] [ swap ##replace ] if ] each-loc ;
 
 : clear-phantoms ( -- )
     [ stack>> delete-all ] each-phantom ;
@@ -271,11 +154,6 @@ M: loc lazy-store
     finalize-locs finalize-vregs clear-phantoms ;
 
 ! Loading stacks to vregs
-: set-value-classes ( classes -- )
-    phantom-datastack get
-    over length over add-locs
-    stack>> [ set-value-class ] 2reverse-each ;
-
 : finalize-phantoms ( -- )
     #! Commit all deferred stacking shuffling, and ensure the
     #! in-memory data and retain stacks are up to date with
@@ -318,5 +196,14 @@ M: loc lazy-store
 : phantom-rdrop ( n -- )
     phantom-retainstack get phantom-input drop ;
 
+: phantom-load ( n -- vreg )
+    phantom-datastack get phantom-input [ lazy-load ] map ;
+
 : phantom-pop ( -- vreg )
-    1 phantom-datastack get phantom-input first f (lazy-load) ;
+    1 phantom-load first ;
+
+: 2phantom-pop ( -- vreg1 vreg2 )
+    2 phantom-load first2 ;
+
+: 3phantom-pop ( -- vreg1 vreg2 vreg3 )
+    3 phantom-load first3 ;
diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 6665564c91..294238fbbf 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words sequences quotations namespaces io
-accessors prettyprint prettyprint.config
+classes.tuple accessors prettyprint prettyprint.config
 compiler.tree.builder compiler.tree.optimizer
 compiler.cfg.builder compiler.cfg.linearization
 compiler.cfg.stack-frame compiler.cfg.linear-scan ;
@@ -15,16 +15,25 @@ M: callable test-cfg
 M: word test-cfg
     [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
 
+SYMBOL: allocate-registers?
+
 : test-mr ( quot -- mrs )
-    test-cfg [ build-mr linear-scan build-stack-frame ] map ;
+    test-cfg [
+        build-mr
+        allocate-registers? get
+        [ linear-scan build-stack-frame ] when
+    ] map ;
+
+: insn. ( insn -- )
+    tuple>array allocate-registers? get [ but-last ] unless
+    [ pprint bl ] each nl ;
 
 : mr. ( mrs -- )
     [
-        boa-tuples? on
         "=== word: " write
         dup word>> pprint
         ", label: " write
         dup label>> pprint nl nl
-        instructions>> .
+        instructions>> [ insn. ] each
         nl
     ] each ;
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
new file mode 100644
index 0000000000..93232579de
--- /dev/null
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel compiler.cfg.instructions
+compiler.cfg.instructions.syntax ;
+IN: compiler.cfg.def-use
+
+GENERIC: defs-vregs ( insn -- seq )
+GENERIC: uses-vregs ( insn -- seq )
+
+: allot-defs-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
+M: ##flushable defs-vregs dst>> 1array ;
+M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
+M: ##boxer defs-vregs allot-defs-vregs ;
+M: ##allot defs-vregs allot-defs-vregs ;
+M: ##dispatch defs-vregs temp>> 1array ;
+M: insn defs-vregs drop f ;
+
+M: ##unary uses-vregs src>> 1array ;
+M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: ##binary-imm uses-vregs src1>> 1array ;
+M: ##effect uses-vregs src>> 1array ;
+M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
+M: ##slot-imm uses-vregs obj>> 1array ;
+M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
+M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
+M: ##binary-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: ##binary-imm-branch uses-vregs src1>> 1array ;
+M: ##dispatch uses-vregs src>> 1array ;
+M: _binary-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: _binary-imm-branch uses-vregs src1>> 1array ;
+M: insn uses-vregs drop f ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 689650f0a4..368460b920 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -1,19 +1,49 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces words
-math compiler.cfg.registers compiler.cfg.instructions.syntax ;
+math math.order layouts classes.algebra alien byte-arrays
+combinators compiler.cfg.registers
+compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
 ! Virtual CPU instructions, used by CFG and machine IRs
 
-TUPLE: ##cond-branch < insn { src vreg } ;
-TUPLE: ##unary < insn { dst vreg } { src vreg } ;
-TUPLE: ##nullary < insn { dst vreg } ;
+! Instruction with no side effects; if 'out' is never read, we
+! can eliminate it.
+TUPLE: ##flushable < insn { dst vreg } ;
+
+! Instruction which is referentially transparent; we can replace
+! repeated computation with a reference to a previous value
+TUPLE: ##pure < ##flushable ;
+
+TUPLE: ##unary < ##pure { src vreg } ;
+TUPLE: ##boxer < ##unary { temp vreg } ;
+TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ;
+TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ;
+TUPLE: ##commutative < ##binary ;
+
+! Instruction only used for its side effect, produces no values
+TUPLE: ##effect < insn { src vreg } ;
+
+! Read/write ops: candidates for alias analysis
+TUPLE: ##read < ##flushable ;
+TUPLE: ##write < ##effect ;
+
+TUPLE: ##alien-getter < ##read { src vreg } ;
+TUPLE: ##alien-setter < ##effect { value vreg } ;
 
 ! Stack operations
-INSN: ##load-literal < ##nullary obj ;
-INSN: ##peek < ##nullary { loc loc } ;
-INSN: ##replace { src vreg } { loc loc } ;
+INSN: ##load-immediate < ##pure { val integer } ;
+INSN: ##load-indirect < ##pure obj ;
+
+GENERIC: ##load-literal ( dst value -- )
+
+M: fixnum ##load-literal tag-fixnum ##load-immediate ;
+M: f ##load-literal drop \ f tag-number ##load-immediate ;
+M: object ##load-literal ##load-indirect ;
+
+INSN: ##peek < ##read { loc loc } ;
+INSN: ##replace < ##write { loc loc } ;
 INSN: ##inc-d { n integer } ;
 INSN: ##inc-r { n integer } ;
 
@@ -30,12 +60,48 @@ INSN: ##call word ;
 INSN: ##jump word ;
 INSN: ##return ;
 
-INSN: ##intrinsic quot defs-vregs uses-vregs ;
-
 ! Jump tables
 INSN: ##dispatch src temp ;
 INSN: ##dispatch-label label ;
 
+! Slot access
+INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } ;
+INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
+INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } ;
+INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
+
+! Integer arithmetic
+INSN: ##add < ##commutative ;
+INSN: ##add-imm < ##binary-imm ;
+INSN: ##sub < ##binary ;
+INSN: ##sub-imm < ##binary-imm ;
+INSN: ##mul < ##commutative ;
+INSN: ##mul-imm < ##binary-imm ;
+INSN: ##and < ##commutative ;
+INSN: ##and-imm < ##binary-imm ;
+INSN: ##or < ##commutative ;
+INSN: ##or-imm < ##binary-imm ;
+INSN: ##xor < ##commutative ;
+INSN: ##xor-imm < ##binary-imm ;
+INSN: ##shl-imm < ##binary-imm ;
+INSN: ##shr-imm < ##binary-imm ;
+INSN: ##sar-imm < ##binary-imm ;
+INSN: ##not < ##unary ;
+
+! Bignum/integer conversion
+INSN: ##integer>bignum < ##boxer ;
+INSN: ##bignum>integer < ##unary ;
+
+! Float arithmetic
+INSN: ##add-float < ##commutative ;
+INSN: ##sub-float < ##binary ;
+INSN: ##mul-float < ##commutative ;
+INSN: ##div-float < ##binary ;
+
+! Float/integer conversion
+INSN: ##float>integer < ##unary ;
+INSN: ##integer>float < ##unary ;
+
 ! Boxing and unboxing
 INSN: ##copy < ##unary ;
 INSN: ##copy-float < ##unary ;
@@ -44,12 +110,38 @@ INSN: ##unbox-f < ##unary ;
 INSN: ##unbox-alien < ##unary ;
 INSN: ##unbox-byte-array < ##unary ;
 INSN: ##unbox-any-c-ptr < ##unary ;
-INSN: ##box-float < ##unary { temp vreg } ;
-INSN: ##box-alien < ##unary { temp vreg } ;
+INSN: ##box-float < ##boxer ;
+INSN: ##box-alien < ##boxer ;
+
+: ##unbox-c-ptr ( dst src class -- )
+    {
+        { [ dup \ f class<= ] [ drop ##unbox-f ] }
+        { [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
+        { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
+        [ drop ##unbox-any-c-ptr ]
+    } cond ; inline
+
+! Alien accessors
+INSN: ##alien-unsigned-1 < ##alien-getter ;
+INSN: ##alien-unsigned-2 < ##alien-getter ;
+INSN: ##alien-unsigned-4 < ##alien-getter ;
+INSN: ##alien-signed-1 < ##alien-getter ;
+INSN: ##alien-signed-2 < ##alien-getter ;
+INSN: ##alien-signed-3 < ##alien-getter ;
+INSN: ##alien-cell < ##alien-getter ;
+INSN: ##alien-float < ##alien-getter ;
+INSN: ##alien-double < ##alien-getter ;
+
+INSN: ##set-alien-integer-1 < ##alien-setter ;
+INSN: ##set-alien-integer-2 < ##alien-setter ;
+INSN: ##set-alien-integer-4 < ##alien-setter ;
+INSN: ##set-alien-cell < ##alien-getter ;
+INSN: ##set-alien-float < ##alien-setter ;
+INSN: ##set-alien-double < ##alien-setter ;
 
 ! Memory allocation
-INSN: ##allot < ##nullary size type tag { temp vreg } ;
-INSN: ##write-barrier { src vreg } card# table ;
+INSN: ##allot < ##flushable size type tag { temp vreg } ;
+INSN: ##write-barrier < ##effect card# table ;
 INSN: ##gc ;
 
 ! FFI
@@ -58,54 +150,35 @@ INSN: ##alien-indirect params ;
 INSN: ##alien-callback params ;
 INSN: ##callback-return params ;
 
-GENERIC: defs-vregs ( insn -- seq )
-GENERIC: uses-vregs ( insn -- seq )
-
-M: ##nullary defs-vregs dst>> 1array ;
-M: ##unary defs-vregs dst>> 1array ;
-M: ##write-barrier defs-vregs
-    [ card#>> ] [ table>> ] bi 2array ;
-
-: allot-defs-vregs ( insn -- seq )
-    [ dst>> ] [ temp>> ] bi 2array ;
-
-M: ##box-float defs-vregs allot-defs-vregs ;
-M: ##box-alien defs-vregs allot-defs-vregs ;
-M: ##allot defs-vregs allot-defs-vregs ;
-M: ##dispatch defs-vregs temp>> 1array ;
-M: insn defs-vregs drop f ;
-
-M: ##replace uses-vregs src>> 1array ;
-M: ##unary uses-vregs src>> 1array ;
-M: ##write-barrier uses-vregs src>> 1array ;
-M: ##dispatch uses-vregs src>> 1array ;
-M: insn uses-vregs drop f ;
-
-: intrinsic-vregs ( assoc -- seq' )
-    [ nip dup vreg? swap and ] { } assoc>map sift ;
-
-: intrinsic-defs-vregs ( insn -- seq )
-    defs-vregs>> intrinsic-vregs ;
-
-: intrinsic-uses-vregs ( insn -- seq )
-    uses-vregs>> intrinsic-vregs ;
-
-M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
-M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
-
 ! Instructions used by CFG IR only.
 INSN: ##prologue ;
 INSN: ##epilogue ;
 
 INSN: ##branch ;
-INSN: ##branch-f < ##cond-branch ;
-INSN: ##branch-t < ##cond-branch ;
-INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
 
-M: ##cond-branch uses-vregs src>> 1array ;
+! Condition codes
+SYMBOL: cc<
+SYMBOL: cc<=
+SYMBOL: cc=
+SYMBOL: cc>
+SYMBOL: cc>=
+SYMBOL: cc/=
 
-M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
-M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
+: evaluate-cc ( result cc -- ? )
+    H{
+        { cc<  { +lt+           } }
+        { cc<= { +lt+ +eq+      } }
+        { cc=  {      +eq+      } }
+        { cc>= {      +eq+ +gt+ } }
+        { cc>  {           +gt+ } }
+        { cc/= { +lt+      +gt+ } }
+    } at memq? ;
+
+INSN: ##binary-branch { src1 vreg } { src2 vreg } cc ;
+INSN: ##binary-imm-branch { src1 vreg } { src2 integer } cc ;
+
+INSN: ##boolean < ##binary cc ;
+INSN: ##boolean-imm < ##binary-imm cc ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;
@@ -113,17 +186,10 @@ INSN: _epilogue stack-frame ;
 
 INSN: _label id ;
 
-TUPLE: _cond-branch < insn { src vreg } label ;
-
 INSN: _branch label ;
-INSN: _branch-f < _cond-branch ;
-INSN: _branch-t < _cond-branch ;
-INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
 
-M: _cond-branch uses-vregs src>> 1array ;
-
-M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
-M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
+INSN: _binary-branch label { src1 vreg } { src2 vreg } cc ;
+INSN: _binary-imm-branch label { src1 vreg } { src2 integer } cc ;
 
 ! These instructions operate on machine registers and not
 ! virtual registers
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 876bb6ba6c..2d8ad8c214 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -3,6 +3,7 @@
 USING: accessors kernel math assocs namespaces sequences heaps
 fry make combinators
 cpu.architecture
+compiler.cfg.def-use
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.linear-scan.live-intervals ;
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 3ab7e03783..54cead850c 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel assocs accessors sequences math fry
-compiler.cfg.instructions compiler.cfg.registers ;
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.def-use ;
 IN: compiler.cfg.linear-scan.live-intervals
 
 TUPLE: live-interval
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 24730cd17f..c8e4b734d8 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -40,21 +40,14 @@ M: ##branch linearize-insn
 : conditional ( basic-block -- basic-block successor1 label2 )
     dup successors>> first2 swap number>> ; inline
 
-: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
-    [ conditional ] [ src>> ] bi* swap ; inline
+: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
+    [ conditional ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
 
-M: ##branch-f linearize-insn
-    boolean-conditional _branch-f emit-branch ;
+M: ##binary-branch linearize-insn
+    binary-conditional _binary-branch emit-branch ;
 
-M: ##branch-t linearize-insn
-    boolean-conditional _branch-t emit-branch ;
-
-: >intrinsic< ( insn -- quot defs uses )
-    [ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
-
-M: ##if-intrinsic linearize-insn
-    [ conditional ] [ >intrinsic< ] bi*
-    _if-intrinsic emit-branch ;
+M: ##binary-imm-branch linearize-insn
+    binary-conditional _binary-imm-branch emit-branch ;
 
 : linearize-basic-block ( bb -- )
     [ number>> _label ] [ linearize-insns ] bi ;
diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor
index 64712297e2..f9fd4521f7 100644
--- a/basis/compiler/cfg/registers/registers.factor
+++ b/basis/compiler/cfg/registers/registers.factor
@@ -1,91 +1,37 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces math kernel alien classes ;
+USING: accessors namespaces kernel arrays
+parser prettyprint.backend prettyprint.sections ;
 IN: compiler.cfg.registers
 
-! Virtual CPU registers, used by CFG and machine IRs
-
-MIXIN: value
-
-GENERIC: >vreg ( obj -- vreg )
-GENERIC: set-value-class ( class obj -- )
-GENERIC: value-class* ( operand -- class )
-
-: value-class ( operand -- class ) value-class* object or ;
-
-M: value set-value-class 2drop ;
-M: value value-class* drop f ;
-
-! Virtual registers
+! Virtual registers, used by CFG and machine IRs
 TUPLE: vreg reg-class n ;
 SYMBOL: vreg-counter
 : next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
 
-M: vreg >vreg ;
-
-INSTANCE: vreg value
-
 ! Stack locations
-TUPLE: loc n class ;
+TUPLE: loc n ;
 
-M: loc >vreg drop f ;
-
-! A data stack location.
 TUPLE: ds-loc < loc ;
-: <ds-loc> ( n -- loc ) f ds-loc boa ;
+C: <ds-loc> ds-loc
 
 TUPLE: rs-loc < loc ;
-: <rs-loc> ( n -- loc ) f rs-loc boa ;
+C: <rs-loc> ds-loc
 
-INSTANCE: loc value
+! Prettyprinting
+: V scan-word scan-word vreg boa parsed ; parsing
 
-! A tagged pointer
-TUPLE: tagged vreg class ;
-: <tagged> ( vreg -- tagged ) f tagged boa ;
+M: vreg pprint*
+    <block
+    \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
+    block> ;
 
-M: tagged set-value-class (>>class) ;
-M: tagged value-class* class>> ;
-M: tagged >vreg vreg>> ;
+: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
 
-INSTANCE: tagged value
+: D scan-word <ds-loc> parsed ; parsing
 
-! Unboxed value
-TUPLE: unboxed vreg ;
-C: <unboxed> unboxed
+M: ds-loc pprint* \ D pprint-loc ;
 
-M: unboxed >vreg vreg>> ;
+: R scan-word <rs-loc> parsed ; parsing
 
-INSTANCE: unboxed value
-
-! Unboxed alien pointer
-TUPLE: unboxed-alien < unboxed ;
-C: <unboxed-alien> unboxed-alien
-
-M: unboxed-alien value-class* drop simple-alien ;
-
-! Untagged byte array pointer
-TUPLE: unboxed-byte-array < unboxed ;
-C: <unboxed-byte-array> unboxed-byte-array
-
-M: unboxed-byte-array value-class* drop c-ptr ;
-
-! A register set to f
-TUPLE: unboxed-f < unboxed ;
-C: <unboxed-f> unboxed-f
-
-M: unboxed-f value-class* drop \ f ;
-
-! An alien, byte array or f
-TUPLE: unboxed-c-ptr < unboxed ;
-C: <unboxed-c-ptr> unboxed-c-ptr
-
-M: unboxed-c-ptr value-class* drop c-ptr ;
-
-! A constant value
-TUPLE: constant value ;
-C: <constant> constant
-
-M: constant value-class* value>> class ;
-M: constant >vreg ;
-
-INSTANCE: constant value
+M: rs-loc pprint* \ R pprint-loc ;
diff --git a/basis/compiler/cfg/templates/templates.factor b/basis/compiler/cfg/templates/templates.factor
deleted file mode 100644
index 289c420f8f..0000000000
--- a/basis/compiler/cfg/templates/templates.factor
+++ /dev/null
@@ -1,86 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs accessors sequences kernel fry namespaces
-quotations combinators classes.algebra compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.stacks ;
-IN: compiler.cfg.templates
-
-TUPLE: template input output scratch clobber gc ;
-
-: live-vregs ( -- seq )
-    [ stack>> [ >vreg ] map sift ] each-phantom append ;
-
-: clobbered ( template -- seq )
-    [ output>> ] [ clobber>> ] bi append ;
-
-: clobbered? ( value name -- ? )
-    \ clobbered get member? [
-        >vreg \ live-vregs get member?
-    ] [ drop f ] if ;
-
-: lazy-load ( specs -- seq )
-    [ length phantom-datastack get phantom-input ] keep
-    [
-        2dup second clobbered?
-        [ first (eager-load) ] [ first (lazy-load) ] if
-    ] 2map ;
-
-: load-inputs ( template -- assoc )
-    [
-        live-vregs \ live-vregs set
-        dup clobbered \ clobbered set
-        input>> [ values ] [ lazy-load ] bi zip
-    ] with-scope ;
-
-: alloc-scratch ( template -- assoc )
-    scratch>> [ swap alloc-vreg ] assoc-map ;
-
-: do-template-inputs ( template -- defs uses )
-    #! Load input values into registers and allocates scratch
-    #! registers.
-    [ alloc-scratch ] [ load-inputs ] bi ;
-
-: do-template-outputs ( template defs uses -- )
-    [ output>> ] 2dip assoc-union '[ _ at ] map
-    phantom-datastack get phantom-append ;
-
-: apply-template ( pair quot -- )
-    [
-        first2
-        dup gc>> [ t fresh-object ] when
-        dup do-template-inputs
-        [ do-template-outputs ]
-        [ [ [ >vreg ] assoc-map ] dip ] 2bi
-    ] dip call ; inline
-
-: phantom&spec ( phantom specs -- phantom' specs' )
-    >r stack>> r>
-    [ length f pad-left ] keep
-    [ <reversed> ] bi@ ; inline
-
-: value-matches? ( value spec -- ? )
-    #! If the spec is a quotation and the value is a literal
-    #! fixnum, see if the quotation yields true when applied
-    #! to the fixnum. Otherwise, the values don't match. If the
-    #! spec is not a quotation, its a reg-class, in which case
-    #! the value is always good.
-    {
-        { [ dup small-slot eq? ] [ drop dup constant? [ value>> small-slot? ] [ drop f ] if ] }
-        { [ dup small-tagged eq? ] [ drop dup constant? [ value>> small-tagged? ] [ drop f ] if ] }
-        [ 2drop t ]
-    } cond ;
-
-: class-matches? ( actual expected -- ? )
-    dup [ class<= ] [ 2drop t ] if ;
-
-: spec-matches? ( value spec -- ? )
-    2dup first value-matches?
-    >r >r value-class 2 r> ?nth class-matches? r> and ;
-
-: template-matches? ( template -- ? )
-    input>> phantom-datastack get swap phantom&spec
-    [ spec-matches? ] 2all? ;
-
-: find-template ( templates -- pair/f )
-    #! Pair has shape { quot assoc }
-    [ second template-matches? ] find nip ;
diff --git a/basis/compiler/cfg/value-numbering/liveness/liveness.factor b/basis/compiler/cfg/value-numbering/liveness/liveness.factor
index c445c0835d..127a584091 100644
--- a/basis/compiler/cfg/value-numbering/liveness/liveness.factor
+++ b/basis/compiler/cfg/value-numbering/liveness/liveness.factor
@@ -30,7 +30,7 @@ M: load-literal-expr live-expr in>> live-vn ;
 GENERIC: eliminate ( insn -- insn/f )
 
 : (eliminate) ( insn -- insn/f )
-    dup dst>> >vreg live? [ drop f ] unless ;
+    dup dst>> live? [ drop f ] unless ;
 
 M: ##peek eliminate (eliminate) ;
 M: ##unary eliminate (eliminate) ;
diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
index 758d3f95e6..4bca1714ca 100644
--- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor
+++ b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
@@ -9,11 +9,11 @@ IN: compiler.cfg.value-numbering.propagate
 
 GENERIC: propogate ( insn -- insn )
 
-M: ##cond-branch propagate [ resolve ] change-src ;
+M: ##unary-branch propagate [ resolve ] change-src ;
 
 M: ##unary propogate [ resolve ] change-src ;
 
-M: ##nullary propagate ;
+M: ##flushable propagate ;
 
 M: ##replace propagate [ resolve ] change-src ;
 
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index 81e8c40afd..a2957e59f8 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -6,9 +6,9 @@ IN: compiler.cfg.value-numbering
 
 GENERIC: make-value-node ( insn -- )
 
-M: ##cond-branch make-value-node src>> live-vreg ;
+M: ##unary-branch make-value-node src>> live-vreg ;
 M: ##unary make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
-M: ##nullary make-value-node drop ;
+M: ##flushable make-value-node drop ;
 M: ##load-literal make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
 M: ##peek make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
 M: ##replace make-value-node reset-value-graph ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 6c83c38355..3f88873e6e 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -4,26 +4,21 @@ USING: namespaces make math math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
 combinators classes.algebra alien alien.c-types alien.structs
 alien.strings alien.arrays sets threads libc continuations.private
-cpu.architecture
+fry cpu.architecture
 compiler.errors
 compiler.alien
-compiler.codegen.fixup
 compiler.cfg
 compiler.cfg.instructions
 compiler.cfg.registers
-compiler.cfg.builder ;
+compiler.cfg.builder
+compiler.codegen.fixup ;
 IN: compiler.codegen
 
 GENERIC: generate-insn ( insn -- )
 
-GENERIC: v>operand ( obj -- operand )
-
 SYMBOL: registers
 
-M: constant v>operand
-    value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
-
-M: value v>operand
+: register ( vreg -- operand )
     registers get at [ "Bad value" throw ] unless* ;
 
 : generate-insns ( insns -- code )
@@ -68,124 +63,142 @@ SYMBOL: labels
 : lookup-label ( id -- label )
     labels get [ drop <label> ] cache ;
 
-M: _label generate-insn
-    id>> lookup-label , ;
+M: ##load-immediate generate-insn
+    [ dst>> register ] [ obj>> ] bi %load-immediate ;
 
-M: _prologue generate-insn
-    stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
-
-M: _epilogue generate-insn
-    stack-frame>> total-size>> %epilogue ;
-
-M: ##load-literal generate-insn
-    [ obj>> ] [ dst>> v>operand ] bi load-literal ;
+M: ##load-indirect generate-insn
+    [ dst>> register ] [ obj>> ] bi %load-indirect ;
 
 M: ##peek generate-insn
-    [ dst>> v>operand ] [ loc>> ] bi %peek ;
+    [ dst>> register ] [ loc>> ] bi %peek ;
 
 M: ##replace generate-insn
-    [ src>> v>operand ] [ loc>> ] bi %replace ;
+    [ src>> register ] [ loc>> ] bi %replace ;
 
 M: ##inc-d generate-insn n>> %inc-d ;
 
 M: ##inc-r generate-insn n>> %inc-r ;
 
-M: ##return generate-insn drop %return ;
-
 M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
 
 M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
 
-SYMBOL: operands
-
-: init-intrinsic ( insn -- )
-    [ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
-
-M: ##intrinsic generate-insn
-    [ init-intrinsic ] [ quot>> call ] bi ;
-
-: (operand) ( name -- operand )
-    operands get at* [ "Bad operand name" throw ] unless ;
-
-: literal ( name -- value )
-    (operand) value>> ;
-
-: operand ( name -- operand )
-    (operand) v>operand ;
-
-: operand-class ( var -- class )
-    (operand) value-class ;
-
-: operand-tag ( operand -- tag/f )
-    operand-class dup [ class-tag ] when ;
-
-: operand-immediate? ( operand -- ? )
-    operand-class immediate class<= ;
-
-: unique-operands ( operands quot -- )
-    >r [ operand ] map prune r> each ; inline
-
-M: _if-intrinsic generate-insn
-    [ init-intrinsic ]
-    [ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
-
-M: _branch generate-insn
-    label>> lookup-label %jump-label ;
-
-M: _branch-f generate-insn
-    [ label>> lookup-label ] [ src>> v>operand ] bi %jump-f ;
-
-M: _branch-t generate-insn
-    [ label>> lookup-label ] [ src>> v>operand ] bi %jump-t ;
+M: ##return generate-insn drop %return ;
 
 M: ##dispatch-label generate-insn label>> %dispatch-label ;
 
 M: ##dispatch generate-insn
-    [ src>> v>operand ] [ temp>> v>operand ] bi %dispatch ;
+    [ src>> register ] [ temp>> register ] bi %dispatch ;
+
+: >slot<
+    {
+        [ dst>> register ]
+        [ obj>> register ]
+        [ slot>> dup vreg? [ register ] when ]
+        [ tag>> ]
+    } cleave ; inline
+
+M: ##slot generate-insn >slot< %slot ;
+
+M: ##slot-imm generate-insn >slot< %slot-imm ;
+
+: >set-slot<
+    {
+        [ src>> register ]
+        [ obj>> register ]
+        [ slot>> dup vreg? [ register ] when ]
+        [ tag>> ]
+    } cleave ; inline
+
+M: ##set-slot generate-insn >set-slot< %set-slot ;
+
+M: ##set-slot-imm generate-insn >set-slot< %set-slot-imm ;
 
 : dst/src ( insn -- dst src )
-    [ dst>> v>operand ] [ src>> v>operand ] bi ;
+    [ dst>> register ] [ src>> register ] bi ; inline
 
-M: ##copy generate-insn dst/src %copy ;
+: dst/src1/src2 ( insn -- dst src1 src2 )
+    [ dst>> register ] [ src1>> register ] [ src2>> register ] tri ; inline
 
-M: ##copy-float generate-insn dst/src %copy-float ;
-
-M: ##unbox-float generate-insn dst/src %unbox-float ;
-
-M: ##unbox-f generate-insn dst/src %unbox-f ;
-
-M: ##unbox-alien generate-insn dst/src %unbox-alien ;
-
-M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
-
-M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
+M: ##add     generate-insn dst/src1/src2 %add     ;
+M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
+M: ##sub     generate-insn dst/src1/src2 %sub     ;
+M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
+M: ##mul     generate-insn dst/src1/src2 %mul     ;
+M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
+M: ##and     generate-insn dst/src1/src2 %and     ;
+M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
+M: ##or      generate-insn dst/src1/src2 %or      ;
+M: ##or-imm  generate-insn dst/src1/src2 %or-imm  ;
+M: ##xor     generate-insn dst/src1/src2 %xor     ;
+M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
+M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
+M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
+M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
+M: ##not     generate-insn dst/src       %not     ;
 
 : dst/src/temp ( insn -- dst src temp )
-    [ dst/src ] [ temp>> v>operand ] bi ;
+    [ dst/src ] [ temp>> register ] bi ; inline
 
-M: ##box-float generate-insn dst/src/temp %box-float ;
+M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
+M: ##bignum>integer generate-insn dst/src %bignum>integer ;
 
-M: ##box-alien generate-insn dst/src/temp %box-alien ;
+M: ##add-float generate-insn dst/src1/src2 %add-float ;
+M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
+M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
+M: ##div-float generate-insn dst/src1/src2 %div-float ;
+
+M: ##integer>float generate-insn dst/src/temp %integer>float ;
+M: ##float>integer generate-insn dst/src %float>integer ;
+
+M: ##copy             generate-insn dst/src %copy             ;
+M: ##copy-float       generate-insn dst/src %copy-float       ;
+M: ##unbox-float      generate-insn dst/src %unbox-float      ;
+M: ##unbox-f          generate-insn dst/src %unbox-f          ;
+M: ##unbox-alien      generate-insn dst/src %unbox-alien      ;
+M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
+M: ##unbox-any-c-ptr  generate-insn dst/src %unbox-any-c-ptr  ;
+M: ##box-float        generate-insn dst/src/temp %box-float   ;
+M: ##box-alien        generate-insn dst/src/temp %box-alien   ;
+
+M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
+M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
+M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
+M: ##alien-signed-1   generate-insn dst/src %alien-signed-1   ;
+M: ##alien-signed-2   generate-insn dst/src %alien-signed-2   ;
+M: ##alien-signed-3   generate-insn dst/src %alien-signed-3   ;
+M: ##alien-cell       generate-insn dst/src %alien-cell       ;
+M: ##alien-float      generate-insn dst/src %alien-float      ;
+M: ##alien-double     generate-insn dst/src %alien-double     ;
+
+: >alien-setter< [ src>> register ] [ value>> register ] bi ;
+
+M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
+M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
+M: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
+M: ##set-alien-cell      generate-insn >alien-setter< %set-alien-cell      ;
+M: ##set-alien-float     generate-insn >alien-setter< %set-alien-float     ;
+M: ##set-alien-double    generate-insn >alien-setter< %set-alien-double    ;
 
 M: ##allot generate-insn
     {
-        [ dst>> v>operand ]
+        [ dst>> register ]
         [ size>> ]
         [ type>> ]
         [ tag>> ]
-        [ temp>> v>operand ]
+        [ temp>> register ]
     } cleave
     %allot ;
 
 M: ##write-barrier generate-insn
-    [ src>> v>operand ]
-    [ card#>> v>operand ]
-    [ table>> v>operand ]
+    [ src>> register ]
+    [ card#>> register ]
+    [ table>> register ]
     tri %write-barrier ;
 
 M: ##gc generate-insn drop %gc ;
 
-! #alien-invoke
+! ##alien-invoke
 GENERIC: reg-size ( register-class -- n )
 
 M: int-regs reg-size drop cell ;
@@ -276,7 +289,7 @@ M: long-long-type flatten-value-type ( type -- types )
     >r
     alien-parameters
     flatten-value-types
-    r> [ >r alloc-parameter r> execute ] curry each-parameter ;
+    r> '[ alloc-parameter _ execute ] each-parameter ;
     inline
 
 : unbox-parameters ( offset node -- )
@@ -331,7 +344,7 @@ M: no-such-symbol compiler-error-type
 
 : check-dlsym ( symbols dll -- )
     dup dll-valid? [
-        dupd [ dlsym ] curry contains?
+        dupd '[ _ dlsym ] contains?
         [ drop ] [ no-such-symbol ] if
     ] [
         dll-path no-such-library drop
@@ -407,7 +420,7 @@ TUPLE: callback-context ;
 : callback-return-quot ( ctype -- quot )
     return>> {
         { [ dup "void" = ] [ drop [ ] ] }
-        { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
+        { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
         [ c-type c-type-unboxer-quot ]
     } cond ;
 
@@ -436,6 +449,32 @@ M: ##alien-callback generate-insn
     [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
     tri ;
 
+M: _prologue generate-insn
+    stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
+
+M: _epilogue generate-insn
+    stack-frame>> total-size>> %epilogue ;
+
+M: _label generate-insn
+    id>> lookup-label , ;
+
+M: _branch generate-insn
+    label>> lookup-label %jump-label ;
+
+: >binary-branch< ( insn -- label src1 src2 cc )
+    {
+        [ label>> lookup-label ]
+        [ src1>> register ]
+        [ src2>> dup vreg? [ register ] when ]
+        [ cc>> ]
+    } cleave ;
+
+M: _binary-branch generate-insn
+    >binary-branch< %binary-branch ;
+
+M: _binary-imm-branch generate-insn
+    >binary-branch< %binary-imm-branch ;
+
 M: _spill generate-insn
     [ src>> ] [ n>> ] [ class>> ] tri {
         { int-regs [ %spill-integer ] }
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index 6e45ab27e9..fe270f4410 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -43,9 +43,10 @@ M: rel-fixup fixup*
 
 M: integer fixup* , ;
 
+: indq ( elt seq -- n ) [ eq? ] with find drop ;
+
 : adjoin* ( obj table -- n )
-    2dup swap [ eq? ] curry find drop
-    [ 2nip ] [ dup length >r push r> ] if* ;
+    2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
 
 SYMBOL: literal-table
 
diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor
index 671171a959..2f413b642a 100644
--- a/basis/compiler/tests/simple.factor
+++ b/basis/compiler/tests/simple.factor
@@ -1,8 +1,10 @@
-USING: compiler.units tools.test kernel kernel.private
-sequences.private math.private math combinators strings
-alien arrays memory vocabs parser eval ;
+USING: compiler compiler.units tools.test kernel kernel.private
+sequences.private math.private math combinators strings alien
+arrays memory vocabs parser eval ;
 IN: compiler.tests
 
+\ (compile) must-infer
+
 ! Test empty word
 [ ] [ [ ] compile-call ] unit-test
 
diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/templates.factor
index 6bcbb8baea..675e0cbc0f 100644
--- a/basis/compiler/tests/templates.factor
+++ b/basis/compiler/tests/templates.factor
@@ -375,3 +375,8 @@ TUPLE: my-tuple ;
 [ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
 
 [ vector ] [ dispatch-alignment-regression ] unit-test
+
+! Regression
+: bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
+
+[ { f f f } ] [ t bad-value-bug ] unit-test
diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor
index 54bc445b25..19d80ec14f 100644
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@@ -7,7 +7,7 @@ stack-checker.backend compiler.tree ;
 IN: compiler.tree.builder
 
 : with-tree-builder ( quot -- nodes )
-    [ V{ } clone stack-visitor set ] prepose
+    '[ V{ } clone stack-visitor set @ ]
     with-infer ; inline
 
 : build-tree ( quot -- nodes )
diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor
index f284a06a88..40bbf81a03 100644
--- a/basis/compiler/tree/combinators/combinators.factor
+++ b/basis/compiler/tree/combinators/combinators.factor
@@ -48,7 +48,7 @@ IN: compiler.tree.combinators
 : sift-children ( seq flags -- seq' )
     zip [ nip ] assoc-filter keys ;
 
-: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
+: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
 
 : 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
 
diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor
index 4d2881af5a..59a028a4f4 100644
--- a/basis/compiler/tree/debugger/debugger.factor
+++ b/basis/compiler/tree/debugger/debugger.factor
@@ -24,7 +24,7 @@ IN: compiler.tree.debugger
 GENERIC: node>quot ( node -- )
 
 MACRO: match-choose ( alist -- )
-    [ [ ] curry ] assoc-map [ match-cond ] curry ;
+    [ '[ _ ] ] assoc-map '[ _ match-cond ] ;
 
 MATCH-VARS: ?a ?b ?c ;
 
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 9f208bdc12..9d26ab2f4a 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -277,7 +277,7 @@ generic-comparison-ops [
         }
     } cond
     [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
-    [ 2nip ] curry "outputs" set-word-prop
+    '[ 2drop _ ] "outputs" set-word-prop
 ] each
 
 { <tuple> <tuple-boa> (tuple) } [
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 2d3f8a8b40..277d83412b 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generic kernel kernel.private math
 memory namespaces make sequences layouts system hashtables
-classes alien byte-arrays combinators words sets ;
+classes alien byte-arrays combinators words sets fry ;
 IN: cpu.architecture
 
 ! Labels
@@ -35,60 +35,96 @@ GENERIC: param-reg ( n register-class -- reg )
 
 M: object param-reg param-regs nth ;
 
-! Sequence mapping vreg-n to native assembler registers
-GENERIC: vregs ( register-class -- regs )
+HOOK: %load-immediate cpu ( reg obj -- )
+HOOK: %load-indirect cpu ( reg obj -- )
 
-! Load a literal (immediate or indirect)
-GENERIC# load-literal 1 ( obj reg -- )
-
-HOOK: load-indirect cpu ( obj reg -- )
-
-HOOK: stack-frame-size cpu ( stack-frame -- n )
-
-! Set up caller stack frame
-HOOK: %prologue cpu ( n -- )
-
-! Tear down stack frame
-HOOK: %epilogue cpu ( n -- )
-
-! Call another word
-HOOK: %call cpu ( word -- )
-
-! Local jump for branches
-HOOK: %jump-label cpu ( label -- )
-
-! Test if vreg is 'f' or not
-HOOK: %jump-f cpu ( label vreg -- )
-
-! Test if vreg is 't' or not
-HOOK: %jump-t cpu ( label vreg -- )
-
-HOOK: %dispatch cpu ( src temp -- )
-
-HOOK: %dispatch-label cpu ( word -- )
-
-! Return to caller
-HOOK: %return cpu ( -- )
-
-! Change datastack height
+HOOK: %peek cpu ( vreg loc -- )
+HOOK: %replace cpu ( vreg loc -- )
 HOOK: %inc-d cpu ( n -- )
-
-! Change callstack height
 HOOK: %inc-r cpu ( n -- )
 
-! Load stack into vreg
-HOOK: %peek cpu ( vreg loc -- )
+HOOK: stack-frame-size cpu ( stack-frame -- n )
+HOOK: %call cpu ( word -- )
+HOOK: %jump-label cpu ( label -- )
+HOOK: %return cpu ( -- )
 
-! Store vreg to stack
-HOOK: %replace cpu ( vreg loc -- )
+HOOK: %dispatch cpu ( src temp -- )
+HOOK: %dispatch-label cpu ( word -- )
+
+HOOK: %slot cpu ( dst obj slot tag -- )
+HOOK: %slot-imm cpu ( dst obj slot tag -- )
+HOOK: %set-slot cpu ( src obj slot tag -- )
+HOOK: %set-slot-imm cpu ( src obj slot tag -- )
+
+HOOK: %add     cpu ( dst src1 src2 -- )
+HOOK: %add-imm cpu ( dst src1 src2 -- )
+HOOK: %sub     cpu ( dst src1 src2 -- )
+HOOK: %sub-imm cpu ( dst src1 src2 -- )
+HOOK: %mul     cpu ( dst src1 src2 -- )
+HOOK: %mul-imm cpu ( dst src1 src2 -- )
+HOOK: %and     cpu ( dst src1 src2 -- )
+HOOK: %and-imm cpu ( dst src1 src2 -- )
+HOOK: %or      cpu ( dst src1 src2 -- )
+HOOK: %or-imm  cpu ( dst src1 src2 -- )
+HOOK: %xor     cpu ( dst src1 src2 -- )
+HOOK: %xor-imm cpu ( dst src1 src2 -- )
+HOOK: %shl-imm cpu ( dst src1 src2 -- )
+HOOK: %shr-imm cpu ( dst src1 src2 -- )
+HOOK: %sar-imm cpu ( dst src1 src2 -- )
+HOOK: %not     cpu ( dst src -- )
+
+HOOK: %integer>bignum cpu ( dst src -- )
+HOOK: %bignum>integer cpu ( dst src -- )
+
+HOOK: %add-float      cpu ( dst src1 src2 -- )
+HOOK: %sub-float      cpu ( dst src1 src2 -- )
+HOOK: %mul-float      cpu ( dst src1 src2 -- )
+HOOK: %div-float      cpu ( dst src1 src2 -- )
+
+HOOK: %integer>float  cpu ( dst src -- )
+HOOK: %float>integer  cpu ( dst src -- )
 
-! Copy values between vregs
 HOOK: %copy cpu ( dst src -- )
 HOOK: %copy-float cpu ( dst src -- )
-
-! Box and unbox floats
 HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %unbox-f cpu ( dst src -- )
+HOOK: %unbox-alien cpu ( dst src -- )
+HOOK: %unbox-byte-array cpu ( dst src -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 HOOK: %box-float cpu ( dst src temp -- )
+HOOK: %box-alien cpu ( dst src temp -- )
+
+HOOK: %alien-unsigned-1 cpu ( dst src -- )
+HOOK: %alien-unsigned-2 cpu ( dst src -- )
+HOOK: %alien-unsigned-4 cpu ( dst src -- )
+HOOK: %alien-signed-1   cpu ( dst src -- )
+HOOK: %alien-signed-2   cpu ( dst src -- )
+HOOK: %alien-signed-3   cpu ( dst src -- )
+HOOK: %alien-cell       cpu ( dst src -- )
+HOOK: %alien-float      cpu ( dst src -- )
+HOOK: %alien-double     cpu ( dst src -- )
+
+HOOK: %set-alien-integer-1 cpu ( src value -- )
+HOOK: %set-alien-integer-2 cpu ( src value -- )
+HOOK: %set-alien-integer-4 cpu ( src value -- )
+HOOK: %set-alien-cell      cpu ( src value -- )
+HOOK: %set-alien-float     cpu ( src value -- )
+HOOK: %set-alien-double    cpu ( src value -- )
+
+HOOK: %allot cpu ( dst size type tag temp -- )
+HOOK: %write-barrier cpu ( src card# table -- )
+HOOK: %gc cpu ( -- )
+
+HOOK: %prologue cpu ( n -- )
+HOOK: %epilogue cpu ( n -- )
+
+HOOK: %binary-branch cpu ( label src1 src2 label cc -- )
+HOOK: %binary-imm-branch cpu ( label src1 src2 label cc -- )
+
+HOOK: %spill-integer cpu ( src n -- )
+HOOK: %spill-float cpu ( src n -- )
+HOOK: %reload-integer cpu ( dst n -- )
+HOOK: %reload-float cpu ( dst n -- )
 
 ! FFI stuff
 
@@ -141,6 +177,10 @@ HOOK: %cleanup cpu ( params -- )
 
 M: object %cleanup ( params -- ) drop ;
 
+HOOK: %prepare-alien-indirect cpu ( -- )
+
+HOOK: %alien-indirect cpu ( -- )
+
 HOOK: %alien-callback cpu ( quot -- )
 
 HOOK: %callback-value cpu ( ctype -- )
@@ -150,59 +190,17 @@ HOOK: %callback-return cpu ( params -- )
 
 M: object %callback-return drop %return ;
 
-HOOK: %prepare-alien-indirect cpu ( -- )
-
-HOOK: %alien-indirect cpu ( -- )
-
 M: stack-params param-reg drop ;
 
 M: stack-params param-regs drop f ;
 
-M: object load-literal load-indirect ;
-
 : if-small-struct ( n size true false -- ? )
-    [ over not over struct-small-enough? and ] 2dip
-    [ [ nip ] prepose ] dip if ;
+    [ 2dup [ not ] [ struct-small-enough? ] bi and ] 2dip
+    [ '[ nip @ ] ] dip if ;
     inline
 
 : %unbox-struct ( n c-type -- )
-    [
-        %unbox-small-struct
-    ] [
-        %unbox-large-struct
-    ] if-small-struct ;
+    [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
 
 : %box-struct ( n c-type -- )
-    [
-        %box-small-struct
-    ] [
-        %box-large-struct
-    ] if-small-struct ;
-
-! Alien accessors
-HOOK: %unbox-byte-array cpu ( dst src -- )
-
-HOOK: %unbox-alien cpu ( dst src -- )
-
-HOOK: %unbox-f cpu ( dst src -- )
-
-HOOK: %unbox-any-c-ptr cpu ( dst src -- )
-
-HOOK: %box-alien cpu ( dst src temp -- )
-
-! Allocation
-HOOK: %allot cpu ( dst size type tag temp -- )
-
-HOOK: %write-barrier cpu ( src card# table -- )
-
-! GC check
-HOOK: %gc cpu ( -- )
-
-! Spilling
-HOOK: %spill-integer cpu ( src n -- )
-
-HOOK: %spill-float cpu ( src n -- )
-
-HOOK: %reload-integer cpu ( dst n -- )
-
-HOOK: %reload-float cpu ( dst n -- )
+    [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
diff --git a/basis/cpu/ppc/allot/allot.factor b/basis/cpu/ppc/allot/allot.factor
index 5868316577..3190973f26 100644
--- a/basis/cpu/ppc/allot/allot.factor
+++ b/basis/cpu/ppc/allot/allot.factor
@@ -66,7 +66,7 @@ M: ppc %box-float ( dst src -- )
         ! is it zero?
         0 over v>operand 0 CMPI
         "non-zero" get BNE
-        0 >bignum over load-literal
+        dup 0 >bignum %load-literal
         "end" get B
         ! it is non-zero
         "non-zero" resolve-label
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index e7e654c8f7..cc25f06cc9 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -41,7 +41,6 @@ M: x86.32 struct-small-enough? ( size -- ? )
 ! On x86, parameters are never passed in registers.
 M: int-regs return-reg drop EAX ;
 M: int-regs param-regs drop { } ;
-M: int-regs vregs drop { EAX ECX EDX EBP } ;
 M: int-regs push-return-reg return-reg PUSH ;
 
 M: int-regs load-return-reg
@@ -51,7 +50,6 @@ M: int-regs store-return-reg
     [ stack@ ] [ return-reg ] bi* MOV ;
 
 M: float-regs param-regs drop { } ;
-M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 : FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
 
@@ -81,8 +79,8 @@ M: x86.32 fixnum>slot@ 1 SHR ;
 
 M: x86.32 prepare-division CDQ ;
 
-M: x86.32 load-indirect
-    0 [] MOV rc-absolute-cell rel-literal ;
+M: x86.32 %load-indirect
+    swap 0 [] MOV rc-absolute-cell rel-literal ;
 
 M: object %load-param-reg 3drop ;
 
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index a78b4d8d92..3db92d82a5 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -26,17 +26,10 @@ M: x86.64 temp-reg-1 RAX ;
 M: x86.64 temp-reg-2 RCX ;
 
 M: int-regs return-reg drop RAX ;
-M: int-regs vregs drop { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } ;
 M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
 
 M: float-regs return-reg drop XMM0 ;
 
-M: float-regs vregs
-    drop {
-        XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
-        XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
-    } ;
-
 M: float-regs param-regs
     drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
@@ -44,8 +37,8 @@ M: x86.64 fixnum>slot@ drop ;
 
 M: x86.64 prepare-division CQO ;
 
-M: x86.64 load-indirect ( literal reg -- )
-    0 [] MOV rc-relative rel-literal ;
+M: x86.64 %load-indirect ( literal reg -- )
+    swap 0 [] MOV rc-relative rel-literal ;
 
 M: stack-params %load-param-reg
     drop
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 3b48610fe7..6d0860deee 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -71,11 +71,7 @@ HOOK: temp-reg-2 cpu ( -- reg )
 HOOK: fixnum>slot@ cpu ( op -- )
 HOOK: prepare-division cpu ( -- )
 
-M: f load-literal
-    \ f tag-number MOV drop ;
-
-M: fixnum load-literal
-    swap tag-fixnum MOV ;
+M: x86 %load-immediate MOV ;
 
 : align-stack ( n -- n' )
     os macosx? cpu x86.64? or [ 16 align ] when ;
@@ -118,11 +114,11 @@ M: x86 %call ( label -- ) CALL ;
 
 M: x86 %jump-label ( label -- ) JMP ;
 
-M: x86 %jump-f ( label reg -- )
-    \ f tag-number CMP JE ;
-
-M: x86 %jump-t ( label reg -- )
-    \ f tag-number CMP JNE ;
+! M: x86 %jump-f ( label reg -- )
+!     \ f tag-number CMP JE ;
+! 
+! M: x86 %jump-t ( label reg -- )
+!     \ f tag-number CMP JNE ;
 
 : code-alignment ( -- n )
     building get length dup cell align swap - ;

From 37cf7d9a9c853e3e33558cddd6b9279ad4434d42 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 20 Oct 2008 05:55:20 -0500
Subject: [PATCH 041/318] Add SSA comparison instructions, fix various problems

---
 .../compiler/cfg/builder/builder-tests.factor | 74 +++++++++++++++++--
 basis/compiler/cfg/builder/builder.factor     |  6 +-
 basis/compiler/cfg/builder/calls/calls.factor | 13 ++--
 basis/compiler/cfg/builder/hats/hats.factor   | 17 +++--
 basis/compiler/cfg/def-use/def-use.factor     | 14 ++--
 .../cfg/instructions/instructions.factor      | 60 ++++++++-------
 .../cfg/linearization/linearization.factor    | 11 ++-
 basis/compiler/codegen/codegen.factor         | 32 ++++----
 basis/cpu/architecture/architecture.factor    | 44 ++++++-----
 9 files changed, 179 insertions(+), 92 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index 4ac25a3c30..c3cce1425e 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -1,19 +1,42 @@
 IN: compiler.cfg.builder.tests
 USING: tools.test kernel sequences
-words sequences.private fry prettyprint alien
+words sequences.private fry prettyprint alien alien.accessors
 math.private compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.debugger  ;
+compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
+kernel.private math ;
 
 \ build-cfg must-infer
 
 ! Just ensure that various CFGs build correctly.
+: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
+
 {
     [ ]
     [ dup ]
     [ swap ]
     [ >r r> ]
     [ fixnum+ ]
+    [ fixnum+fast ]
+    [ 3 fixnum+fast ]
+    [ fixnum*fast ]
+    [ 3 fixnum*fast ]
+    [ fixnum-shift-fast ]
+    [ 10 fixnum-shift-fast ]
+    [ -10 fixnum-shift-fast ]
+    [ 0 fixnum-shift-fast ]
+    [ fixnum-bitnot ]
+    [ eq? ]
+    [ "hi" eq? ]
     [ fixnum< ]
+    [ 5 fixnum< ]
+    [ float+ ]
+    [ 3.0 float+ ]
+    [ float<= ]
+    [ fixnum>bignum ]
+    [ bignum>fixnum ]
+    [ fixnum>float ]
+    [ float>fixnum ]
+    [ 3 f <array> ]
     [ [ 1 ] [ 2 ] if ]
     [ fixnum< [ 1 ] [ 2 ] if ]
     [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
@@ -25,7 +48,7 @@ compiler.cfg.builder compiler.cfg.debugger  ;
     [ "int" { "int" } "cdecl" alien-indirect ]
     [ "int" { "int" } "cdecl" [ ] alien-callback ]
 } [
-    '[ _ test-cfg drop ] [ ] swap unit-test
+    unit-test-cfg
 ] each
 
 : test-1 ( -- ) test-1 ;
@@ -36,6 +59,47 @@ compiler.cfg.builder compiler.cfg.debugger  ;
     test-1
     test-2
     test-3
-} [
-    '[ _ test-cfg drop ] [ ] swap unit-test
+} [ unit-test-cfg ] each
+
+{
+    byte-array
+    simple-alien
+    alien
+    POSTPONE: f
+} [| class |
+    {
+        alien-signed-1
+        alien-signed-2
+        alien-signed-4
+        alien-unsigned-1
+        alien-unsigned-2
+        alien-unsigned-4
+        alien-cell
+        alien-float
+        alien-double
+    } [| word |
+        { class } word '[ _ declare 10 _ execute ] unit-test-cfg
+        { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+    ] each
+    
+    {
+        set-alien-signed-1
+        set-alien-signed-2
+        set-alien-signed-4
+        set-alien-unsigned-1
+        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
+    ] 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-double '[ _ declare 10 _ execute ] unit-test-cfg
+    { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
+    
+    { 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
 ] each
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 7fd65fb05e..8ea182c108 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -139,7 +139,7 @@ M: #recursive emit-node
     init-phantoms ;
 
 : ##branch-t ( vreg -- )
-    \ f tag-number cc/= ##binary-imm-branch ;
+    \ f tag-number cc/= ##compare-imm-branch ;
 
 M: #if emit-node
     phantom-pop ##branch-t emit-if iterate-next ;
@@ -168,7 +168,9 @@ M: #if emit-node
 
 : emit-dispatch ( node -- )
     phantom-pop int-regs next-vreg
-    [ finalize-phantoms ##epilogue ] 2dip ##dispatch
+    [ finalize-phantoms ##epilogue ] 2dip
+    [ ^^offset>slot ] dip
+    ##dispatch
     dispatch-branches init-phantoms ;
 
 : <dispatch-block> ( -- word )
diff --git a/basis/compiler/cfg/builder/calls/calls.factor b/basis/compiler/cfg/builder/calls/calls.factor
index 86ebdf575b..9337bb17cc 100644
--- a/basis/compiler/cfg/builder/calls/calls.factor
+++ b/basis/compiler/cfg/builder/calls/calls.factor
@@ -85,8 +85,6 @@ IN: compiler.cfg.builder.calls
 : emit-tag ( -- )
     phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ;
 
-: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ;
-
 : (emit-slot) ( infos -- dst )
     [ 2phantom-pop ] [ third literal>> ] bi*
     ^^slot ;
@@ -108,7 +106,7 @@ IN: compiler.cfg.builder.calls
 
 : (emit-set-slot) ( infos -- )
     [ 3phantom-pop ] [ fourth literal>> ] bi*
-    ##set-slot ;
+    ^^set-slot ;
 
 : (emit-set-slot-imm) ( infos -- )
     1 phantom-drop
@@ -136,6 +134,7 @@ IN: compiler.cfg.builder.calls
         [ infos imm-insn (emit-fixnum-imm-op) ]
         [ insn (emit-fixnum-op) ]
         if
+        phantom-push
     ] ; inline
 
 : emit-primitive ( node -- )
@@ -170,7 +169,7 @@ IN: compiler.cfg.builder.calls
     phantom-push ;
 
 : emit-fixnum-comparison ( node cc -- )
-    [ '[ _ ##boolean ] ] [ '[ _ ##boolean-imm ] ] bi
+    [ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
     emit-fixnum-op ;
 
 : emit-bignum>fixnum ( -- )
@@ -180,10 +179,12 @@ IN: compiler.cfg.builder.calls
     phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ;
 
 : emit-float-op ( insn -- )
-    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float ; inline
+    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float
+    phantom-push ; inline
 
 : emit-float-comparison ( cc -- )
-    '[ _ ##boolean ] emit-float-op ;
+    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip ^^compare-float
+    phantom-push ; inline
 
 : emit-float>fixnum ( -- )
     phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ;
diff --git a/basis/compiler/cfg/builder/hats/hats.factor b/basis/compiler/cfg/builder/hats/hats.factor
index 4ac7f92ea3..d8e4dc613c 100644
--- a/basis/compiler/cfg/builder/hats/hats.factor
+++ b/basis/compiler/cfg/builder/hats/hats.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel cpu.architecture compiler.cfg.registers
+USING: kernel layouts cpu.architecture compiler.cfg.registers
 compiler.cfg.instructions ;
 IN: compiler.cfg.builder.hats
 
@@ -18,8 +18,9 @@ IN: compiler.cfg.builder.hats
 
 : ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
 : ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
-: ^^slot ( obj slot tag -- dst ) ^^i3 ##slot ; inline
+: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
 : ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
+: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
 : ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
 : ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
 : ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
@@ -36,27 +37,31 @@ IN: compiler.cfg.builder.hats
 : ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
 : ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
 : ^^not ( src -- dst ) ^^i1 ##not ; inline
-: ^^bignum>integer ( src -- dst ) ^^i1 ##bignum>integer ; inline
+: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
 : ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
 : ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
 : ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
 : ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
 : ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
 : ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
-: ^^integer>float ( src -- dst ) ^^d1 i ##integer>float ; inline
+: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
 : ^^allot ( size type tag -- dst ) ^^i3 i ##allot ; inline
 : ^^write-barrier ( src -- ) i i ##write-barrier ; inline
 : ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
 : ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
 : ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
 : ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
-: ^^unbox-c-ptr ( src class -- dst ) ^^i2 ##unbox-c-ptr ;
+: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
 : ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
 : ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
 : ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
 : ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
 : ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
-: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-3 ; inline
+: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
 : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
 : ^^alien-float ( src -- dst ) ^^i1 ##alien-float ; inline
 : ^^alien-double ( src -- dst ) ^^i1 ##alien-double ; inline
+: ^^compare ( src1 src2 -- dst ) ^^i2 ##compare ; inline
+: ^^compare-imm ( src1 src2 -- dst ) ^^i2 ##compare-imm ; inline
+: ^^compare-float ( src1 src2 -- dst ) ^^i2 ##compare-float ; inline
+: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 93232579de..fea51ab2a5 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -7,11 +7,11 @@ IN: compiler.cfg.def-use
 GENERIC: defs-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
-: allot-defs-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
+: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
 M: ##flushable defs-vregs dst>> 1array ;
 M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
-M: ##boxer defs-vregs allot-defs-vregs ;
-M: ##allot defs-vregs allot-defs-vregs ;
+M: ##unary/temp defs-vregs dst/tmp-vregs ;
+M: ##allot defs-vregs dst/tmp-vregs ;
 M: ##dispatch defs-vregs temp>> 1array ;
 M: insn defs-vregs drop f ;
 
@@ -23,9 +23,9 @@ M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
 M: ##slot-imm uses-vregs obj>> 1array ;
 M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
 M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
-M: ##binary-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: ##binary-imm-branch uses-vregs src1>> 1array ;
+M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: ##compare-imm-branch uses-vregs src1>> 1array ;
 M: ##dispatch uses-vregs src>> 1array ;
-M: _binary-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: _binary-imm-branch uses-vregs src1>> 1array ;
+M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: insn uses-vregs drop f ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 368460b920..da79782aaf 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces words
 math math.order layouts classes.algebra alien byte-arrays
-combinators compiler.cfg.registers
+compiler.constants combinators compiler.cfg.registers
 compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
@@ -17,7 +17,7 @@ TUPLE: ##flushable < insn { dst vreg } ;
 TUPLE: ##pure < ##flushable ;
 
 TUPLE: ##unary < ##pure { src vreg } ;
-TUPLE: ##boxer < ##unary { temp vreg } ;
+TUPLE: ##unary/temp < ##unary { temp vreg } ;
 TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ;
 TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ;
 TUPLE: ##commutative < ##binary ;
@@ -65,9 +65,9 @@ INSN: ##dispatch src temp ;
 INSN: ##dispatch-label label ;
 
 ! Slot access
-INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } ;
+INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
 INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
-INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } ;
+INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
 INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
 
 ! Integer arithmetic
@@ -89,8 +89,8 @@ INSN: ##sar-imm < ##binary-imm ;
 INSN: ##not < ##unary ;
 
 ! Bignum/integer conversion
-INSN: ##integer>bignum < ##boxer ;
-INSN: ##bignum>integer < ##unary ;
+INSN: ##integer>bignum < ##unary/temp ;
+INSN: ##bignum>integer < ##unary/temp ;
 
 ! Float arithmetic
 INSN: ##add-float < ##commutative ;
@@ -106,20 +106,21 @@ INSN: ##integer>float < ##unary ;
 INSN: ##copy < ##unary ;
 INSN: ##copy-float < ##unary ;
 INSN: ##unbox-float < ##unary ;
-INSN: ##unbox-f < ##unary ;
-INSN: ##unbox-alien < ##unary ;
-INSN: ##unbox-byte-array < ##unary ;
-INSN: ##unbox-any-c-ptr < ##unary ;
-INSN: ##box-float < ##boxer ;
-INSN: ##box-alien < ##boxer ;
+INSN: ##unbox-any-c-ptr < ##unary/temp ;
+INSN: ##box-float < ##unary/temp ;
+INSN: ##box-alien < ##unary/temp ;
 
-: ##unbox-c-ptr ( dst src class -- )
+: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
+: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
+: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ;
+
+: ##unbox-c-ptr ( dst src class temp -- )
     {
-        { [ dup \ f class<= ] [ drop ##unbox-f ] }
-        { [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
-        { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
-        [ drop ##unbox-any-c-ptr ]
-    } cond ; inline
+        { [ over \ f class<= ] [ 2drop ##unbox-f ] }
+        { [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
+        { [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
+        [ nip ##unbox-any-c-ptr ]
+    } cond ;
 
 ! Alien accessors
 INSN: ##alien-unsigned-1 < ##alien-getter ;
@@ -127,7 +128,7 @@ INSN: ##alien-unsigned-2 < ##alien-getter ;
 INSN: ##alien-unsigned-4 < ##alien-getter ;
 INSN: ##alien-signed-1 < ##alien-getter ;
 INSN: ##alien-signed-2 < ##alien-getter ;
-INSN: ##alien-signed-3 < ##alien-getter ;
+INSN: ##alien-signed-4 < ##alien-getter ;
 INSN: ##alien-cell < ##alien-getter ;
 INSN: ##alien-float < ##alien-getter ;
 INSN: ##alien-double < ##alien-getter ;
@@ -174,11 +175,16 @@ SYMBOL: cc/=
         { cc/= { +lt+      +gt+ } }
     } at memq? ;
 
-INSN: ##binary-branch { src1 vreg } { src2 vreg } cc ;
-INSN: ##binary-imm-branch { src1 vreg } { src2 integer } cc ;
+TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
 
-INSN: ##boolean < ##binary cc ;
-INSN: ##boolean-imm < ##binary-imm cc ;
+INSN: ##compare-branch < ##conditional-branch ;
+INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
+
+INSN: ##compare < ##binary cc ;
+INSN: ##compare-imm < ##binary-imm cc ;
+
+INSN: ##compare-float-branch < ##conditional-branch ;
+INSN: ##compare-float < ##binary cc ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;
@@ -188,8 +194,12 @@ INSN: _label id ;
 
 INSN: _branch label ;
 
-INSN: _binary-branch label { src1 vreg } { src2 vreg } cc ;
-INSN: _binary-imm-branch label { src1 vreg } { src2 integer } cc ;
+TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
+
+INSN: _compare-branch < _conditional-branch ;
+INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
+
+INSN: _compare-float-branch < _conditional-branch ;
 
 ! These instructions operate on machine registers and not
 ! virtual registers
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index c8e4b734d8..a906e77103 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -43,11 +43,14 @@ M: ##branch linearize-insn
 : binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
     [ conditional ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
 
-M: ##binary-branch linearize-insn
-    binary-conditional _binary-branch emit-branch ;
+M: ##compare-branch linearize-insn
+    binary-conditional _compare-branch emit-branch ;
 
-M: ##binary-imm-branch linearize-insn
-    binary-conditional _binary-imm-branch emit-branch ;
+M: ##compare-imm-branch linearize-insn
+    binary-conditional _compare-imm-branch emit-branch ;
+
+M: ##compare-float-branch linearize-insn
+    binary-conditional _compare-float-branch emit-branch ;
 
 : linearize-basic-block ( bb -- )
     [ number>> _label ] [ linearize-insns ] bi ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 3f88873e6e..a66f355d81 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -98,9 +98,11 @@ M: ##dispatch generate-insn
         [ tag>> ]
     } cleave ; inline
 
-M: ##slot generate-insn >slot< %slot ;
+M: ##slot generate-insn
+    [ >slot< ] [ temp>> register ] bi %slot ;
 
-M: ##slot-imm generate-insn >slot< %slot-imm ;
+M: ##slot-imm generate-insn
+    >slot< %slot-imm ;
 
 : >set-slot<
     {
@@ -110,9 +112,11 @@ M: ##slot-imm generate-insn >slot< %slot-imm ;
         [ tag>> ]
     } cleave ; inline
 
-M: ##set-slot generate-insn >set-slot< %set-slot ;
+M: ##set-slot generate-insn
+    [ >set-slot< ] [ temp>> register ] bi %set-slot ;
 
-M: ##set-slot-imm generate-insn >set-slot< %set-slot-imm ;
+M: ##set-slot-imm generate-insn
+    >set-slot< %set-slot-imm ;
 
 : dst/src ( insn -- dst src )
     [ dst>> register ] [ src>> register ] bi ; inline
@@ -154,9 +158,6 @@ M: ##float>integer generate-insn dst/src %float>integer ;
 M: ##copy             generate-insn dst/src %copy             ;
 M: ##copy-float       generate-insn dst/src %copy-float       ;
 M: ##unbox-float      generate-insn dst/src %unbox-float      ;
-M: ##unbox-f          generate-insn dst/src %unbox-f          ;
-M: ##unbox-alien      generate-insn dst/src %unbox-alien      ;
-M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
 M: ##unbox-any-c-ptr  generate-insn dst/src %unbox-any-c-ptr  ;
 M: ##box-float        generate-insn dst/src/temp %box-float   ;
 M: ##box-alien        generate-insn dst/src/temp %box-alien   ;
@@ -166,7 +167,7 @@ M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
 M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
 M: ##alien-signed-1   generate-insn dst/src %alien-signed-1   ;
 M: ##alien-signed-2   generate-insn dst/src %alien-signed-2   ;
-M: ##alien-signed-3   generate-insn dst/src %alien-signed-3   ;
+M: ##alien-signed-4   generate-insn dst/src %alien-signed-4   ;
 M: ##alien-cell       generate-insn dst/src %alien-cell       ;
 M: ##alien-float      generate-insn dst/src %alien-float      ;
 M: ##alien-double     generate-insn dst/src %alien-double     ;
@@ -461,19 +462,22 @@ M: _label generate-insn
 M: _branch generate-insn
     label>> lookup-label %jump-label ;
 
-: >binary-branch< ( insn -- label src1 src2 cc )
+: >binary-branch< ( insn -- label cc src1 src2 )
     {
         [ label>> lookup-label ]
+        [ cc>> ]
         [ src1>> register ]
         [ src2>> dup vreg? [ register ] when ]
-        [ cc>> ]
     } cleave ;
 
-M: _binary-branch generate-insn
-    >binary-branch< %binary-branch ;
+M: _compare-branch generate-insn
+    >binary-branch< %compare-branch ;
 
-M: _binary-imm-branch generate-insn
-    >binary-branch< %binary-imm-branch ;
+M: _compare-imm-branch generate-insn
+    >binary-branch< %compare-imm-branch ;
+
+M: _compare-float-branch generate-insn
+    >binary-branch< %compare-float-branch ;
 
 M: _spill generate-insn
     [ src>> ] [ n>> ] [ class>> ] tri {
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 277d83412b..24115767c3 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -51,9 +51,9 @@ HOOK: %return cpu ( -- )
 HOOK: %dispatch cpu ( src temp -- )
 HOOK: %dispatch-label cpu ( word -- )
 
-HOOK: %slot cpu ( dst obj slot tag -- )
+HOOK: %slot cpu ( dst obj slot tag temp -- )
 HOOK: %slot-imm cpu ( dst obj slot tag -- )
-HOOK: %set-slot cpu ( src obj slot tag -- )
+HOOK: %set-slot cpu ( src obj slot tag temp -- )
 HOOK: %set-slot-imm cpu ( src obj slot tag -- )
 
 HOOK: %add     cpu ( dst src1 src2 -- )
@@ -73,24 +73,21 @@ HOOK: %shr-imm cpu ( dst src1 src2 -- )
 HOOK: %sar-imm cpu ( dst src1 src2 -- )
 HOOK: %not     cpu ( dst src -- )
 
-HOOK: %integer>bignum cpu ( dst src -- )
-HOOK: %bignum>integer cpu ( dst src -- )
+HOOK: %integer>bignum cpu ( dst src temp -- )
+HOOK: %bignum>integer cpu ( dst src temp -- )
 
-HOOK: %add-float      cpu ( dst src1 src2 -- )
-HOOK: %sub-float      cpu ( dst src1 src2 -- )
-HOOK: %mul-float      cpu ( dst src1 src2 -- )
-HOOK: %div-float      cpu ( dst src1 src2 -- )
+HOOK: %add-float cpu ( dst src1 src2 -- )
+HOOK: %sub-float cpu ( dst src1 src2 -- )
+HOOK: %mul-float cpu ( dst src1 src2 -- )
+HOOK: %div-float cpu ( dst src1 src2 -- )
 
-HOOK: %integer>float  cpu ( dst src -- )
-HOOK: %float>integer  cpu ( dst src -- )
+HOOK: %integer>float cpu ( dst src -- )
+HOOK: %float>integer cpu ( dst src -- )
 
 HOOK: %copy cpu ( dst src -- )
 HOOK: %copy-float cpu ( dst src -- )
 HOOK: %unbox-float cpu ( dst src -- )
-HOOK: %unbox-f cpu ( dst src -- )
-HOOK: %unbox-alien cpu ( dst src -- )
-HOOK: %unbox-byte-array cpu ( dst src -- )
-HOOK: %unbox-any-c-ptr cpu ( dst src -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
 HOOK: %box-float cpu ( dst src temp -- )
 HOOK: %box-alien cpu ( dst src temp -- )
 
@@ -99,17 +96,17 @@ HOOK: %alien-unsigned-2 cpu ( dst src -- )
 HOOK: %alien-unsigned-4 cpu ( dst src -- )
 HOOK: %alien-signed-1   cpu ( dst src -- )
 HOOK: %alien-signed-2   cpu ( dst src -- )
-HOOK: %alien-signed-3   cpu ( dst src -- )
+HOOK: %alien-signed-4   cpu ( dst src -- )
 HOOK: %alien-cell       cpu ( dst src -- )
 HOOK: %alien-float      cpu ( dst src -- )
 HOOK: %alien-double     cpu ( dst src -- )
 
-HOOK: %set-alien-integer-1 cpu ( src value -- )
-HOOK: %set-alien-integer-2 cpu ( src value -- )
-HOOK: %set-alien-integer-4 cpu ( src value -- )
-HOOK: %set-alien-cell      cpu ( src value -- )
-HOOK: %set-alien-float     cpu ( src value -- )
-HOOK: %set-alien-double    cpu ( src value -- )
+HOOK: %set-alien-integer-1 cpu ( ptr value -- )
+HOOK: %set-alien-integer-2 cpu ( ptr value -- )
+HOOK: %set-alien-integer-4 cpu ( ptr value -- )
+HOOK: %set-alien-cell      cpu ( ptr value -- )
+HOOK: %set-alien-float     cpu ( ptr value -- )
+HOOK: %set-alien-double    cpu ( ptr value -- )
 
 HOOK: %allot cpu ( dst size type tag temp -- )
 HOOK: %write-barrier cpu ( src card# table -- )
@@ -118,8 +115,9 @@ HOOK: %gc cpu ( -- )
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )
 
-HOOK: %binary-branch cpu ( label src1 src2 label cc -- )
-HOOK: %binary-imm-branch cpu ( label src1 src2 label cc -- )
+HOOK: %compare-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
 
 HOOK: %spill-integer cpu ( src n -- )
 HOOK: %spill-float cpu ( src n -- )

From 508b1f52b823d55e0310975d56a9a6bf9d642b1c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 20 Oct 2008 05:55:57 -0500
Subject: [PATCH 042/318] Update x86 backend for SSA codegen

---
 basis/cpu/x86/32/32.factor                    |  54 +-
 basis/cpu/x86/64/64.factor                    |  96 +--
 basis/cpu/x86/allot/allot.factor              | 141 -----
 basis/cpu/x86/allot/authors.txt               |   1 -
 basis/cpu/x86/allot/tags.txt                  |   1 -
 .../cpu/x86/architecture/architecture.factor  | 564 +++++++++++++-----
 basis/cpu/x86/intrinsics/authors.txt          |   1 -
 basis/cpu/x86/intrinsics/intrinsics.factor    | 328 ----------
 basis/cpu/x86/intrinsics/tags.txt             |   1 -
 basis/cpu/x86/sse2/authors.txt                |   1 -
 basis/cpu/x86/sse2/sse2.factor                | 115 ----
 basis/cpu/x86/sse2/summary.txt                |   1 -
 basis/cpu/x86/sse2/tags.txt                   |   1 -
 13 files changed, 443 insertions(+), 862 deletions(-)
 delete mode 100644 basis/cpu/x86/allot/allot.factor
 delete mode 100755 basis/cpu/x86/allot/authors.txt
 delete mode 100644 basis/cpu/x86/allot/tags.txt
 delete mode 100755 basis/cpu/x86/intrinsics/authors.txt
 delete mode 100644 basis/cpu/x86/intrinsics/intrinsics.factor
 delete mode 100644 basis/cpu/x86/intrinsics/tags.txt
 delete mode 100644 basis/cpu/x86/sse2/authors.txt
 delete mode 100644 basis/cpu/x86/sse2/sse2.factor
 delete mode 100644 basis/cpu/x86/sse2/summary.txt
 delete mode 100644 basis/cpu/x86/sse2/tags.txt

diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index cc25f06cc9..015b1b8b03 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -1,13 +1,12 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types arrays kernel kernel.private math
-namespaces sequences stack-checker.known-words system layouts io
-vocabs.loader accessors init combinators command-line
-cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics
-cpu.x86.allot cpu.architecture compiler compiler.units
+USING: locals alien.c-types alien.syntax arrays kernel
+math namespaces sequences system layouts io vocabs.loader
+accessors init combinators command-line cpu.x86.assembler
+cpu.x86.architecture cpu.architecture compiler compiler.units
 compiler.constants compiler.alien compiler.codegen
-compiler.codegen.fixup compiler.cfg.builder
-compiler.cfg.instructions ;
+compiler.codegen.fixup compiler.cfg.instructions
+compiler.cfg.builder compiler.cfg.builder.calls ;
 IN: cpu.x86.32
 
 ! We implement the FFI for Linux, OS X and Windows all at once.
@@ -75,12 +74,8 @@ M: float-regs store-return-reg
     [ [ align-sub ] [ call ] bi* ]
     [ [ align-add ] [ drop ] bi* ] 2bi ; inline
 
-M: x86.32 fixnum>slot@ 1 SHR ;
-
-M: x86.32 prepare-division CDQ ;
-
 M: x86.32 %load-indirect
-    swap 0 [] MOV rc-absolute-cell rel-literal ;
+    0 [] MOV rc-absolute-cell rel-literal ;
 
 M: object %load-param-reg 3drop ;
 
@@ -222,7 +217,7 @@ M: x86.32 %alien-indirect ( -- )
 
 M: x86.32 %alien-callback ( quot -- )
     4 [
-        EAX load-indirect
+        EAX %load-indirect
         EAX PUSH
         "c_to_factor" f %alien-invoke
     ] with-aligned-stack ;
@@ -279,34 +274,17 @@ os windows? [
     4 "double" c-type (>>align)
 ] unless
 
-: (sse2?) ( -- ? ) "Intrinsic" throw ;
+FUNCTION: bool check_sse2 ( ) ;
 
-<<
-
-\ (sse2?) [
-    { EAX EBX ECX EDX } [ PUSH ] each
-    EAX 1 MOV
-    CPUID
-    EDX 26 SHR
-    EDX 1 AND
-    { EAX EBX ECX EDX } [ POP ] each
-    JNE
-] { } define-if-intrinsic
-
-\ (sse2?) { } { object } define-primitive
-
->>
-
-: sse2? ( -- ? ) (sse2?) ;
+: sse2? ( -- ? )
+    [ optimized-recompile-hook ] recompile-hook
+    [ [ check_sse2 ] compile-call ] with-variable ;
 
 "-no-sse2" cli-args member? [
     "Checking if your CPU supports SSE2..." print flush
-    [ optimized-recompile-hook ] recompile-hook [
-        [ sse2? ] compile-call
-    ] with-variable
-    [
+    sse2? [
         " - yes" print
-        "cpu.x86.sse2" require
+        enable-float-intrinsics
         [
             sse2? [
                 "This image was built to use SSE2, which your CPU does not support." print
@@ -315,7 +293,5 @@ os windows? [
                 1 exit
             ] unless
         ] "cpu.x86" add-init-hook
-    ] [
-        " - no" print
-    ] if
+    ] [ " - no" print ] if
 ] unless
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 3db92d82a5..e081b80374 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -1,13 +1,12 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays kernel kernel.private math
-namespaces make sequences system
-layouts alien alien.accessors alien.structs slots splitting
-assocs combinators cpu.x86.assembler
-cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
-cpu.x86.allot cpu.architecture compiler.constants
-compiler.codegen compiler.codegen.fixup compiler.cfg.instructions
-compiler.cfg.builder ;
+USING: accessors arrays kernel math namespaces make sequences
+system layouts alien alien.c-types alien.accessors alien.structs
+slots splitting assocs combinators cpu.x86.assembler
+cpu.x86.architecture cpu.architecture compiler.constants
+compiler.codegen compiler.codegen.fixup
+compiler.cfg.instructions compiler.cfg.builder
+compiler.cfg.builder.calls ;
 IN: cpu.x86.64
 
 M: x86.64 machine-registers
@@ -33,12 +32,8 @@ M: float-regs return-reg drop XMM0 ;
 M: float-regs param-regs
     drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
-M: x86.64 fixnum>slot@ drop ;
-
-M: x86.64 prepare-division CQO ;
-
-M: x86.64 %load-indirect ( literal reg -- )
-    swap 0 [] MOV rc-relative rel-literal ;
+M: x86.64 %load-indirect
+    0 [] MOV rc-relative rel-literal ;
 
 M: stack-params %load-param-reg
     drop
@@ -58,8 +53,8 @@ M: stack-params %save-param-reg
     ] with-scope ; inline
 
 ! The ABI for passing structs by value is pretty messed up
-<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>reg-class) >>
+"void*" c-type clone "__stack_value" define-primitive-type
+stack-params "__stack_value" c-type (>>reg-class)
 
 : struct-types&offset ( struct-type -- pairs )
     fields>> [
@@ -200,7 +195,7 @@ M: x86.64 %alien-indirect ( -- )
     RBP CALL ;
 
 M: x86.64 %alien-callback ( quot -- )
-    RDI load-indirect "c_to_factor" f %alien-invoke ;
+    RDI %load-indirect "c_to_factor" f %alien-invoke ;
 
 M: x86.64 %callback-value ( ctype -- )
     ! Save top of data stack
@@ -216,66 +211,9 @@ M: x86.64 %callback-value ( ctype -- )
     ! Unbox former top of data stack to return registers
     unbox-return ;
 
-USE: cpu.x86.intrinsics
+! The result of reading 4 bytes from memory is a fixnum on
+! x86-64.
+enable-alien-4-intrinsics
 
-: (%alien-get-4) ( -- )
-    small-reg-32 "offset" operand [] MOV ; inline
-
-: %alien-unsigned-4 ( -- )
-    %prepare-alien-accessor
-    "value" operand small-reg = [
-        (%alien-get-4)
-    ] [
-        small-reg PUSH
-        (%alien-get-4)
-        "value" operand small-reg MOV
-        small-reg POP
-    ] if
-    "value" operand %tag-fixnum ; inline
-
-: (%alien-signed-4) ( -- )
-    (%alien-get-4)
-    "value" operand small-reg-32 MOVSX ;
-
-: %alien-signed-4 ( -- )
-    %prepare-alien-accessor
-    "value" operand small-reg = [
-        (%alien-signed-4)
-    ] [
-        small-reg PUSH
-        (%alien-signed-4)
-        small-reg POP
-    ] if
-    "value" operand %tag-fixnum ; inline
-
-: define-alien-unsigned-4-getter ( word -- )
-    [ %alien-unsigned-4 ] alien-integer-get-template define-intrinsic ;
-
-: define-alien-signed-4-getter ( word -- )
-    [ %alien-signed-4 ] alien-integer-get-template define-intrinsic ;
-
-: %set-alien-4 ( -- )
-    "value" operand "offset" operand = [
-        "value" operand %untag-fixnum
-    ] unless
-    %prepare-alien-accessor
-    small-reg "offset" operand = [
-        "value" operand "offset" operand XCHG
-        "value" operand [] small-reg-32 MOV
-    ] [
-        small-reg PUSH
-        small-reg "value" operand MOV
-        "offset" operand [] small-reg-32 MOV
-        small-reg POP
-    ] if ; inline
-
-: define-alien-4-setter ( word -- )
-    [ %set-alien-4 ] alien-integer-set-template define-intrinsic ;
-
-! On 64-bit systems, the result of reading 4 bytes from memory
-! is a fixnum.
-\ alien-unsigned-4 define-alien-unsigned-4-getter
-\ set-alien-unsigned-4 define-alien-4-setter
-
-\ alien-signed-4 define-alien-signed-4-getter
-\ set-alien-signed-4 define-alien-4-setter
+! SSE2 is always available on x86-64.
+enable-float-intrinsics
diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor
deleted file mode 100644
index a1180755db..0000000000
--- a/basis/cpu/x86/allot/allot.factor
+++ /dev/null
@@ -1,141 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words kernel.private namespaces math math.private
-sequences generic arrays system layouts alien locals fry
-cpu.architecture cpu.x86.assembler cpu.x86.architecture
-compiler.constants compiler.cfg.templates compiler.cfg.builder
-compiler.codegen compiler.codegen.fixup ;
-IN: cpu.x86.allot
-
-M:: x86 %write-barrier ( src card# table -- )
-    #! Mark the card pointed to by vreg.
-    ! Mark the card
-    card# src MOV
-    card# card-bits SHR
-    "cards_offset" f table %alien-global
-    table card# [+] card-mark <byte> MOV
-
-    ! Mark the card deck
-    card# deck-bits card-bits - SHR
-    "decks_offset" f table %alien-global
-    table card# [+] card-mark <byte> MOV ;
-
-: load-zone-ptr ( reg -- )
-    #! Load pointer to start of zone array
-    0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
-
-: load-allot-ptr ( nursery-ptr allot-ptr -- )
-    [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
-
-: inc-allot-ptr ( nursery-ptr n -- )
-    [ cell [+] ] dip 8 align ADD ;
-
-: store-header ( temp type -- )
-    [ [] ] [ type-number tag-fixnum ] bi* MOV ;
-
-: store-tagged ( dst tag -- )
-    tag-number OR ;
-
-M:: x86 %allot ( dst size type tag nursery-ptr -- )
-    nursery-ptr dst load-allot-ptr
-    dst type store-header
-    dst tag store-tagged
-    nursery-ptr size inc-allot-ptr ;
-
-M: x86 %gc ( -- )
-    "end" define-label
-    temp-reg-1 load-zone-ptr
-    temp-reg-2 temp-reg-1 cell [+] MOV
-    temp-reg-2 1024 ADD
-    temp-reg-1 temp-reg-1 3 cells [+] MOV
-    temp-reg-2 temp-reg-1 CMP
-    "end" get JLE
-    %prepare-alien-invoke
-    "minor_gc" f %alien-invoke
-    "end" resolve-label ;
-
-: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
-
-:: %allot-bignum-signed-1 ( dst src temp -- )
-    #! on entry, inreg is a signed 32-bit quantity
-    #! exits with tagged ptr to bignum in outreg
-    #! 1 cell header, 1 cell length, 1 cell sign, + digits
-    #! length is the # of digits + sign
-    [
-        { "end" "nonzero" "positive" "store" } [ define-label ] each
-        src 0 CMP ! is it zero?
-        "nonzero" get JNE
-        ! Use cached zero value
-        0 >bignum dst load-indirect
-        "end" get JMP
-        "nonzero" resolve-label
-        ! Allocate a bignum
-        dst 4 cells bignum bignum temp %allot
-        ! Write length
-        dst 1 bignum@ 2 tag-fixnum MOV
-        ! Test sign
-        src 0 CMP
-        "positive" get JGE
-        dst 2 bignum@ 1 MOV ! negative sign
-        src NEG
-        "store" get JMP
-        "positive" resolve-label
-        dst 2 bignum@ 0 MOV ! positive sign
-        "store" resolve-label
-        dst 3 bignum@ src MOV
-        "end" resolve-label
-    ] with-scope ;
-
-: alien@ ( reg n -- op ) cells object tag-number - [+] ;
-
-M:: x86 %box-alien ( dst src temp -- )
-    [
-        { "end" "f" } [ define-label ] each
-        src 0 CMP
-        "f" get JE
-        dst 4 cells alien object temp %allot
-        dst 1 alien@ \ f tag-number MOV
-        dst 2 alien@ \ f tag-number MOV
-        ! Store src in alien-offset slot
-        dst 3 alien@ src MOV
-        "end" get JMP
-        "f" resolve-label
-        dst \ f tag-number MOV
-        "end" resolve-label
-    ] with-scope ;
-
-: overflow-check ( word -- )
-    "end" define-label
-    "z" operand "x" operand MOV
-    "z" operand "y" operand pick execute
-    ! If the previous arithmetic operation overflowed, then we
-    ! turn the result into a bignum and leave it in EAX.
-    "end" get JNO
-    ! There was an overflow. Recompute the original operand.
-    { "y" "x" } [ %untag-fixnum ] unique-operands
-    "x" operand "y" operand rot execute
-    "z" operand "x" operand "y" operand %allot-bignum-signed-1
-    "end" resolve-label ; inline
-
-: overflow-template ( word insn -- )
-    '[ _ overflow-check ] T{ template
-        { input { { f "x" } { f "y" } } }
-        { scratch { { f "z" } } }
-        { output { "z" } }
-        { clobber { "x" "y" } }
-        { gc t }
-    } define-intrinsic ;
-
-\ fixnum+ \ ADD overflow-template
-\ fixnum- \ SUB overflow-template
-
-\ fixnum>bignum [
-    "x" operand %untag-fixnum
-    "y" operand "x" operand "scratch" operand %allot-bignum-signed-1
-] T{ template
-    { input { { f "x" } } }
-    { scratch { { f "y" } { f "scratch" } } }
-    { output { "y" } }
-    { clobber { "x" } }
-    { gc t }
-} define-intrinsic
diff --git a/basis/cpu/x86/allot/authors.txt b/basis/cpu/x86/allot/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/basis/cpu/x86/allot/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/cpu/x86/allot/tags.txt b/basis/cpu/x86/allot/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/basis/cpu/x86/allot/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 6d0860deee..37f827b857 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -3,16 +3,416 @@
 USING: accessors assocs alien alien.c-types arrays
 cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
 kernel kernel.private math memory namespaces make sequences
-words system layouts combinators math.order locals
+words system layouts combinators math.order fry locals
 compiler.constants compiler.cfg.registers
 compiler.cfg.instructions compiler.codegen
 compiler.codegen.fixup ;
 IN: cpu.x86.architecture
 
+HOOK: temp-reg-1 cpu ( -- reg )
+HOOK: temp-reg-2 cpu ( -- reg )
+
+M: x86 %load-immediate MOV ;
+
 HOOK: ds-reg cpu ( -- reg )
 HOOK: rs-reg cpu ( -- reg )
+
+: reg-stack ( n reg -- op ) swap cells neg [+] ;
+
+GENERIC: loc>operand ( loc -- operand )
+
+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 ;
+: (%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) ;
+
+: align-stack ( n -- n' )
+    os macosx? cpu x86.64? or [ 16 align ] when ;
+
+M: x86 stack-frame-size ( stack-frame -- i )
+    [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+    [ params>> ]
+    [ return>> ]
+    tri + +
+    3 cells +
+    align-stack ;
+
+M: x86 %call ( label -- ) CALL ;
+M: x86 %jump-label ( label -- ) JMP ;
+M: x86 %return ( -- ) 0 RET ;
+
+: code-alignment ( -- n )
+    building get length dup cell align swap - ;
+
+: align-code ( n -- )
+    0 <repetition> % ;
+
+M:: x86 %dispatch ( src temp -- )
+    ! Load jump table base. We use a temporary register
+    ! since on AMD64 we have to load a 64-bit immediate. On
+    ! x86, this is redundant.
+    ! Add jump table base
+    temp HEX: ffffffff MOV rc-absolute-cell rel-here
+    src temp ADD
+    src HEX: 7f [+] JMP
+    ! Fix up the displacement above
+    code-alignment dup bootstrap-cell 8 = 15 9 ? +
+    building get dup pop* push
+    align-code ;
+
+M: x86 %dispatch-label ( word -- )
+    0 cell, rc-absolute-cell rel-word ;
+
+:: (%slot) ( obj slot tag temp -- op )
+    temp slot obj [+] LEA
+    temp tag neg [+] ; inline
+
+:: (%slot-imm) ( obj slot tag -- op )
+    obj slot cells tag - [+] ; inline
+
+M: x86 %slot ( dst obj slot tag temp -- ) (%slot) MOV ;
+M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
+M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ;
+M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
+
+: ?MOV ( dst src -- )
+    2dup = [ 2drop ] [ MOV ] if ; inline
+
+: 1operand ( dst src -- dst' )
+    dupd ?MOV ; inline
+
+: 2operand ( dst src1 src2 -- dst src )
+    [ 1operand ] dip ; inline
+
+M: x86 %add     [+] LEA ;
+M: x86 %add-imm [+] LEA ;
+M: x86 %sub     2operand SUB ;
+M: x86 %sub-imm neg [+] LEA ;
+M: x86 %mul     2operand IMUL2 ;
+M: x86 %mul-imm 2operand IMUL2 ;
+M: x86 %and     2operand AND ;
+M: x86 %and-imm 2operand AND ;
+M: x86 %or      2operand OR ;
+M: x86 %or-imm  2operand OR ;
+M: x86 %xor     2operand XOR ;
+M: x86 %xor-imm 2operand XOR ;
+M: x86 %shl-imm 2operand SHL ;
+M: x86 %shr-imm 2operand SHR ;
+M: x86 %sar-imm 2operand SAR ;
+M: x86 %not     1operand NOT ;
+
+: bignum@ ( reg n -- op )
+    cells bignum tag-number - [+] ; inline
+
+M:: x86 %integer>bignum ( dst src temp -- )
+    #! on entry, inreg is a signed 32-bit quantity
+    #! exits with tagged ptr to bignum in outreg
+    #! 1 cell header, 1 cell length, 1 cell sign, + digits
+    #! length is the # of digits + sign
+    [
+        { "end" "nonzero" "positive" } [ define-label ] each
+        src 0 CMP ! is it zero?
+        "nonzero" get JNE
+        ! Use cached zero value
+        dst 0 >bignum %load-indirect
+        "end" get JMP
+        "nonzero" resolve-label
+        ! Allocate a bignum
+        dst 4 cells bignum bignum temp %allot
+        ! Write length
+        dst 1 bignum@ 2 tag-fixnum MOV
+        ! Test sign
+        src 0 CMP
+        "positive" get JGE
+        dst 2 bignum@ 1 MOV ! negative sign
+        src NEG
+        dst 3 bignum@ src MOV
+        src NEG ! we don't want to clobber src
+        "end" get JMP
+        "positive" resolve-label
+        dst 2 bignum@ 0 MOV ! positive sign
+        dst 3 bignum@ src MOV
+        "end" resolve-label
+    ] with-scope ;
+
+M:: x86 %bignum>integer ( dst src -- )
+    [
+        "nonzero" define-label
+        "positive" define-label
+        "end" define-label
+        dst src 1 bignum@ MOV
+         ! if the length is 1, its just the sign and nothing else,
+         ! so output 0
+        dst 1 tag-fixnum CMP
+        "nonzero" get JNE
+        dst 0 MOV
+        "end" get JMP
+        "nonzero" resolve-label
+        ! load the value
+        dst src 3 bignum@ MOV
+        ! is the sign negative?
+        src 2 bignum@ 0 CMP
+        "positive" get JE
+        dst -1 IMUL2
+        "positive" resolve-label
+        dst 3 SHL
+        "end" resolve-label
+    ] with-scope ;
+
+M: x86 %add-float 2operand ADDSD ;
+M: x86 %sub-float 2operand SUBSD ;
+M: x86 %mul-float 2operand MULSD ;
+M: x86 %div-float 2operand DIVSD ;
+
+M: x86 %integer>float CVTTSD2SI ;
+M: x86 %float>integer CVTSI2SD ;
+
+M: x86 %copy ( dst src -- ) MOV ;
+
+M: x86 %copy-float MOVSD ;
+
+M: x86 %unbox-float ( dst src -- )
+    float-offset [+] MOVSD ;
+
+M:: x86 %unbox-any-c-ptr ( dst src dst temp -- )
+    [
+        { "is-byte-array" "end" "start" } [ define-label ] each
+        dst 0 MOV
+        temp src MOV
+        ! We come back here with displaced aliens
+        "start" resolve-label
+        ! Is the object f?
+        temp \ f tag-number CMP
+        "end" get JE
+        ! Is the object an alien?
+        temp header-offset [+] alien type-number tag-fixnum CMP
+        "is-byte-array" get JNE
+        ! If so, load the offset and add it to the address
+        dst temp alien-offset [+] ADD
+        ! Now recurse on the underlying alien
+        temp temp underlying-alien-offset [+] MOV
+        "start" get JMP
+        "is-byte-array" resolve-label
+        ! Add byte array address to address being computed
+        dst temp ADD
+        ! Add an offset to start of byte array's data
+        dst byte-array-offset ADD
+        "end" resolve-label
+    ] with-scope ;
+
+M:: x86 %box-float ( dst src temp -- )
+    dst 16 float float temp %allot
+    dst 8 float tag-number - [+] src MOVSD ;
+
+: alien@ ( reg n -- op ) cells object tag-number - [+] ;
+
+M:: x86 %box-alien ( dst src temp -- )
+    [
+        { "end" "f" } [ define-label ] each
+        src 0 CMP
+        "f" get JE
+        dst 4 cells alien object temp %allot
+        dst 1 alien@ \ f tag-number MOV
+        dst 2 alien@ \ f tag-number MOV
+        ! Store src in alien-offset slot
+        dst 3 alien@ src MOV
+        "end" get JMP
+        "f" resolve-label
+        dst \ f tag-number MOV
+        "end" resolve-label
+    ] with-scope ;
+
+: small-reg-4 ( reg -- reg' )
+    H{
+        { EAX EAX }
+        { ECX ECX }
+        { EDX EDX }
+        { EBX EBX }
+        { ESP ESP }
+        { EBP EBP }
+        { ESI ESP }
+        { EDI EDI }
+
+        { RAX EAX }
+        { RCX ECX }
+        { RDX EDX }
+        { RBX EBX }
+        { RSP ESP }
+        { RBP EBP }
+        { RSI ESP }
+        { RDI EDI }
+    } at ; inline
+
+: small-reg-2 ( reg -- reg' )
+    small-reg-4 H{
+        { EAX AX }
+        { ECX CX }
+        { EDX DX }
+        { EBX BX }
+        { ESP SP }
+        { EBP BP }
+        { ESI SI }
+        { EDI DI }
+    } at ; inline
+
+: small-reg-1 ( reg -- reg' )
+    small-reg-4 {
+        { EAX AL }
+        { ECX CL }
+        { EDX DL }
+        { EBX BL }
+    } at ; inline
+
+: small-reg ( reg size -- reg' )
+    {
+        { 1 small-reg-1 }
+        { 2 small-reg-2 }
+        { 4 small-reg-4 }
+    } case ;
+
+: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
+
+: small-reg-that-isn't ( exclude -- reg' )
+    small-reg-4 small-regs [ eq? not ] with find nip ;
+
+: with-save/restore ( reg quot -- )
+    [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
+
+:: with-small-register ( dst src quot: ( dst src -- ) -- )
+    #! If the destination register overlaps a small register, we
+    #! call the quot with that. Otherwise, we find a small
+    #! register that is not equal to src, and call quot, saving
+    #! and restoring the small register.
+    dst small-regs memq? [ src quot call ] [
+        src small-reg-that-isn't
+        [ src quot call ]
+        with-save/restore
+    ] if ; inline
+
+: %alien-integer-getter ( dst src size quot -- )
+    '[ [ _ small-reg ] dip @ ] with-small-register ; inline
+
+: %alien-unsigned-getter ( dst src size -- )
+    [ MOVZX ] %alien-integer-getter ; inline
+
+M: x86 %alien-unsigned-1 1 %alien-unsigned-getter ;
+M: x86 %alien-unsigned-2 2 %alien-unsigned-getter ;
+M: x86 %alien-unsigned-4 4 %alien-unsigned-getter ;
+
+: %alien-signed-getter ( dst src size -- )
+    [ MOVSX ] %alien-integer-getter ; inline
+
+M: x86 %alien-signed-1 1 %alien-signed-getter ;
+M: x86 %alien-signed-2 2 %alien-signed-getter ;
+M: x86 %alien-signed-4 4 %alien-signed-getter ;
+
+M: x86 %alien-cell [] MOV ;
+M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
+M: x86 %alien-double [] MOVSD ;
+
+:: %alien-integer-setter ( ptr value size -- )
+    value ptr [| new-value ptr |
+        new-value value ?MOV
+        ptr [] new-value size small-reg MOV
+    ] with-small-register ; inline
+
+M: x86 %set-alien-integer-1 1 %alien-integer-setter ;
+M: x86 %set-alien-integer-2 2 %alien-integer-setter ;
+M: x86 %set-alien-integer-4 4 %alien-integer-setter ;
+M: x86 %set-alien-cell [ [] ] dip MOV ;
+M: x86 %set-alien-float dup dup CVTSD2SS [ [] ] dip MOVSS ;
+M: x86 %set-alien-double [ [] ] dip MOVSD ;
+
+: load-zone-ptr ( reg -- )
+    #! Load pointer to start of zone array
+    0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+
+: load-allot-ptr ( nursery-ptr allot-ptr -- )
+    [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
+
+: inc-allot-ptr ( nursery-ptr n -- )
+    [ cell [+] ] dip 8 align ADD ;
+
+: store-header ( temp type -- )
+    [ [] ] [ type-number tag-fixnum ] bi* MOV ;
+
+: store-tagged ( dst tag -- )
+    tag-number OR ;
+
+M:: x86 %allot ( dst size type tag nursery-ptr -- )
+    nursery-ptr dst load-allot-ptr
+    dst type store-header
+    dst tag store-tagged
+    nursery-ptr size inc-allot-ptr ;
+
+HOOK: %alien-global cpu ( symbol dll register -- )
+
+M:: x86 %write-barrier ( src card# table -- )
+    #! Mark the card pointed to by vreg.
+    ! Mark the card
+    card# src MOV
+    card# card-bits SHR
+    "cards_offset" f table %alien-global
+    table card# [+] card-mark <byte> MOV
+
+    ! Mark the card deck
+    card# deck-bits card-bits - SHR
+    "decks_offset" f table %alien-global
+    table card# [+] card-mark <byte> MOV ;
+
+M: x86 %gc ( -- )
+    "end" define-label
+    temp-reg-1 load-zone-ptr
+    temp-reg-2 temp-reg-1 cell [+] MOV
+    temp-reg-2 1024 ADD
+    temp-reg-1 temp-reg-1 3 cells [+] MOV
+    temp-reg-2 temp-reg-1 CMP
+    "end" get JLE
+    %prepare-alien-invoke
+    "minor_gc" f %alien-invoke
+    "end" resolve-label ;
+
 HOOK: stack-reg cpu ( -- reg )
 
+: decr-stack-reg ( n -- )
+    dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
+
+M: x86 %prologue ( n -- )
+    temp-reg-1 0 MOV rc-absolute-cell rel-this
+    dup PUSH
+    temp-reg-1 PUSH
+    stack-reg swap 3 cells - SUB ;
+
+: incr-stack-reg ( n -- )
+    dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
+
+M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
+
+M: x86 %compare-branch ( label cc src1 src2 -- )
+    CMP {
+        { cc< [ JL ] }
+        { cc<= [ JLE ] }
+        { cc> [ JG ] }
+        { cc>= [ JGE ] }
+        { cc= [ JE ] }
+    } case ;
+
+M: x86 %compare-imm-branch ( label src1 src2 cc -- )
+    %compare-branch ;
+
+M: x86 %compare-float-branch ( label cc src1 src2 -- )
+    UCOMISD {
+        { cc< [ JB ] }
+        { cc<= [ JBE ] }
+        { cc> [ JA ] }
+        { cc>= [ JAE ] }
+        { cc= [ JE ] }
+    } case ;
+
 : stack@ ( n -- op ) stack-reg swap [+] ;
 
 : spill-integer-base ( stack-frame -- n )
@@ -34,19 +434,11 @@ HOOK: stack-reg cpu ( -- reg )
     stack-frame get spill-float-base
     + stack@ ;
 
-: next-stack@ ( n -- operand )
-    #! nth parameter from the next stack frame. Used to box
-    #! input values to callbacks; the callback has its own
-    #! stack frame set up, and we want to read the frame
-    #! set up by the caller.
-    stack-frame get total-size>> + stack@ ;
+M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
+M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
 
-: reg-stack ( n reg -- op ) swap cells neg [+] ;
-
-GENERIC: loc>operand ( loc -- operand )
-
-M: ds-loc loc>operand n>> ds-reg reg-stack ;
-M: rs-loc loc>operand n>> rs-reg reg-stack ;
+M: x86 %spill-float spill-float@ swap MOVSD ;
+M: x86 %reload-float spill-float@ MOVSD ;
 
 M: int-regs %save-param-reg drop >r stack@ r> MOV ;
 M: int-regs %load-param-reg drop swap stack@ MOV ;
@@ -54,7 +446,6 @@ M: int-regs %load-param-reg drop swap stack@ MOV ;
 GENERIC: MOVSS/D ( dst src reg-class -- )
 
 M: single-float-regs MOVSS/D drop MOVSS ;
-
 M: double-float-regs MOVSS/D drop MOVSD ;
 
 M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
@@ -64,42 +455,6 @@ GENERIC: push-return-reg ( reg-class -- )
 GENERIC: load-return-reg ( n reg-class -- )
 GENERIC: store-return-reg ( n reg-class -- )
 
-! Only used by inline allocation
-HOOK: temp-reg-1 cpu ( -- reg )
-HOOK: temp-reg-2 cpu ( -- reg )
-
-HOOK: fixnum>slot@ cpu ( op -- )
-HOOK: prepare-division cpu ( -- )
-
-M: x86 %load-immediate MOV ;
-
-: align-stack ( n -- n' )
-    os macosx? cpu x86.64? or [ 16 align ] when ;
-
-M: x86 stack-frame-size ( stack-frame -- i )
-    [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
-    [ params>> ]
-    [ return>> ]
-    tri + +
-    3 cells +
-    align-stack ;
-
-: decr-stack-reg ( n -- )
-    dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
-
-M: x86 %prologue ( n -- )
-    temp-reg-1 0 MOV rc-absolute-cell rel-this
-    dup PUSH
-    temp-reg-1 PUSH
-    stack-reg swap 3 cells - SUB ;
-
-: incr-stack-reg ( n -- )
-    dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
-
-M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
-
-HOOK: %alien-global cpu ( symbol dll register -- )
-
 M: x86 %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
@@ -110,52 +465,6 @@ M: x86 %prepare-alien-invoke
     temp-reg-1 2 cells [+] ds-reg MOV
     temp-reg-1 3 cells [+] rs-reg MOV ;
 
-M: x86 %call ( label -- ) CALL ;
-
-M: x86 %jump-label ( label -- ) JMP ;
-
-! M: x86 %jump-f ( label reg -- )
-!     \ f tag-number CMP JE ;
-! 
-! M: x86 %jump-t ( label reg -- )
-!     \ f tag-number CMP JNE ;
-
-: code-alignment ( -- n )
-    building get length dup cell align swap - ;
-
-: align-code ( n -- )
-    0 <repetition> % ;
-
-M:: x86 %dispatch ( src temp -- )
-    ! Load jump table base. We use a temporary register
-    ! since on AMD64 we have to load a 64-bit immediate. On
-    ! x86, this is redundant.
-    ! Untag and multiply to get a jump table offset
-    src fixnum>slot@
-    ! Add jump table base
-    temp HEX: ffffffff MOV rc-absolute-cell rel-here
-    src temp ADD
-    src HEX: 7f [+] JMP
-    ! Fix up the displacement above
-    code-alignment dup bootstrap-cell 8 = 15 9 ? +
-    building get dup pop* push
-    align-code ;
-
-M: x86 %dispatch-label ( word -- )
-    0 cell, rc-absolute-cell rel-word ;
-
-M: x86 %peek loc>operand MOV ;
-
-M: x86 %replace loc>operand swap MOV ;
-
-: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
-
-M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
-
-M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
-
-M: x86 %copy ( dst src -- ) MOV ;
-
 M: x86 fp-shadows-int? ( -- ? ) f ;
 
 M: x86 value-structs? t ;
@@ -163,60 +472,9 @@ M: x86 value-structs? t ;
 M: x86 small-enough? ( n -- ? )
     HEX: -80000000 HEX: 7fffffff between? ;
 
-: %untag ( reg -- ) tag-mask get bitnot AND ;
-
-: %untag-fixnum ( reg -- ) tag-bits get SAR ;
-
-: %tag-fixnum ( reg -- ) tag-bits get SHL ;
-
-M: x86 %return ( -- ) 0 RET ;
-
-! Alien intrinsics
-M: x86 %unbox-byte-array ( dst src -- )
-    byte-array-offset [+] LEA ;
-
-M: x86 %unbox-alien ( dst src -- )
-    alien-offset [+] MOV ;
-
-M: x86 %unbox-f ( dst src -- )
-    drop 0 MOV ;
-
-M: x86 %unbox-any-c-ptr ( dst src -- )
-    { "is-byte-array" "end" "start" } [ define-label ] each
-    ! Address is computed in ds-reg
-    ds-reg PUSH
-    ds-reg 0 MOV
-    ! Object is stored in ds-reg
-    rs-reg PUSH
-    rs-reg swap MOV
-    ! We come back here with displaced aliens
-    "start" resolve-label
-    ! Is the object f?
-    rs-reg \ f tag-number CMP
-    "end" get JE
-    ! Is the object an alien?
-    rs-reg header-offset [+] alien type-number tag-fixnum CMP
-    "is-byte-array" get JNE
-    ! If so, load the offset and add it to the address
-    ds-reg rs-reg alien-offset [+] ADD
-    ! Now recurse on the underlying alien
-    rs-reg rs-reg underlying-alien-offset [+] MOV
-    "start" get JMP
-    "is-byte-array" resolve-label
-    ! Add byte array address to address being computed
-    ds-reg rs-reg ADD
-    ! Add an offset to start of byte array's data
-    ds-reg byte-array-offset ADD
-    "end" resolve-label
-    ! Done, store address in destination register
-    ds-reg MOV
-    ! Restore rs-reg
-    rs-reg POP
-    ! Restore ds-reg
-    ds-reg POP ;
-
-M: x86 %spill-integer ( src n -- )
-    spill-integer@ swap MOV ;
-
-M: x86 %reload-integer ( dst n -- )
-    spill-integer@ MOV ;
+: next-stack@ ( n -- operand )
+    #! nth parameter from the next stack frame. Used to box
+    #! input values to callbacks; the callback has its own
+    #! stack frame set up, and we want to read the frame
+    #! set up by the caller.
+    stack-frame get total-size>> + stack@ ;
diff --git a/basis/cpu/x86/intrinsics/authors.txt b/basis/cpu/x86/intrinsics/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/basis/cpu/x86/intrinsics/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/cpu/x86/intrinsics/intrinsics.factor b/basis/cpu/x86/intrinsics/intrinsics.factor
deleted file mode 100644
index e5f13f4a9d..0000000000
--- a/basis/cpu/x86/intrinsics/intrinsics.factor
+++ /dev/null
@@ -1,328 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays alien.accessors kernel
-kernel.private math memory namespaces make sequences words
-system layouts combinators math.order math.private alien
-alien.c-types slots.private locals fry cpu.architecture
-cpu.x86.assembler cpu.x86.assembler.private cpu.x86.architecture
-compiler.codegen.fixup compiler.constants compiler.intrinsics
-compiler.cfg.builder compiler.cfg.registers compiler.cfg.stacks
-compiler.cfg.templates compiler.codegen ;
-IN: cpu.x86.intrinsics
-
-! Type checks
-\ tag [
-    "in" operand tag-mask get AND
-    "in" operand %tag-fixnum
-] T{ template
-    { input { { f "in" } } }
-    { output { "in" } }
-} define-intrinsic
-
-! Slots
-: %constant-slot ( -- op )
-    "obj" operand
-    "n" literal cells "tag" literal - [+] ;
-
-: %computed-slot ( -- op )
-    "n" operand fixnum>slot@
-    "n" operand "obj" operand ADD
-    "n" operand "tag" literal neg [+] ;
-
-\ (slot) {
-    {
-        [ "val" operand %constant-slot MOV ] T{ template
-            { input { { f "obj" } { small-slot "n" } { small-slot "tag" } } }
-            { scratch { { f "val" } } }
-            { output { "val" } }
-        }
-    }
-    {
-        [ "val" operand %computed-slot MOV ] T{ template
-            { input { { f "obj" } { f "n" } { small-slot "tag" } } }
-            { scratch { { f "val" } } }
-            { output { "val" } }
-            { clobber { "n" } }
-        }
-    }
-} define-intrinsics
-
-\ (set-slot) {
-    {
-        [ %constant-slot "val" operand MOV ] T{ template
-            { input { { f "val" } { f "obj" } { small-slot "n" } { small-slot "tag" } } }
-        }
-    }
-    {
-        [ %computed-slot "val" operand MOV ] T{ template
-            { input { { f "val" } { f "obj" } { f "n" } { small-slot "tag" } } }
-            { clobber { "n" } }
-        }
-    }
-} define-intrinsics
-
-! Fixnums
-: fixnum-op ( op hash -- pair )
-    >r [ "x" operand "y" operand ] swap suffix r> 2array ;
-
-: fixnum-value-op ( op -- pair )
-    T{ template
-        { input { { f "x" } { small-tagged "y" } } }
-        { output { "x" } }
-    } fixnum-op ;
-
-: fixnum-register-op ( op -- pair )
-    T{ template
-        { input { { f "x" } { f "y" } } }
-        { output { "x" } }
-    } fixnum-op ;
-
-: define-fixnum-op ( word op -- )
-    [ fixnum-value-op ] keep fixnum-register-op
-    2array define-intrinsics ;
-
-{
-    { fixnum+fast ADD }
-    { fixnum-fast SUB }
-    { fixnum-bitand AND }
-    { fixnum-bitor OR }
-    { fixnum-bitxor XOR }
-} [
-    first2 define-fixnum-op
-] each
-
-\ fixnum-bitnot [
-    "x" operand NOT
-    "x" operand tag-mask get XOR
-] T{ template
-    { input { { f "x" } } }
-    { output { "x" } }
-} define-intrinsic
-
-\ fixnum*fast {
-    {
-        [
-            "x" operand "y" literal IMUL2
-        ] T{ template
-            { input { { f "x" } { small-tagged "y" } } }
-            { output { "x" } }
-        }
-    } {
-        [
-            "out" operand "x" operand MOV
-            "out" operand %untag-fixnum
-            "y" operand "out" operand IMUL2
-        ] T{ template
-            { input { { f "x" } { f "y" } } }
-            { scratch { { f "out" } } }
-            { output { "out" } }
-        }
-    }
-} define-intrinsics
-
-\ fixnum-shift-fast [
-    "x" operand "y" literal
-    dup 0 < [ neg SAR ] [ SHL ] if
-    ! Mask off low bits
-    "x" operand %untag
-] T{ template
-    { input { { f "x" } { small-tagged "y" } } }
-    { output { "x" } }
-} define-intrinsic
-
-: fixnum-jump ( op inputs -- pair )
-    >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
-
-: fixnum-value-jump ( op -- pair )
-    { { f "x" } { small-tagged "y" } } fixnum-jump ;
-
-: fixnum-register-jump ( op -- pair )
-    { { f "x" } { f "y" } } fixnum-jump ;
-
-: define-fixnum-jump ( word op -- )
-    [ fixnum-value-jump ] [ fixnum-register-jump ] bi
-    2array define-if-intrinsics ;
-
-{
-    { fixnum< JL }
-    { fixnum<= JLE }
-    { fixnum> JG }
-    { fixnum>= JGE }
-    { eq? JE }
-} [
-    first2 define-fixnum-jump
-] each
-
-\ bignum>fixnum [
-    "nonzero" define-label
-    "positive" define-label
-    "end" define-label
-    "x" operand %untag
-    "y" operand "x" operand cell [+] MOV
-     ! if the length is 1, its just the sign and nothing else,
-     ! so output 0
-    "y" operand 1 tag-fixnum CMP
-    "nonzero" get JNE
-    "y" operand 0 MOV
-    "end" get JMP
-    "nonzero" resolve-label
-    ! load the value
-    "y" operand "x" operand 3 cells [+] MOV
-    ! load the sign
-    "x" operand "x" operand 2 cells [+] MOV
-    ! is the sign negative?
-    "x" operand 0 CMP
-    "positive" get JE
-    "y" operand -1 IMUL2
-    "positive" resolve-label
-    "y" operand 3 SHL
-    "end" resolve-label
-] T{ template
-    { input { { f "x" } } }
-    { scratch { { f "y" } } }
-    { clobber { "x" } }
-    { output { "y" } }
-} define-intrinsic
-
-! User environment
-: %userenv ( -- )
-    "x" operand 0 MOV
-    "userenv" f rc-absolute-cell rel-dlsym
-    "n" operand fixnum>slot@
-    "n" operand "x" operand ADD ;
-
-\ getenv [
-    %userenv  "n" operand dup [] MOV
-] T{ template
-    { input { { f "n" } } }
-    { scratch { { f "x" } } }
-    { output { "n" } }
-} define-intrinsic
-
-\ setenv [
-    %userenv  "n" operand [] "val" operand MOV
-] T{ template
-    { input { { f "val" } { f "n" } } }
-    { scratch { { f "x" } } }
-    { clobber { "n" } }
-} define-intrinsic
-
-! Alien intrinsics
-
-! Sometimes, we need to do stuff with operands which are
-! less than the word size. Instead of teaching the register
-! allocator about the different sized registers, with all
-! the complexity this entails, we just push/pop a register
-! which is guaranteed to be unused (the tempreg)
-: small-reg cell 8 = RDX EDX ? ; inline
-: small-reg-8 DL ; inline
-: small-reg-16 DX ; inline
-: small-reg-32 EDX ; inline
-
-: %prepare-alien-accessor ( -- )
-    "offset" operand %untag-fixnum
-    "offset" operand "alien" operand ADD ;
-
-:: (%alien-integer-get) ( reg quot -- )
-    reg "offset" operand [] MOV
-    "value" operand reg quot call ; inline
-
-: %alien-integer-get ( reg quot -- )
-    %prepare-alien-accessor
-    "value" operand small-reg = [
-        (%alien-integer-get)
-    ] [
-        small-reg PUSH
-        (%alien-integer-get)
-        small-reg POP
-    ] if
-    "value" operand %tag-fixnum ; inline
-
-: alien-integer-get-template
-    T{ template
-        { input {
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { scratch { { f "value" } } }
-        { output { "value" } }
-        { clobber { "offset" } }
-    } ;
-
-: define-getter ( word reg quot -- )
-    '[ _ _ %alien-integer-get ]
-    alien-integer-get-template
-    define-intrinsic ;
-
-: define-unsigned-getter ( word reg -- )
-    [ MOVZX ] define-getter ;
-
-: define-signed-getter ( word reg -- )
-    [ MOVSX ] define-getter ;
-
-: %alien-integer-set ( reg -- )
-    "value" operand "offset" operand = [
-        "value" operand %untag-fixnum
-    ] unless
-    %prepare-alien-accessor
-    small-reg "offset" operand = [
-        "value" operand "offset" operand XCHG
-        "value" operand [] swap MOV
-    ] [
-        small-reg PUSH
-        small-reg "value" operand MOV
-        "offset" operand [] swap MOV
-        small-reg POP
-    ] if ; inline
-
-: alien-integer-set-template
-    T{ template
-        { input {
-            { f "value" fixnum }
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { clobber { "value" "offset" } }
-    } ;
-
-: define-setter ( word reg -- )
-    '[ _ %alien-integer-set ]
-    alien-integer-set-template
-    define-intrinsic ;
-
-\ alien-unsigned-1 small-reg-8 define-unsigned-getter
-\ set-alien-unsigned-1 small-reg-8 define-setter
-
-\ alien-signed-1 small-reg-8 define-signed-getter
-\ set-alien-signed-1 small-reg-8 define-setter
-
-\ alien-unsigned-2 small-reg-16 define-unsigned-getter
-\ set-alien-unsigned-2 small-reg-16 define-setter
-
-\ alien-signed-2 small-reg-16 define-signed-getter
-\ set-alien-signed-2 small-reg-16 define-setter
-
-\ alien-cell [
-    %prepare-alien-accessor
-    "value" operand "offset" operand [] MOV
-] T{ template
-    { input {
-        { unboxed-c-ptr "alien" c-ptr }
-        { f "offset" fixnum }
-    } }
-    { scratch { { unboxed-alien "value" } } }
-    { output { "value" } }
-    { clobber { "offset" } }
-} define-intrinsic
-
-\ set-alien-cell [
-    %prepare-alien-accessor
-    "offset" operand [] "value" operand MOV
-] T{ template
-    { input {
-        { unboxed-c-ptr "value" pinned-c-ptr }
-        { unboxed-c-ptr "alien" c-ptr }
-        { f "offset" fixnum }
-    } }
-    { clobber { "offset" } }
-} define-intrinsic
diff --git a/basis/cpu/x86/intrinsics/tags.txt b/basis/cpu/x86/intrinsics/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/basis/cpu/x86/intrinsics/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/basis/cpu/x86/sse2/authors.txt b/basis/cpu/x86/sse2/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/basis/cpu/x86/sse2/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/cpu/x86/sse2/sse2.factor b/basis/cpu/x86/sse2/sse2.factor
deleted file mode 100644
index 1f3090fcbd..0000000000
--- a/basis/cpu/x86/sse2/sse2.factor
+++ /dev/null
@@ -1,115 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays generic kernel
-kernel.private math math.private memory namespaces sequences
-words math.floats.private layouts quotations locals fry
-system compiler.constants compiler.codegen compiler.cfg.templates
-compiler.cfg.registers compiler.cfg.builder cpu.architecture
-cpu.x86.assembler cpu.x86.architecture cpu.x86.intrinsics ;
-IN: cpu.x86.sse2
-
-M: x86 %spill-float ( src n -- )
-    spill-float@ swap MOVSD ;
-
-M: x86 %reload-float ( dst n -- )
-    spill-float@ MOVSD ;
-
-M: x86 %copy-float MOVSD ;
-
-M:: x86 %box-float ( dst src temp -- )
-    dst 16 float float temp %allot
-    dst 8 float tag-number - [+] src MOVSD ;
-
-M: x86 %unbox-float ( dst src -- )
-    float-offset [+] MOVSD ;
-
-: define-float-op ( word op -- )
-    [ "x" operand "y" operand ] swap suffix T{ template
-        { input { { float "x" } { float "y" } } }
-        { output { "x" } }
-    } define-intrinsic ;
-
-{
-    { float+ ADDSD }
-    { float- SUBSD }
-    { float* MULSD }
-    { float/f DIVSD }
-} [
-    first2 define-float-op
-] each
-
-: define-float-jump ( word op -- )
-    [ "x" operand "y" operand UCOMISD ] swap suffix
-    { { float "x" } { float "y" } } define-if-intrinsic ;
-
-{
-    { float< JB }
-    { float<= JBE }
-    { float> JA }
-    { float>= JAE }
-    { float= JE }
-} [
-    first2 define-float-jump
-] each
-
-\ float>fixnum [
-    "out" operand "in" operand CVTTSD2SI
-    "out" operand tag-bits get SHL
-] T{ template
-    { input { { float "in" } } }
-    { scratch { { f "out" } } }
-    { output { "out" } }
-} define-intrinsic
-
-\ fixnum>float [
-    "in" operand %untag-fixnum
-    "out" operand "in" operand CVTSI2SD
-] T{ template
-    { input { { f "in" } } }
-    { scratch { { float "out" } } }
-    { output { "out" } }
-    { clobber { "in" } }
-} define-intrinsic
-
-: alien-float-get-template
-    T{ template
-        { input {
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { scratch { { float "value" } } }
-        { output { "value" } }
-        { clobber { "offset" } }
-    } ;
-
-: alien-float-set-template
-    T{ template
-        { input {
-            { float "value" float }
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { clobber { "offset" } }
-    } ;
-
-: define-float-getter ( word get-quot -- )
-    '[
-        %prepare-alien-accessor
-        "value" operand "offset" operand [] @
-    ]
-    alien-float-get-template
-    define-intrinsic ;
-
-: define-float-setter ( word set-quot -- )
-    '[
-        %prepare-alien-accessor
-        "offset" operand [] "value" operand @
-    ]
-    alien-float-set-template
-    define-intrinsic ;
-
-\ alien-double [ MOVSD ] define-float-getter
-\ set-alien-double [ MOVSD ] define-float-setter
-
-\ alien-float [ dupd MOVSS dup CVTSS2SD ] define-float-getter
-\ set-alien-float [ dup dup CVTSD2SS MOVSS ] define-float-setter
diff --git a/basis/cpu/x86/sse2/summary.txt b/basis/cpu/x86/sse2/summary.txt
deleted file mode 100644
index dd2d309b1e..0000000000
--- a/basis/cpu/x86/sse2/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-SSE2 floating point intrinsics for Pentium 4 and above
diff --git a/basis/cpu/x86/sse2/tags.txt b/basis/cpu/x86/sse2/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/basis/cpu/x86/sse2/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable

From 461a4ddd0a67ffda7bd89e7179bf85dea5880682 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 20 Oct 2008 05:56:39 -0500
Subject: [PATCH 043/318] Add SSE2 detection routine

---
 vm/cpu-x86.32.S | 11 +++++++++++
 1 file changed, 11 insertions(+)

diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S
index b1a3561974..1613579244 100644
--- a/vm/cpu-x86.32.S
+++ b/vm/cpu-x86.32.S
@@ -39,4 +39,15 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
 	add $12,%esp                       /* pop args from the stack */
 	ret                                /* return _with new stack_ */
 
+/* cpu.x86.32 calls this */
+DEF(bool,check_sse2,())
+	push %ebx
+	mov 1,%eax
+	cpuid
+	shr $26,%edx
+	and $1,%edx
+	pop %ebx
+	mov %edx,%eax
+	ret
+
 #include "cpu-x86.S"

From e92f795a7626f8668aaa4bb54b3d31f271c8bb80 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 20 Oct 2008 20:40:15 -0500
Subject: [PATCH 044/318] More work on intrinsics; memory allocation and slot
 access now expands correctly

---
 basis/compiler/cfg/builder/builder.factor     |   6 +-
 basis/compiler/cfg/builder/calls/calls.factor | 361 ------------------
 .../cfg/{builder => }/hats/hats.factor        |  21 +-
 .../cfg/instructions/instructions.factor      |   5 +-
 .../cfg/intrinsics/alien/alien.factor         | 109 ++++++
 .../cfg/intrinsics/allot/allot.factor         |  63 +++
 .../cfg/intrinsics/fixnum/fixnum.factor       |  63 +++
 .../cfg/intrinsics/float/float.factor         |  18 +
 .../compiler/cfg/intrinsics/intrinsics.factor | 137 +++++++
 .../cfg/intrinsics/slots/slots.factor         |  54 +++
 .../cfg/intrinsics/utilities/utilities.factor |   7 +
 .../cfg/linear-scan/linear-scan-tests.factor  |   1 -
 .../cfg/{builder => }/stacks/authors.txt      |   0
 .../cfg/{builder => }/stacks/stacks.factor    |  24 +-
 basis/compiler/intrinsics/intrinsics.factor   |  49 ---
 .../tree/finalization/finalization.factor     | 126 +-----
 basis/cpu/architecture/architecture.factor    |   2 +-
 basis/cpu/x86/32/32.factor                    |   2 +-
 basis/cpu/x86/64/64.factor                    |   2 +-
 .../cpu/x86/architecture/architecture.factor  |  12 +-
 20 files changed, 495 insertions(+), 567 deletions(-)
 delete mode 100644 basis/compiler/cfg/builder/calls/calls.factor
 rename basis/compiler/cfg/{builder => }/hats/hats.factor (78%)
 create mode 100644 basis/compiler/cfg/intrinsics/alien/alien.factor
 create mode 100644 basis/compiler/cfg/intrinsics/allot/allot.factor
 create mode 100644 basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
 create mode 100644 basis/compiler/cfg/intrinsics/float/float.factor
 create mode 100644 basis/compiler/cfg/intrinsics/intrinsics.factor
 create mode 100644 basis/compiler/cfg/intrinsics/slots/slots.factor
 create mode 100644 basis/compiler/cfg/intrinsics/utilities/utilities.factor
 rename basis/compiler/cfg/{builder => }/stacks/authors.txt (100%)
 rename basis/compiler/cfg/{builder => }/stacks/stacks.factor (91%)
 delete mode 100644 basis/compiler/intrinsics/intrinsics.factor

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 8ea182c108..bee7884e81 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -9,12 +9,12 @@ compiler.tree.builder
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.cfg
+compiler.cfg.hats
+compiler.cfg.stacks
 compiler.cfg.iterator
 compiler.cfg.registers
+compiler.cfg.intrinsics
 compiler.cfg.instructions
-compiler.cfg.builder.hats
-compiler.cfg.builder.calls
-compiler.cfg.builder.stacks
 compiler.alien ;
 IN: compiler.cfg.builder
 
diff --git a/basis/compiler/cfg/builder/calls/calls.factor b/basis/compiler/cfg/builder/calls/calls.factor
deleted file mode 100644
index 9337bb17cc..0000000000
--- a/basis/compiler/cfg/builder/calls/calls.factor
+++ /dev/null
@@ -1,361 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: qualified kernel words sequences layouts namespaces
-accessors fry arrays byte-arrays locals math combinators alien
-classes.algebra cpu.architecture compiler.tree.propagation.info
-compiler.cfg.registers
-compiler.cfg.instructions
-compiler.cfg.builder.hats
-compiler.cfg.builder.stacks ;
-QUALIFIED: compiler.intrinsics
-QUALIFIED: kernel.private
-QUALIFIED: slots.private
-QUALIFIED: math.private
-QUALIFIED: alien.accessors
-IN: compiler.cfg.builder.calls
-
-{
-    kernel.private:tag
-    math.private:fixnum+fast
-    math.private:fixnum-fast
-    math.private:fixnum-bitand
-    math.private:fixnum-bitor 
-    math.private:fixnum-bitxor
-    math.private:fixnum-shift-fast
-    math.private:fixnum-bitnot
-    math.private:fixnum*fast
-    math.private:fixnum< 
-    math.private:fixnum<=
-    math.private:fixnum>=
-    math.private:fixnum>
-    math.private:bignum>fixnum
-    math.private:fixnum>bignum
-    eq?
-    compiler.intrinsics:(slot)
-    compiler.intrinsics:(set-slot)
-    compiler.intrinsics:(tuple)
-    compiler.intrinsics:(array)
-    compiler.intrinsics:(byte-array)
-    compiler.intrinsics:(complex)
-    compiler.intrinsics:(ratio)
-    compiler.intrinsics:(wrapper)
-    compiler.intrinsics:(write-barrier)
-    alien.accessors:alien-unsigned-1
-    alien.accessors:set-alien-unsigned-1
-    alien.accessors:alien-signed-1
-    alien.accessors:set-alien-signed-1
-    alien.accessors:alien-unsigned-2
-    alien.accessors:set-alien-unsigned-2
-    alien.accessors:alien-signed-2
-    alien.accessors:set-alien-signed-2
-    alien.accessors:alien-cell
-    alien.accessors:set-alien-cell
-} [ t "intrinsic" set-word-prop ] each
-
-: enable-alien-4-intrinsics ( -- )
-    {
-        alien.accessors:alien-unsigned-4
-        alien.accessors:set-alien-unsigned-4
-        alien.accessors:alien-signed-4
-        alien.accessors:set-alien-signed-4
-    } [ t "intrinsic" set-word-prop ] each ;
-
-: enable-float-intrinsics ( -- )
-    {
-        math.private:float+
-        math.private:float-
-        math.private:float*
-        math.private:float/f
-        math.private:fixnum>float
-        math.private:float>fixnum
-        alien.accessors:alien-float
-        alien.accessors:set-alien-float
-        alien.accessors:alien-double
-        alien.accessors:set-alien-double
-    } [ t "intrinsic" set-word-prop ] each ;
-
-: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ;
-
-: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ;
-
-: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ;
-
-: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ;
-
-: emit-tag ( -- )
-    phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ;
-
-: (emit-slot) ( infos -- dst )
-    [ 2phantom-pop ] [ third literal>> ] bi*
-    ^^slot ;
-
-: (emit-slot-imm) ( infos -- dst )
-    1 phantom-drop
-    [ phantom-pop ^^offset>slot ]
-    [ [ second literal>> ] [ third literal>> ] bi ] bi*
-    ^^slot-imm ;
-
-: value-info-small-tagged? ( value-info -- ? )
-    dup literal?>> [ literal>> small-tagged? ] [ drop f ] if ;
-
-: emit-slot ( node -- )
-    node-input-infos
-    dup second value-info-small-tagged?
-    [ (emit-slot-imm) ] [ (emit-slot) ] if
-    phantom-push ;
-
-: (emit-set-slot) ( infos -- )
-    [ 3phantom-pop ] [ fourth literal>> ] bi*
-    ^^set-slot ;
-
-: (emit-set-slot-imm) ( infos -- )
-    1 phantom-drop
-    [ 2phantom-pop ^^offset>slot ]
-    [ [ third literal>> ] [ fourth literal>> ] bi ] bi*
-    ##set-slot-imm ;
-
-: emit-set-slot ( node -- )
-    1 phantom-drop
-    node-input-infos
-    dup third value-info-small-tagged?
-    [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if ;
-
-: (emit-fixnum-imm-op) ( infos insn -- dst )
-    1 phantom-drop
-    [ phantom-pop ] [ second literal>> tag-fixnum ] [ ] tri*
-    call ; inline
-
-: (emit-fixnum-op) ( insn -- dst )
-    [ 2phantom-pop ] dip call ; inline
-
-:: emit-fixnum-op ( node insn imm-insn -- )
-    [let | infos [ node node-input-infos ] |
-        infos second value-info-small-tagged?
-        [ infos imm-insn (emit-fixnum-imm-op) ]
-        [ insn (emit-fixnum-op) ]
-        if
-        phantom-push
-    ] ; inline
-
-: emit-primitive ( node -- )
-    word>> ##simple-stack-frame ##call ;
-
-: emit-fixnum-shift-fast ( node -- )
-    dup node-input-infos dup second value-info-small-tagged? [
-        nip
-        [ 1 phantom-drop phantom-pop ] dip
-        second literal>> dup sgn {
-            { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
-            {  0 [ drop ] }
-            {  1 [ ^^shl-imm ] }
-        } case
-        phantom-push
-    ] [ drop emit-primitive ] if ;
-
-: emit-fixnum-bitnot ( -- )
-    phantom-pop ^^not tag-mask get ^^xor-imm phantom-push ;
-
-: (emit-fixnum*fast) ( -- dst )
-    2phantom-pop ^^untag-fixnum ^^mul ;
-
-: (emit-fixnum*fast-imm) ( infos -- dst )
-    1 phantom-drop
-    [ phantom-pop ] [ second literal>> ] bi* ^^mul-imm ;
-
-: emit-fixnum*fast ( node -- )
-    node-input-infos
-    dup second value-info-small-tagged?
-    [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
-    phantom-push ;
-
-: emit-fixnum-comparison ( node cc -- )
-    [ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
-    emit-fixnum-op ;
-
-: emit-bignum>fixnum ( -- )
-    phantom-pop ^^bignum>integer ^^tag-fixnum phantom-push ;
-
-: emit-fixnum>bignum ( -- )
-    phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ;
-
-: emit-float-op ( insn -- )
-    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float
-    phantom-push ; inline
-
-: emit-float-comparison ( cc -- )
-    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip ^^compare-float
-    phantom-push ; inline
-
-: emit-float>fixnum ( -- )
-    phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ;
-
-: emit-fixnum>float ( -- )
-    phantom-pop ^^untag-fixnum ^^integer>float ^^box-float phantom-push ;
-
-: pop-literal ( node -- n )
-    1 phantom-drop dup in-d>> first node-value-info literal>> ; 
-
-: emit-allot ( size type tag -- )
-    ^^allot [ fresh-object ] [ phantom-push ] bi ;
-
-: emit-write-barrier ( -- )
-    phantom-pop dup fresh-object? [ drop ] [ ^^write-barrier ] if ;
-
-: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
-    1 phantom-drop [ phantom-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
-
-: (prepare-alien-accessor) ( class -- offset-vreg )
-    [ 2phantom-pop ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
-
-: prepare-alien-accessor ( infos -- offset-vreg )
-    <reversed> [ second class>> ] [ first ] bi
-    dup value-info-small-tagged? [
-        1 phantom-drop
-        literal>> (prepare-alien-accessor-imm)
-    ] [ drop (prepare-alien-accessor) ] if ;
-
-:: inline-alien ( node quot test -- )
-    [let | infos [ node node-input-infos ] |
-        infos test call
-        [ infos prepare-alien-accessor quot call ]
-        [ node emit-primitive ]
-        if
-    ] ; inline
-
-: inline-alien-getter? ( infos -- ? )
-    [ first class>> c-ptr class<= ]
-    [ second class>> fixnum class<= ]
-    bi and ;
-
-: inline-alien-getter ( node quot -- )
-    '[ @ phantom-push ]
-    [ inline-alien-getter? ] inline-alien ; inline
-
-: inline-alien-setter? ( infos class -- ? )
-    '[ first class>> _ class<= ]
-    [ second class>> c-ptr class<= ]
-    [ third class>> fixnum class<= ]
-    tri and and ;
-
-: inline-alien-integer-setter ( node quot -- )
-    '[ phantom-pop ^^untag-fixnum @ ]
-    [ fixnum inline-alien-setter? ]
-    inline-alien ; inline
-
-: inline-alien-cell-setter ( node quot -- )
-    [ dup node-input-infos first class>> ] dip
-    '[ phantom-pop _ ^^unbox-c-ptr @ ]
-    [ pinned-c-ptr inline-alien-setter? ]
-    inline-alien ; inline
-
-: inline-alien-float-setter ( node quot -- )
-    '[ phantom-pop ^^unbox-float @ ]
-    [ 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
-    ] inline-alien-getter ;
-
-: emit-alien-signed-getter ( node n -- )
-    '[
-        _ {
-            { 1 [ ^^alien-signed-1 ] }
-            { 2 [ ^^alien-signed-2 ] }
-            { 4 [ ^^alien-signed-4 ] }
-        } case ^^tag-fixnum
-    ] 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 reg-class -- )
-    '[
-        _ {
-            { single-float-regs [ ^^alien-float ] }
-            { double-float-regs [ ^^alien-double ] }
-        } case ^^box-float
-    ] inline-alien-getter ;
-
-: emit-alien-float-setter ( node reg-class -- )
-    '[
-        _ {
-            { single-float-regs [ ##set-alien-float ] }
-            { double-float-regs [ ##set-alien-double ] }
-        } case
-    ] inline-alien-float-setter ;
-
-: emit-intrinsic ( node word -- )
-    {
-        { \ kernel.private:tag [ drop emit-tag ] }
-        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
-        { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
-        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
-        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
-        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
-        { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
-        { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
-        { \ math.private:fixnum*fast [ emit-fixnum*fast ] }
-        { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
-        { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
-        { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
-        { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
-        { \ eq? [ cc= emit-fixnum-comparison ] }
-        { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
-        { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
-        { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
-        { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
-        { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
-        { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
-        { \ math.private:float< [ drop cc< emit-float-comparison ] }
-        { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
-        { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
-        { \ math.private:float> [ drop cc> emit-float-comparison ] }
-        { \ math.private:float= [ drop cc> emit-float-comparison ] }
-        { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
-        { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
-        { \ compiler.intrinsics:(slot) [ emit-slot ] }
-        { \ compiler.intrinsics:(set-slot) [ emit-set-slot ] }
-        { \ compiler.intrinsics:(tuple) [ pop-literal 2 + cells tuple tuple emit-allot ] }
-        { \ compiler.intrinsics:(array) [ pop-literal 2 + cells array object emit-allot ] }
-        { \ compiler.intrinsics:(byte-array) [ pop-literal 2 cells + byte-array object emit-allot ] }
-        { \ compiler.intrinsics:(complex) [ drop 3 cells complex complex emit-allot ] }
-        { \ compiler.intrinsics:(ratio) [ drop 3 cells ratio ratio emit-allot ] }
-        { \ compiler.intrinsics:(wrapper) [ drop 2 cells wrapper object emit-allot ] }
-        { \ compiler.intrinsics:(write-barrier) [ drop emit-write-barrier ] }
-        { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
-        { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
-        { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
-        { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
-        { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
-        { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
-        { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
-        { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
-        { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
-        { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
-        { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
-        { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
-        { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
-        { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
-        { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
-        { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
-        { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
-        { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
-    } case ;
diff --git a/basis/compiler/cfg/builder/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
similarity index 78%
rename from basis/compiler/cfg/builder/hats/hats.factor
rename to basis/compiler/cfg/hats/hats.factor
index d8e4dc613c..77b10b5e9f 100644
--- a/basis/compiler/cfg/builder/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -1,8 +1,16 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel layouts cpu.architecture compiler.cfg.registers
+USING: arrays byte-arrays kernel layouts math namespaces
+sequences classes.tuple cpu.architecture compiler.cfg.registers
 compiler.cfg.instructions ;
-IN: compiler.cfg.builder.hats
+IN: compiler.cfg.hats
+
+! Operands holding pointers to freshly-allocated objects which
+! are guaranteed to be in the nursery
+SYMBOL: fresh-objects
+
+: fresh-object ( vreg/t -- ) fresh-objects get push ;
+: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
 
 : i int-regs next-vreg ; inline
 : ^^i i dup ; inline
@@ -45,8 +53,11 @@ IN: compiler.cfg.builder.hats
 : ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
 : ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
 : ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
-: ^^allot ( size type tag -- dst ) ^^i3 i ##allot ; inline
-: ^^write-barrier ( src -- ) i i ##write-barrier ; inline
+: ^^allot ( size class -- dst ) ^^i2 i ##allot dup fresh-object ; inline
+: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
+: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
+: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
+: ^^write-barrier ( src -- ) dup fresh-object? [ drop ] [ i i ##write-barrier ] if ; inline
 : ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
 : ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
 : ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
@@ -65,3 +76,5 @@ IN: compiler.cfg.builder.hats
 : ^^compare-imm ( src1 src2 -- dst ) ^^i2 ##compare-imm ; inline
 : ^^compare-float ( src1 src2 -- dst ) ^^i2 ##compare-float ; inline
 : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
+: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
+: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index da79782aaf..17b9728243 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -88,6 +88,9 @@ INSN: ##shr-imm < ##binary-imm ;
 INSN: ##sar-imm < ##binary-imm ;
 INSN: ##not < ##unary ;
 
+: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
+: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
+
 ! Bignum/integer conversion
 INSN: ##integer>bignum < ##unary/temp ;
 INSN: ##bignum>integer < ##unary/temp ;
@@ -141,7 +144,7 @@ INSN: ##set-alien-float < ##alien-setter ;
 INSN: ##set-alien-double < ##alien-setter ;
 
 ! Memory allocation
-INSN: ##allot < ##flushable size type tag { temp vreg } ;
+INSN: ##allot < ##flushable size class { temp vreg } ;
 INSN: ##write-barrier < ##effect card# table ;
 INSN: ##gc ;
 
diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor
new file mode 100644
index 0000000000..9ab013f04b
--- /dev/null
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@@ -0,0 +1,109 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences alien math classes.algebra
+fry locals combinators cpu.architecture
+compiler.tree.propagation.info
+compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
+compiler.cfg.intrinsics.utilities ;
+IN: compiler.cfg.intrinsics.alien
+
+: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
+    1 phantom-drop [ phantom-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
+
+: (prepare-alien-accessor) ( class -- offset-vreg )
+    [ 2phantom-pop ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+
+: prepare-alien-accessor ( infos -- offset-vreg )
+    <reversed> [ second class>> ] [ first ] bi
+    dup value-info-small-tagged? [
+        1 phantom-drop
+        literal>> (prepare-alien-accessor-imm)
+    ] [ drop (prepare-alien-accessor) ] if ;
+
+:: inline-alien ( node quot test -- )
+    [let | infos [ node node-input-infos ] |
+        infos test call
+        [ infos prepare-alien-accessor quot call ]
+        [ node emit-primitive ]
+        if
+    ] ; inline
+
+: inline-alien-getter? ( infos -- ? )
+    [ first class>> c-ptr class<= ]
+    [ second class>> fixnum class<= ]
+    bi and ;
+
+: inline-alien-getter ( node quot -- )
+    '[ @ phantom-push ]
+    [ inline-alien-getter? ] inline-alien ; inline
+
+: inline-alien-setter? ( infos class -- ? )
+    '[ first class>> _ class<= ]
+    [ second class>> c-ptr class<= ]
+    [ third class>> fixnum class<= ]
+    tri and and ;
+
+: inline-alien-integer-setter ( node quot -- )
+    '[ phantom-pop ^^untag-fixnum @ ]
+    [ fixnum inline-alien-setter? ]
+    inline-alien ; inline
+
+: inline-alien-cell-setter ( node quot -- )
+    [ dup node-input-infos first class>> ] dip
+    '[ phantom-pop _ ^^unbox-c-ptr @ ]
+    [ pinned-c-ptr inline-alien-setter? ]
+    inline-alien ; inline
+
+: inline-alien-float-setter ( node quot -- )
+    '[ phantom-pop ^^unbox-float @ ]
+    [ 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
+    ] inline-alien-getter ;
+
+: emit-alien-signed-getter ( node n -- )
+    '[
+        _ {
+            { 1 [ ^^alien-signed-1 ] }
+            { 2 [ ^^alien-signed-2 ] }
+            { 4 [ ^^alien-signed-4 ] }
+        } case ^^tag-fixnum
+    ] 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 reg-class -- )
+    '[
+        _ {
+            { single-float-regs [ ^^alien-float ] }
+            { double-float-regs [ ^^alien-double ] }
+        } case ^^box-float
+    ] inline-alien-getter ;
+
+: emit-alien-float-setter ( node reg-class -- )
+    '[
+        _ {
+            { single-float-regs [ ##set-alien-float ] }
+            { double-float-regs [ ##set-alien-double ] }
+        } case
+    ] inline-alien-float-setter ;
diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor
new file mode 100644
index 0000000000..a371f071cc
--- /dev/null
+++ b/basis/compiler/cfg/intrinsics/allot/allot.factor
@@ -0,0 +1,63 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.order sequences accessors arrays
+byte-arrays layouts classes.tuple.private fry locals
+compiler.tree.propagation.info compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.stacks ;
+IN: compiler.cfg.intrinsics.allot
+
+: ##set-slots ( regs obj class -- )
+    '[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ;
+
+: emit-simple-allot ( node -- )
+    [ in-d>> length ] [ node-output-infos first class>> ] bi
+    [ drop phantom-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
+    [ ##set-slots ] [ [ drop ] [ phantom-push ] [ drop ] tri* ] 3bi ;
+
+: tuple-slot-regs ( layout -- vregs )
+    [ size>> phantom-load ] [ ^^load-literal ] bi prefix ;
+
+:: emit-<tuple-boa> ( node -- )
+    [let | layout [ node node-input-infos peek literal>> ] |
+        layout tuple-layout? [
+            1 phantom-drop
+            layout tuple-slot-regs
+            layout size>> ^^allot-tuple
+            tuple ##set-slots
+        ] [ node emit-primitive ] if
+    ] ;
+
+: store-initial-element ( elt reg len -- )
+    [ 2 + object tag-number ##set-slot-imm ] with with each ;
+
+: expand-<array>? ( obj -- ? )
+    dup integer? [ 0 8 between? ] [ drop f ] if ;
+
+:: emit-<array> ( node -- )
+    [let | len [ node node-input-infos first literal>> ] |
+        len expand-<array>? [
+            [let | elt [ phantom-pop ]
+                   reg [ len ^^allot-array ] |
+                1 phantom-drop
+                elt reg len store-initial-element
+                reg phantom-push
+            ]
+        ] [ node emit-primitive ] if
+    ] ;
+
+: expand-<byte-array>? ( obj -- ? )
+    dup integer? [ 0 32 between? ] [ drop f ] if ;
+
+: bytes>cells ( m -- n ) cell align cell /i ;
+
+:: emit-<byte-array> ( node -- )
+    [let | len [ node node-input-infos first literal>> ] |
+        len expand-<byte-array>? [
+            [let | elt [ 0 ^^load-literal ]
+                   reg [ len ^^allot-byte-array ] |
+                1 phantom-drop
+                elt reg len bytes>cells store-initial-element
+                reg phantom-push
+            ]
+        ] [ node emit-primitive ] if
+    ] ;
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
new file mode 100644
index 0000000000..7791edb727
--- /dev/null
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -0,0 +1,63 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences accessors layouts kernel math namespaces
+combinators fry locals
+compiler.tree.propagation.info
+compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.intrinsics.utilities ;
+IN: compiler.cfg.intrinsics.fixnum
+
+: (emit-fixnum-imm-op) ( infos insn -- dst )
+    1 phantom-drop
+    [ phantom-pop ] [ second literal>> tag-fixnum ] [ ] tri*
+    call ; inline
+
+: (emit-fixnum-op) ( insn -- dst )
+    [ 2phantom-pop ] dip call ; inline
+
+:: emit-fixnum-op ( node insn imm-insn -- )
+    [let | infos [ node node-input-infos ] |
+        infos second value-info-small-tagged?
+        [ infos imm-insn (emit-fixnum-imm-op) ]
+        [ insn (emit-fixnum-op) ]
+        if
+        phantom-push
+    ] ; inline
+
+: emit-fixnum-shift-fast ( node -- )
+    dup node-input-infos dup second value-info-small-tagged? [
+        nip
+        [ 1 phantom-drop phantom-pop ] dip
+        second literal>> dup sgn {
+            { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
+            {  0 [ drop ] }
+            {  1 [ ^^shl-imm ] }
+        } case
+        phantom-push
+    ] [ drop emit-primitive ] if ;
+
+: emit-fixnum-bitnot ( -- )
+    phantom-pop ^^not tag-mask get ^^xor-imm phantom-push ;
+
+: (emit-fixnum*fast) ( -- dst )
+    2phantom-pop ^^untag-fixnum ^^mul ;
+
+: (emit-fixnum*fast-imm) ( infos -- dst )
+    1 phantom-drop
+    [ phantom-pop ] [ second literal>> ] bi* ^^mul-imm ;
+
+: emit-fixnum*fast ( node -- )
+    node-input-infos
+    dup second value-info-small-tagged?
+    [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
+    phantom-push ;
+
+: emit-fixnum-comparison ( node cc -- )
+    [ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
+    emit-fixnum-op ;
+
+: emit-bignum>fixnum ( -- )
+    phantom-pop ^^bignum>integer ^^tag-fixnum phantom-push ;
+
+: emit-fixnum>bignum ( -- )
+    phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ;
diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor
new file mode 100644
index 0000000000..24bb56d237
--- /dev/null
+++ b/basis/compiler/cfg/intrinsics/float/float.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel compiler.cfg.stacks compiler.cfg.hats ;
+IN: compiler.cfg.intrinsics.float
+
+: emit-float-op ( insn -- )
+    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float
+    phantom-push ; inline
+
+: emit-float-comparison ( cc -- )
+    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip ^^compare-float
+    phantom-push ; inline
+
+: emit-float>fixnum ( -- )
+    phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ;
+
+: emit-fixnum>float ( -- )
+    phantom-pop ^^untag-fixnum ^^integer>float ^^box-float phantom-push ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
new file mode 100644
index 0000000000..0774eff335
--- /dev/null
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -0,0 +1,137 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: qualified kernel words sequences layouts namespaces
+accessors fry arrays byte-arrays locals math math.order
+combinators alien classes.algebra cpu.architecture
+compiler.tree.propagation.info
+compiler.cfg.hats
+compiler.cfg.stacks
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.intrinsics.alien
+compiler.cfg.intrinsics.allot
+compiler.cfg.intrinsics.fixnum
+compiler.cfg.intrinsics.float
+compiler.cfg.intrinsics.slots ;
+QUALIFIED: kernel.private
+QUALIFIED: slots.private
+QUALIFIED: classes.tuple.private
+QUALIFIED: math.private
+QUALIFIED: alien.accessors
+IN: compiler.cfg.intrinsics
+
+{
+    kernel.private:tag
+    math.private:fixnum+fast
+    math.private:fixnum-fast
+    math.private:fixnum-bitand
+    math.private:fixnum-bitor 
+    math.private:fixnum-bitxor
+    math.private:fixnum-shift-fast
+    math.private:fixnum-bitnot
+    math.private:fixnum*fast
+    math.private:fixnum< 
+    math.private:fixnum<=
+    math.private:fixnum>=
+    math.private:fixnum>
+    math.private:bignum>fixnum
+    math.private:fixnum>bignum
+    eq?
+    slots.private:slot
+    slots.private:set-slot
+    classes.tuple.private:<tuple-boa>
+    <array>
+    <byte-array>
+    math.private:<complex>
+    math.private:<ratio>
+    <wrapper>
+    alien.accessors:alien-unsigned-1
+    alien.accessors:set-alien-unsigned-1
+    alien.accessors:alien-signed-1
+    alien.accessors:set-alien-signed-1
+    alien.accessors:alien-unsigned-2
+    alien.accessors:set-alien-unsigned-2
+    alien.accessors:alien-signed-2
+    alien.accessors:set-alien-signed-2
+    alien.accessors:alien-cell
+    alien.accessors:set-alien-cell
+} [ t "intrinsic" set-word-prop ] each
+
+: enable-alien-4-intrinsics ( -- )
+    {
+        alien.accessors:alien-unsigned-4
+        alien.accessors:set-alien-unsigned-4
+        alien.accessors:alien-signed-4
+        alien.accessors:set-alien-signed-4
+    } [ t "intrinsic" set-word-prop ] each ;
+
+: enable-float-intrinsics ( -- )
+    {
+        math.private:float+
+        math.private:float-
+        math.private:float*
+        math.private:float/f
+        math.private:fixnum>float
+        math.private:float>fixnum
+        alien.accessors:alien-float
+        alien.accessors:set-alien-float
+        alien.accessors:alien-double
+        alien.accessors:set-alien-double
+    } [ t "intrinsic" set-word-prop ] each ;
+
+: emit-intrinsic ( node word -- )
+    {
+        { \ kernel.private:tag [ drop emit-tag ] }
+        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
+        { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+        { \ math.private:fixnum*fast [ emit-fixnum*fast ] }
+        { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
+        { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
+        { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
+        { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
+        { \ eq? [ cc= emit-fixnum-comparison ] }
+        { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
+        { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
+        { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+        { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+        { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+        { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+        { \ math.private:float< [ drop cc< emit-float-comparison ] }
+        { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
+        { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
+        { \ math.private:float> [ drop cc> emit-float-comparison ] }
+        { \ math.private:float= [ drop cc> emit-float-comparison ] }
+        { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
+        { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
+        { \ slots.private:slot [ emit-slot ] }
+        { \ slots.private:set-slot [ emit-set-slot ] }
+        { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
+        { \ <array> [ emit-<array> ] }
+        { \ <byte-array> [ emit-<byte-array> ] }
+        { \ math.private:<complex> [ emit-simple-allot ] }
+        { \ math.private:<ratio> [ emit-simple-allot ] }
+        { \ <wrapper> [ emit-simple-allot ] }
+        { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+        { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+        { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
+        { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
+    } case ;
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
new file mode 100644
index 0000000000..d2e2e95d0d
--- /dev/null
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -0,0 +1,54 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: layouts namespaces kernel accessors sequences
+classes.algebra compiler.tree.propagation.info
+compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.intrinsics.utilities ;
+IN: compiler.cfg.intrinsics.slots
+
+: emit-tag ( -- )
+    phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ;
+
+: value-tag ( info -- n ) class>> class-tag ; inline
+
+: (emit-slot) ( infos -- dst )
+    [ 2phantom-pop ] [ first value-tag ] bi*
+    ^^slot ;
+
+: (emit-slot-imm) ( infos -- dst )
+    1 phantom-drop
+    [ phantom-pop ^^offset>slot ]
+    [ [ second literal>> ] [ first value-tag ] bi ] bi*
+    ^^slot-imm ;
+
+: emit-slot ( node -- )
+    dup node-input-infos
+    dup first value-tag [
+        nip
+        dup second value-info-small-tagged?
+        [ (emit-slot-imm) ] [ (emit-slot) ] if
+        phantom-push
+    ] [ drop emit-primitive ] if ;
+
+: (emit-set-slot) ( infos -- obj-reg )
+    [ 3phantom-pop [ tuck ] dip ^^offset>slot ]
+    [ second value-tag ]
+    bi* ^^set-slot ;
+
+: (emit-set-slot-imm) ( infos -- obj-reg )
+    1 phantom-drop
+    [ 2phantom-pop tuck ]
+    [ [ third literal>> ] [ second value-tag ] bi ] bi*
+    ##set-slot-imm ;
+
+: emit-set-slot ( node -- )
+    dup node-input-infos
+    dup second value-tag [
+        nip
+        1 phantom-drop
+        [
+            dup third value-info-small-tagged?
+            [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
+        ] [ first class>> immediate class<= ] bi
+        [ drop ] [ ^^write-barrier ] if
+    ] [ drop emit-primitive ] if ;
diff --git a/basis/compiler/cfg/intrinsics/utilities/utilities.factor b/basis/compiler/cfg/intrinsics/utilities/utilities.factor
new file mode 100644
index 0000000000..5540e3316a
--- /dev/null
+++ b/basis/compiler/cfg/intrinsics/utilities/utilities.factor
@@ -0,0 +1,7 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math layouts cpu.architecture ;
+IN: compiler.cfg.intrinsics.utilities
+
+: value-info-small-tagged? ( value-info -- ? )
+    literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 88d7bcdbcf..1eea66f523 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -272,7 +272,6 @@ USING: math.private compiler.cfg.debugger ;
         T{ vreg f int-regs 1 }
         40
         array
-        object
         T{ vreg f int-regs 2 }
         f
     } clone
diff --git a/basis/compiler/cfg/builder/stacks/authors.txt b/basis/compiler/cfg/stacks/authors.txt
similarity index 100%
rename from basis/compiler/cfg/builder/stacks/authors.txt
rename to basis/compiler/cfg/stacks/authors.txt
diff --git a/basis/compiler/cfg/builder/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
similarity index 91%
rename from basis/compiler/cfg/builder/stacks/stacks.factor
rename to basis/compiler/cfg/stacks/stacks.factor
index e1119e18d6..73261e0e42 100755
--- a/basis/compiler/cfg/builder/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -6,25 +6,14 @@ quotations sequences system vectors words effects alien
 byte-arrays accessors sets math.order
 combinators.short-circuit cpu.architecture
 compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.builder.hats ;
-IN: compiler.cfg.builder.stacks
+compiler.cfg.hats ;
+IN: compiler.cfg.stacks
 
 ! Converting stack operations into register operations, while
 ! doing a bit of optimization along the way.
-PREDICATE: small-slot < integer cells small-enough? ;
-
-PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
-
-! Operands holding pointers to freshly-allocated objects which
-! are guaranteed to be in the nursery
-SYMBOL: fresh-objects
-
-: fresh-object ( vreg/t -- ) fresh-objects get push ;
-
-: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
 
 ! A compile-time stack
-TUPLE: phantom-stack height stack ;
+TUPLE: phantom-stack { height integer } { stack vector } ;
 
 M: phantom-stack clone
     call-next-method [ clone ] change-stack ;
@@ -32,11 +21,11 @@ M: phantom-stack clone
 GENERIC: finalize-height ( stack -- )
 
 : new-phantom-stack ( class -- stack )
-    >r 0 V{ } clone r> boa ; inline
+    new V{ } clone >>stack ; inline
 
 : (loc) ( m stack -- n )
     #! Utility for methods on <loc>
-    height>> - ;
+    height>> - ; inline
 
 : (finalize-height) ( stack word -- )
     #! We consolidate multiple stack height changes until the
@@ -207,3 +196,6 @@ M: loc lazy-store
 
 : 3phantom-pop ( -- vreg1 vreg2 vreg3 )
     3 phantom-load first3 ;
+
+: emit-primitive ( node -- )
+    finalize-phantoms word>> ##simple-stack-frame ##call ;
diff --git a/basis/compiler/intrinsics/intrinsics.factor b/basis/compiler/intrinsics/intrinsics.factor
deleted file mode 100644
index 2ce01d6659..0000000000
--- a/basis/compiler/intrinsics/intrinsics.factor
+++ /dev/null
@@ -1,49 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes.tuple classes.tuple.private math arrays 
-byte-arrays words stack-checker.known-words ;
-IN: compiler.intrinsics
-
-ERROR: missing-intrinsic ;
-
-: (tuple) ( n -- tuple ) missing-intrinsic ;
-
-\ (tuple) { tuple-layout } { tuple } define-primitive
-\ (tuple) make-flushable
-
-: (array) ( n -- array ) missing-intrinsic ;
-
-\ (array) { integer } { array } define-primitive
-\ (array) make-flushable
-
-: (byte-array) ( n -- byte-array ) missing-intrinsic ;
-
-\ (byte-array) { integer } { byte-array } define-primitive
-\ (byte-array) make-flushable
-
-: (ratio) ( -- ratio ) missing-intrinsic ;
-
-\ (ratio) { } { ratio } define-primitive
-\ (ratio) make-flushable
-
-: (complex) ( -- complex ) missing-intrinsic ;
-
-\ (complex) { } { complex } define-primitive
-\ (complex) make-flushable
-
-: (wrapper) ( -- wrapper ) missing-intrinsic ;
-
-\ (wrapper) { } { wrapper } define-primitive
-\ (wrapper) make-flushable
-
-: (slot) ( obj n tag# -- val ) missing-intrinsic ;
-
-\ (slot) { object fixnum fixnum } { object } define-primitive
-
-: (set-slot) ( val obj n tag# -- ) missing-intrinsic ;
-
-\ (set-slot) { object object fixnum fixnum } { } define-primitive
-
-: (write-barrier) ( obj -- ) missing-intrinsic ;
-
-\ (write-barrier) { object } { } define-primitive
diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor
index 5b09cfab63..49f2eb0281 100644
--- a/basis/compiler/tree/finalization/finalization.factor
+++ b/basis/compiler/tree/finalization/finalization.factor
@@ -1,10 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays accessors sequences sequences.private words
-fry namespaces make math math.private math.order memoize
-classes.builtin classes.tuple.private classes.algebra
-slots.private combinators layouts byte-arrays alien.accessors
-compiler.intrinsics
+USING: kernel accessors sequences words memoize classes.builtin
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -15,7 +11,7 @@ IN: compiler.tree.finalization
 ! See the comment in compiler.tree.late-optimizations.
 
 ! This pass runs after propagation, so that it can expand
-! built-in type predicates and memory allocation; these cannot
+! built-in type predicates; these cannot
 ! be expanded before propagation since we need to see 'fixnum?'
 ! instead of 'tag 0 eq?' and so on, for semantic reasoning.
 ! We also delete empty stack shuffles and copies to facilitate
@@ -43,123 +39,7 @@ MEMO: builtin-predicate-expansion ( word -- nodes )
 : expand-builtin-predicate ( #call -- nodes )
     word>> builtin-predicate-expansion ;
 
-: expand-tuple-boa? ( #call -- ? )
-    dup word>> \ <tuple-boa> eq? [
-        last-literal tuple-layout?
-    ] [ drop f ] if ;
-
-MEMO: (tuple-boa-expansion) ( n -- nodes )
-    [
-        [ '[ _ (tuple) ] % ]
-        [
-            [ 2 + ] map <reversed>
-            [ '[ [ _ set-slot ] keep ] % ] each
-        ] bi
-    ] [ ] make '[ _ dip ] splice-final ;
-
-: tuple-boa-expansion ( layout -- quot )
-    #! No memoization here since otherwise we'd hang on to
-    #! tuple layout objects.
-    size>> (tuple-boa-expansion)
-    [ over 1 set-slot ] splice-final append ;
-
-: expand-tuple-boa ( #call -- node )
-    last-literal tuple-boa-expansion ;
-
-MEMO: <array>-expansion ( n -- quot )
-    [
-        [ swap (array) ] %
-        [ '[ _ over 1 set-slot ] % ]
-        [ [ '[ 2dup _ swap set-array-nth ] % ] each ] bi
-        \ nip ,
-    ] [ ] make splice-final ;
-
-: expand-<array>? ( #call -- ? )
-    dup word>> \ <array> eq? [
-        first-literal dup integer?
-        [ 0 8 between? ] [ drop f ] if
-    ] [ drop f ] if ;
-
-: expand-<array> ( #call -- node )
-    first-literal <array>-expansion ;
-
-: bytes>cells ( m -- n ) cell align cell /i ;
-
-MEMO: <byte-array>-expansion ( n -- quot )
-    [
-        [ (byte-array) ] %
-        [ '[ _ over 1 set-slot ] % ]
-        [
-            bytes>cells [
-                cell *
-                '[ 0 over _ set-alien-unsigned-cell ] %
-            ] each
-        ] bi
-    ] [ ] make splice-final ;
-
-: expand-<byte-array>? ( #call -- ? )
-    dup word>> \ <byte-array> eq? [
-        first-literal dup integer?
-        [ 0 32 between? ] [ drop f ] if
-    ] [ drop f ] if ;
-
-: expand-<byte-array> ( #call -- nodes )
-    first-literal <byte-array>-expansion ;
-
-MEMO: <ratio>-expansion ( -- quot )
-    [ (ratio) [ 2 set-slot ] keep [ 1 set-slot ] keep ] splice-final ;
-
-: expand-<ratio> ( #call -- nodes )
-    drop <ratio>-expansion ;
-
-MEMO: <complex>-expansion ( -- quot )
-    [ (complex) [ 2 set-slot ] keep [ 1 set-slot ] keep ] splice-final ;
-
-: expand-<complex> ( #call -- nodes )
-    drop <complex>-expansion ;
-
-MEMO: <wrapper>-expansion ( -- quot )
-    [ (wrapper) [ 1 set-slot ] keep ] splice-final ;
-
-: expand-<wrapper> ( #call -- nodes )
-    drop <wrapper>-expansion ;
-
-MEMO: slot-expansion ( tag -- nodes )
-    '[ _ (slot) ] splice-final ;
-
-: value-tag ( node value -- n )
-    node-value-info class>> class-tag ;
-
-: expand-slot ( #call -- nodes )
-    dup dup in-d>> first value-tag [ slot-expansion ] [ ] ?if ;
-
-MEMO: set-slot-expansion ( write-barrier? tag# -- nodes )
-    [ '[ [ _ (set-slot) ] [ drop (write-barrier) ] 2bi ] ]
-    [ '[ _ (set-slot) ] ]
-    bi ? splice-final ;
-
-: expand-set-slot ( #call -- nodes )
-    dup dup in-d>> second value-tag [
-        [ dup in-d>> first node-value-info class>> immediate class<= not ] dip
-        set-slot-expansion
-    ] when* ;
-
 M: #call finalize*
-    {
-        { [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
-        { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
-        { [ dup expand-<array>? ] [ expand-<array> ] }
-        { [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
-        [
-            dup word>> {
-                { \ <ratio> [ expand-<ratio> ] }
-                { \ <complex> [ expand-<complex> ] }
-                { \ <wrapper> [ expand-<wrapper> ] }
-                { \ set-slot [ expand-set-slot ] }
-                { \ slot [ expand-slot ] }
-                [ drop ]
-            } case
-        ]
-    } cond ;
+    dup builtin-predicate? [ expand-builtin-predicate ] when ;
 
 M: node finalize* ;
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 24115767c3..2152664c4b 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -108,7 +108,7 @@ HOOK: %set-alien-cell      cpu ( ptr value -- )
 HOOK: %set-alien-float     cpu ( ptr value -- )
 HOOK: %set-alien-double    cpu ( ptr value -- )
 
-HOOK: %allot cpu ( dst size type tag temp -- )
+HOOK: %allot cpu ( dst size class temp -- )
 HOOK: %write-barrier cpu ( src card# table -- )
 HOOK: %gc cpu ( -- )
 
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 015b1b8b03..0ae92a0c07 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -6,7 +6,7 @@ accessors init combinators command-line cpu.x86.assembler
 cpu.x86.architecture cpu.architecture compiler compiler.units
 compiler.constants compiler.alien compiler.codegen
 compiler.codegen.fixup compiler.cfg.instructions
-compiler.cfg.builder compiler.cfg.builder.calls ;
+compiler.cfg.builder compiler.cfg.intrinsics ;
 IN: cpu.x86.32
 
 ! We implement the FFI for Linux, OS X and Windows all at once.
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index e081b80374..6938db2afd 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -6,7 +6,7 @@ slots splitting assocs combinators cpu.x86.assembler
 cpu.x86.architecture cpu.architecture compiler.constants
 compiler.codegen compiler.codegen.fixup
 compiler.cfg.instructions compiler.cfg.builder
-compiler.cfg.builder.calls ;
+compiler.cfg.intrinsics ;
 IN: cpu.x86.64
 
 M: x86.64 machine-registers
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 37f827b857..7db725c6a5 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -122,7 +122,7 @@ M:: x86 %integer>bignum ( dst src temp -- )
         "end" get JMP
         "nonzero" resolve-label
         ! Allocate a bignum
-        dst 4 cells bignum bignum temp %allot
+        dst 4 cells bignum temp %allot
         ! Write length
         dst 1 bignum@ 2 tag-fixnum MOV
         ! Test sign
@@ -205,7 +205,7 @@ M:: x86 %unbox-any-c-ptr ( dst src dst temp -- )
     ] with-scope ;
 
 M:: x86 %box-float ( dst src temp -- )
-    dst 16 float float temp %allot
+    dst 16 float temp %allot
     dst 8 float tag-number - [+] src MOVSD ;
 
 : alien@ ( reg n -- op ) cells object tag-number - [+] ;
@@ -215,7 +215,7 @@ M:: x86 %box-alien ( dst src temp -- )
         { "end" "f" } [ define-label ] each
         src 0 CMP
         "f" get JE
-        dst 4 cells alien object temp %allot
+        dst 4 cells alien temp %allot
         dst 1 alien@ \ f tag-number MOV
         dst 2 alien@ \ f tag-number MOV
         ! Store src in alien-offset slot
@@ -343,10 +343,10 @@ M: x86 %set-alien-double [ [] ] dip MOVSD ;
 : store-tagged ( dst tag -- )
     tag-number OR ;
 
-M:: x86 %allot ( dst size type tag nursery-ptr -- )
+M:: x86 %allot ( dst size class nursery-ptr -- )
     nursery-ptr dst load-allot-ptr
-    dst type store-header
-    dst tag store-tagged
+    dst class store-header
+    dst class store-tagged
     nursery-ptr size inc-allot-ptr ;
 
 HOOK: %alien-global cpu ( symbol dll register -- )

From 4d75baf268328eaa2fd54fb3728d71f5048e3af6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 20 Oct 2008 20:40:28 -0500
Subject: [PATCH 045/318] Update for ##allot change

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

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index a66f355d81..1bc3f4339f 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -185,8 +185,7 @@ M: ##allot generate-insn
     {
         [ dst>> register ]
         [ size>> ]
-        [ type>> ]
-        [ tag>> ]
+        [ class>> ]
         [ temp>> register ]
     } cleave
     %allot ;

From 0cc0a41e573cbcc4625300123ddcfbf924ef1804 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 20 Oct 2008 20:40:36 -0500
Subject: [PATCH 046/318] Update for compiler.intrinsics removal

---
 basis/compiler/tree/cleanup/cleanup.factor                     | 1 -
 .../compiler/tree/escape-analysis/escape-analysis-tests.factor | 2 +-
 basis/compiler/tree/escape-analysis/simple/simple.factor       | 1 -
 basis/compiler/tree/propagation/known-words/known-words.factor | 3 +--
 basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor       | 1 -
 5 files changed, 2 insertions(+), 6 deletions(-)

diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index 563926f233..caf2a36925 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -5,7 +5,6 @@ classes.algebra namespaces assocs words math math.private
 math.partial-dispatch math.intervals classes classes.tuple
 classes.tuple.private layouts definitions stack-checker.state
 stack-checker.branches
-compiler.intrinsics
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 7ece8a5a80..4ed194e81d 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -6,7 +6,7 @@ math.functions compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.combinators compiler.tree sequences math
 math.private kernel tools.test accessors slots.private
 quotations.private prettyprint classes.tuple.private classes
-classes.tuple compiler.intrinsics namespaces
+classes.tuple namespaces
 compiler.tree.propagation.info stack-checker.errors
 kernel.private ;
 
diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor
index 0324b31199..fe1e60dbc2 100644
--- a/basis/compiler/tree/escape-analysis/simple/simple.factor
+++ b/basis/compiler/tree/escape-analysis/simple/simple.factor
@@ -4,7 +4,6 @@ USING: kernel accessors sequences classes.tuple
 classes.tuple.private arrays math math.private slots.private
 combinators deques search-deques namespaces fry classes
 classes.algebra stack-checker.state
-compiler.intrinsics
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 9d26ab2f4a..a1ccaa95bd 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -7,7 +7,6 @@ classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private slots.private
 definitions
 stack-checker.state
-compiler.intrinsics
 compiler.tree.comparisons
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -280,7 +279,7 @@ generic-comparison-ops [
     '[ 2drop _ ] "outputs" set-word-prop
 ] each
 
-{ <tuple> <tuple-boa> (tuple) } [
+{ <tuple> <tuple-boa> } [
     [
         literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
         [ clear ] dip
diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 6fc0e76310..8e07c08194 100644
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -4,7 +4,6 @@ USING: namespaces assocs accessors kernel combinators
 classes.algebra sequences sequences.deep slots.private
 classes.tuple.private math math.private arrays
 stack-checker.branches
-compiler.intrinsics
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info

From df498c21a35fd67b75dd9471584898a961486292 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 20 Oct 2008 20:46:47 -0500
Subject: [PATCH 047/318] Trim USING:

---
 .../compiler/cfg/intrinsics/intrinsics.factor | 27 +++++++++----------
 1 file changed, 13 insertions(+), 14 deletions(-)

diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 0774eff335..f42b53a91e 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -1,18 +1,17 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: qualified kernel words sequences layouts namespaces
-accessors fry arrays byte-arrays locals math math.order
-combinators alien classes.algebra cpu.architecture
-compiler.tree.propagation.info
+USING: qualified words sequences kernel combinators
+cpu.architecture
 compiler.cfg.hats
-compiler.cfg.stacks
-compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.intrinsics.alien
 compiler.cfg.intrinsics.allot
 compiler.cfg.intrinsics.fixnum
 compiler.cfg.intrinsics.float
 compiler.cfg.intrinsics.slots ;
+QUALIFIED: kernel
+QUALIFIED: arrays
+QUALIFIED: byte-arrays
 QUALIFIED: kernel.private
 QUALIFIED: slots.private
 QUALIFIED: classes.tuple.private
@@ -36,15 +35,15 @@ IN: compiler.cfg.intrinsics
     math.private:fixnum>
     math.private:bignum>fixnum
     math.private:fixnum>bignum
-    eq?
+    kernel:eq?
     slots.private:slot
     slots.private:set-slot
     classes.tuple.private:<tuple-boa>
-    <array>
-    <byte-array>
+    arrays:<array>
+    byte-arrays:<byte-array>
     math.private:<complex>
     math.private:<ratio>
-    <wrapper>
+    kernel:<wrapper>
     alien.accessors:alien-unsigned-1
     alien.accessors:set-alien-unsigned-1
     alien.accessors:alien-signed-1
@@ -94,7 +93,7 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
         { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
         { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
-        { \ eq? [ cc= emit-fixnum-comparison ] }
+        { \ kernel:eq? [ cc= emit-fixnum-comparison ] }
         { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
         { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
         { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
@@ -111,11 +110,11 @@ IN: compiler.cfg.intrinsics
         { \ slots.private:slot [ emit-slot ] }
         { \ slots.private:set-slot [ emit-set-slot ] }
         { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
-        { \ <array> [ emit-<array> ] }
-        { \ <byte-array> [ emit-<byte-array> ] }
+        { \ arrays:<array> [ emit-<array> ] }
+        { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
         { \ math.private:<complex> [ emit-simple-allot ] }
         { \ math.private:<ratio> [ emit-simple-allot ] }
-        { \ <wrapper> [ emit-simple-allot ] }
+        { \ kernel:<wrapper> [ emit-simple-allot ] }
         { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
         { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
         { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }

From 94a2bfa2ea83291843595a463fdbf2bc4bd9ebe5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 21 Oct 2008 03:20:48 -0500
Subject: [PATCH 048/318] Working on comparison operations, clearing out
 remaining dead wood

---
 basis/compiler/cfg/builder/builder.factor     |  42 ++--
 basis/compiler/cfg/def-use/def-use.factor     |   2 +
 basis/compiler/cfg/hats/hats.factor           |  16 +-
 .../cfg/intrinsics/alien/alien.factor         |  14 +-
 .../cfg/intrinsics/allot/allot.factor         |  21 +-
 .../cfg/intrinsics/fixnum/fixnum.factor       |  26 +--
 .../cfg/intrinsics/float/float.factor         |  12 +-
 .../cfg/intrinsics/slots/slots.factor         |  20 +-
 .../cfg/intrinsics/utilities/utilities.factor |   6 +-
 .../linearization/linearization-tests.factor  |   4 +
 basis/compiler/cfg/registers/registers.factor |   2 +-
 basis/compiler/cfg/stacks/stacks.factor       | 208 ++----------------
 12 files changed, 100 insertions(+), 273 deletions(-)
 create mode 100644 basis/compiler/cfg/linearization/linearization-tests.factor

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index bee7884e81..7247534b91 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -65,14 +65,12 @@ GENERIC: emit-node ( node -- next )
     basic-block get [ drop f ] unless ; inline
 
 : emit-nodes ( nodes -- )
-    [ current-node emit-node check-basic-block ] iterate-nodes
-    finalize-phantoms ;
+    [ current-node emit-node check-basic-block ] iterate-nodes ;
 
 : begin-word ( -- )
     #! We store the basic block after the prologue as a loop
     #! labelled by the current word, so that self-recursive
     #! calls can skip an epilogue/prologue.
-    init-phantoms
     ##prologue
     ##branch
     begin-basic-block
@@ -98,7 +96,6 @@ GENERIC: emit-node ( node -- next )
     stop-iterating ;
 
 : emit-call ( word -- next )
-    finalize-phantoms
     {
         { [ dup loops get key? ] [ loops get at local-recursive-call ] }
         { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
@@ -115,7 +112,6 @@ GENERIC: emit-node ( node -- next )
     basic-block get swap loops get set-at ;
 
 : compile-loop ( node -- next )
-    finalize-phantoms
     begin-basic-block
     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
     iterate-next ;
@@ -126,7 +122,7 @@ M: #recursive emit-node
 ! #if
 : emit-branch ( obj -- final-bb )
     [
-        begin-basic-block copy-phantoms
+        begin-basic-block
         emit-nodes
         basic-block get dup [ ##branch ] when
     ] with-scope ;
@@ -135,21 +131,19 @@ M: #recursive emit-node
     children>>  [ emit-branch ] map
     end-basic-block
     begin-basic-block
-    basic-block get '[ [ _ swap successors>> push ] when* ] each
-    init-phantoms ;
+    basic-block get '[ [ _ swap successors>> push ] when* ] each ;
 
 : ##branch-t ( vreg -- )
     \ f tag-number cc/= ##compare-imm-branch ;
 
 M: #if emit-node
-    phantom-pop ##branch-t emit-if iterate-next ;
+    ds-pop ##branch-t emit-if iterate-next ;
 
 ! #dispatch
 : dispatch-branch ( nodes word -- label )
     gensym [
         [
             V{ } clone node-stack set
-            init-phantoms
             ##prologue
             emit-nodes
             basic-block get [
@@ -167,11 +161,9 @@ M: #if emit-node
     ] each ;
 
 : emit-dispatch ( node -- )
-    phantom-pop int-regs next-vreg
-    [ finalize-phantoms ##epilogue ] 2dip
-    [ ^^offset>slot ] dip
-    ##dispatch
-    dispatch-branches init-phantoms ;
+    ##epilogue
+    ds-pop ^^offset>slot i ##dispatch
+    dispatch-branches ;
 
 : <dispatch-block> ( -- word )
     gensym dup t "inlined-block" set-word-prop ;
@@ -198,34 +190,36 @@ M: #call-recursive emit-node label>> id>> emit-call ;
 
 ! #push
 M: #push emit-node
-    literal>> ^^load-literal phantom-push iterate-next ;
+    literal>> ^^load-literal ds-push iterate-next ;
 
 ! #shuffle
+: emit-shuffle ( effect -- )
+    [ out>> ] [ in>> dup length ds-load zip ] bi
+    '[ _ at ] map ds-store ;
+
 M: #shuffle emit-node
-    shuffle-effect phantom-shuffle iterate-next ;
+    shuffle-effect emit-shuffle iterate-next ;
 
 M: #>r emit-node
     [ in-d>> length ] [ out-r>> empty? ] bi
-    [ phantom-drop ] [ phantom->r ] if
+    [ neg ##inc-d ] [ ds-load rs-store ] if
     iterate-next ;
 
 M: #r> emit-node
     [ in-r>> length ] [ out-d>> empty? ] bi
-    [ phantom-rdrop ] [ phantom-r> ] if
+    [ neg ##inc-r ] [ rs-load ds-store ] if
     iterate-next ;
 
 ! #return
 M: #return emit-node
-    drop finalize-phantoms ##epilogue ##return stop-iterating ;
+    drop ##epilogue ##return stop-iterating ;
 
 M: #return-recursive emit-node
-    finalize-phantoms
     label>> id>> loops get key?
     [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
 
 ! #terminate
-M: #terminate emit-node
-    drop finalize-phantoms stop-iterating ;
+M: #terminate emit-node drop stop-iterating ;
 
 ! FFI
 : return-size ( ctype -- n )
@@ -246,7 +240,6 @@ M: #terminate emit-node
     <alien-stack-frame> ##stack-frame ;
 
 : emit-alien-node ( node quot -- next )
-    finalize-phantoms
     [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
     iterate-next ; inline
 
@@ -259,7 +252,6 @@ M: #alien-indirect emit-node
 M: #alien-callback emit-node
     dup params>> xt>> dup
     [
-        init-phantoms
         ##prologue
         dup [ ##alien-callback ] emit-alien-node drop
         ##epilogue
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index fea51ab2a5..37b050eda6 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -13,6 +13,8 @@ M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
 M: ##unary/temp defs-vregs dst/tmp-vregs ;
 M: ##allot defs-vregs dst/tmp-vregs ;
 M: ##dispatch defs-vregs temp>> 1array ;
+M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
+M: ##set-slot defs-vregs temp>> 1array ;
 M: insn defs-vregs drop f ;
 
 M: ##unary uses-vregs src>> 1array ;
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index 77b10b5e9f..705aa02701 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -5,13 +5,6 @@ sequences classes.tuple cpu.architecture compiler.cfg.registers
 compiler.cfg.instructions ;
 IN: compiler.cfg.hats
 
-! Operands holding pointers to freshly-allocated objects which
-! are guaranteed to be in the nursery
-SYMBOL: fresh-objects
-
-: fresh-object ( vreg/t -- ) fresh-objects get push ;
-: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
-
 : i int-regs next-vreg ; inline
 : ^^i i dup ; inline
 : ^^i1 [ ^^i ] dip ; inline
@@ -53,11 +46,10 @@ SYMBOL: fresh-objects
 : ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
 : ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
 : ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
-: ^^allot ( size class -- dst ) ^^i2 i ##allot dup fresh-object ; inline
+: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
 : ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
 : ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
 : ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
-: ^^write-barrier ( src -- ) dup fresh-object? [ drop ] [ i i ##write-barrier ] if ; inline
 : ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
 : ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
 : ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
@@ -72,9 +64,9 @@ SYMBOL: fresh-objects
 : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
 : ^^alien-float ( src -- dst ) ^^i1 ##alien-float ; inline
 : ^^alien-double ( src -- dst ) ^^i1 ##alien-double ; inline
-: ^^compare ( src1 src2 -- dst ) ^^i2 ##compare ; inline
-: ^^compare-imm ( src1 src2 -- dst ) ^^i2 ##compare-imm ; inline
-: ^^compare-float ( src1 src2 -- dst ) ^^i2 ##compare-float ; inline
+: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
+: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
+: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
 : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
 : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
 : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor
index 9ab013f04b..087c759384 100644
--- a/basis/compiler/cfg/intrinsics/alien/alien.factor
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@@ -8,15 +8,15 @@ compiler.cfg.intrinsics.utilities ;
 IN: compiler.cfg.intrinsics.alien
 
 : (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
-    1 phantom-drop [ phantom-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
+    ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
 
 : (prepare-alien-accessor) ( class -- offset-vreg )
-    [ 2phantom-pop ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+    [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
 
 : prepare-alien-accessor ( infos -- offset-vreg )
     <reversed> [ second class>> ] [ first ] bi
     dup value-info-small-tagged? [
-        1 phantom-drop
+        ds-drop
         literal>> (prepare-alien-accessor-imm)
     ] [ drop (prepare-alien-accessor) ] if ;
 
@@ -34,7 +34,7 @@ IN: compiler.cfg.intrinsics.alien
     bi and ;
 
 : inline-alien-getter ( node quot -- )
-    '[ @ phantom-push ]
+    '[ @ ds-push ]
     [ inline-alien-getter? ] inline-alien ; inline
 
 : inline-alien-setter? ( infos class -- ? )
@@ -44,18 +44,18 @@ IN: compiler.cfg.intrinsics.alien
     tri and and ;
 
 : inline-alien-integer-setter ( node quot -- )
-    '[ phantom-pop ^^untag-fixnum @ ]
+    '[ ds-pop ^^untag-fixnum @ ]
     [ fixnum inline-alien-setter? ]
     inline-alien ; inline
 
 : inline-alien-cell-setter ( node quot -- )
     [ dup node-input-infos first class>> ] dip
-    '[ phantom-pop _ ^^unbox-c-ptr @ ]
+    '[ ds-pop _ ^^unbox-c-ptr @ ]
     [ pinned-c-ptr inline-alien-setter? ]
     inline-alien ; inline
 
 : inline-alien-float-setter ( node quot -- )
-    '[ phantom-pop ^^unbox-float @ ]
+    '[ ds-pop ^^unbox-float @ ]
     [ float inline-alien-setter? ]
     inline-alien ; inline
 
diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor
index a371f071cc..3c81367cfc 100644
--- a/basis/compiler/cfg/intrinsics/allot/allot.factor
+++ b/basis/compiler/cfg/intrinsics/allot/allot.factor
@@ -3,7 +3,8 @@
 USING: kernel math math.order sequences accessors arrays
 byte-arrays layouts classes.tuple.private fry locals
 compiler.tree.propagation.info compiler.cfg.hats
-compiler.cfg.instructions compiler.cfg.stacks ;
+compiler.cfg.instructions compiler.cfg.stacks
+compiler.cfg.intrinsics.utilities ;
 IN: compiler.cfg.intrinsics.allot
 
 : ##set-slots ( regs obj class -- )
@@ -11,16 +12,16 @@ IN: compiler.cfg.intrinsics.allot
 
 : emit-simple-allot ( node -- )
     [ in-d>> length ] [ node-output-infos first class>> ] bi
-    [ drop phantom-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
-    [ ##set-slots ] [ [ drop ] [ phantom-push ] [ drop ] tri* ] 3bi ;
+    [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
+    [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
 
 : tuple-slot-regs ( layout -- vregs )
-    [ size>> phantom-load ] [ ^^load-literal ] bi prefix ;
+    [ size>> ds-load ] [ ^^load-literal ] bi prefix ;
 
 :: emit-<tuple-boa> ( node -- )
     [let | layout [ node node-input-infos peek literal>> ] |
         layout tuple-layout? [
-            1 phantom-drop
+            ds-drop
             layout tuple-slot-regs
             layout size>> ^^allot-tuple
             tuple ##set-slots
@@ -36,11 +37,11 @@ IN: compiler.cfg.intrinsics.allot
 :: emit-<array> ( node -- )
     [let | len [ node node-input-infos first literal>> ] |
         len expand-<array>? [
-            [let | elt [ phantom-pop ]
+            [let | elt [ ds-pop ]
                    reg [ len ^^allot-array ] |
-                1 phantom-drop
+                ds-drop
                 elt reg len store-initial-element
-                reg phantom-push
+                reg ds-push
             ]
         ] [ node emit-primitive ] if
     ] ;
@@ -55,9 +56,9 @@ IN: compiler.cfg.intrinsics.allot
         len expand-<byte-array>? [
             [let | elt [ 0 ^^load-literal ]
                    reg [ len ^^allot-byte-array ] |
-                1 phantom-drop
+                ds-drop
                 elt reg len bytes>cells store-initial-element
-                reg phantom-push
+                reg ds-push
             ]
         ] [ node emit-primitive ] if
     ] ;
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index 7791edb727..a6e8bf28e7 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -8,12 +8,12 @@ compiler.cfg.intrinsics.utilities ;
 IN: compiler.cfg.intrinsics.fixnum
 
 : (emit-fixnum-imm-op) ( infos insn -- dst )
-    1 phantom-drop
-    [ phantom-pop ] [ second literal>> tag-fixnum ] [ ] tri*
+    ds-drop
+    [ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
     call ; inline
 
 : (emit-fixnum-op) ( insn -- dst )
-    [ 2phantom-pop ] dip call ; inline
+    [ 2inputs ] dip call ; inline
 
 :: emit-fixnum-op ( node insn imm-insn -- )
     [let | infos [ node node-input-infos ] |
@@ -21,43 +21,43 @@ IN: compiler.cfg.intrinsics.fixnum
         [ infos imm-insn (emit-fixnum-imm-op) ]
         [ insn (emit-fixnum-op) ]
         if
-        phantom-push
+        ds-push
     ] ; inline
 
 : emit-fixnum-shift-fast ( node -- )
     dup node-input-infos dup second value-info-small-tagged? [
         nip
-        [ 1 phantom-drop phantom-pop ] dip
+        [ ds-drop ds-pop ] dip
         second literal>> dup sgn {
             { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
             {  0 [ drop ] }
             {  1 [ ^^shl-imm ] }
         } case
-        phantom-push
+        ds-push
     ] [ drop emit-primitive ] if ;
 
 : emit-fixnum-bitnot ( -- )
-    phantom-pop ^^not tag-mask get ^^xor-imm phantom-push ;
+    ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
 
 : (emit-fixnum*fast) ( -- dst )
-    2phantom-pop ^^untag-fixnum ^^mul ;
+    2inputs ^^untag-fixnum ^^mul ;
 
 : (emit-fixnum*fast-imm) ( infos -- dst )
-    1 phantom-drop
-    [ phantom-pop ] [ second literal>> ] bi* ^^mul-imm ;
+    ds-drop
+    [ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
 
 : emit-fixnum*fast ( node -- )
     node-input-infos
     dup second value-info-small-tagged?
     [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
-    phantom-push ;
+    ds-push ;
 
 : emit-fixnum-comparison ( node cc -- )
     [ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
     emit-fixnum-op ;
 
 : emit-bignum>fixnum ( -- )
-    phantom-pop ^^bignum>integer ^^tag-fixnum phantom-push ;
+    ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>bignum ( -- )
-    phantom-pop ^^untag-fixnum ^^integer>bignum phantom-push ;
+    ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor
index 24bb56d237..c8bd326475 100644
--- a/basis/compiler/cfg/intrinsics/float/float.factor
+++ b/basis/compiler/cfg/intrinsics/float/float.factor
@@ -4,15 +4,15 @@ USING: kernel compiler.cfg.stacks compiler.cfg.hats ;
 IN: compiler.cfg.intrinsics.float
 
 : emit-float-op ( insn -- )
-    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip call ^^box-float
-    phantom-push ; inline
+    [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
+    ds-push ; inline
 
 : emit-float-comparison ( cc -- )
-    [ 2phantom-pop [ ^^unbox-float ] bi@ ] dip ^^compare-float
-    phantom-push ; inline
+    [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
+    ds-push ; inline
 
 : emit-float>fixnum ( -- )
-    phantom-pop ^^unbox-float ^^float>integer ^^tag-fixnum phantom-push ;
+    ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>float ( -- )
-    phantom-pop ^^untag-fixnum ^^integer>float ^^box-float phantom-push ;
+    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index d2e2e95d0d..7817d59770 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -7,17 +7,17 @@ compiler.cfg.intrinsics.utilities ;
 IN: compiler.cfg.intrinsics.slots
 
 : emit-tag ( -- )
-    phantom-pop tag-mask get ^^and-imm ^^tag-fixnum phantom-push ;
+    ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
 
 : value-tag ( info -- n ) class>> class-tag ; inline
 
 : (emit-slot) ( infos -- dst )
-    [ 2phantom-pop ] [ first value-tag ] bi*
+    [ 2inputs ] [ first value-tag ] bi*
     ^^slot ;
 
 : (emit-slot-imm) ( infos -- dst )
-    1 phantom-drop
-    [ phantom-pop ^^offset>slot ]
+    ds-drop
+    [ ds-pop ^^offset>slot ]
     [ [ second literal>> ] [ first value-tag ] bi ] bi*
     ^^slot-imm ;
 
@@ -27,17 +27,17 @@ IN: compiler.cfg.intrinsics.slots
         nip
         dup second value-info-small-tagged?
         [ (emit-slot-imm) ] [ (emit-slot) ] if
-        phantom-push
+        ds-push
     ] [ drop emit-primitive ] if ;
 
 : (emit-set-slot) ( infos -- obj-reg )
-    [ 3phantom-pop [ tuck ] dip ^^offset>slot ]
+    [ 3inputs [ tuck ] dip ^^offset>slot ]
     [ second value-tag ]
     bi* ^^set-slot ;
 
 : (emit-set-slot-imm) ( infos -- obj-reg )
-    1 phantom-drop
-    [ 2phantom-pop tuck ]
+    ds-drop
+    [ 2inputs tuck ]
     [ [ third literal>> ] [ second value-tag ] bi ] bi*
     ##set-slot-imm ;
 
@@ -45,10 +45,10 @@ IN: compiler.cfg.intrinsics.slots
     dup node-input-infos
     dup second value-tag [
         nip
-        1 phantom-drop
+        ds-drop
         [
             dup third value-info-small-tagged?
             [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
         ] [ first class>> immediate class<= ] bi
-        [ drop ] [ ^^write-barrier ] if
+        [ drop ] [ i i ##write-barrier ] if
     ] [ drop emit-primitive ] if ;
diff --git a/basis/compiler/cfg/intrinsics/utilities/utilities.factor b/basis/compiler/cfg/intrinsics/utilities/utilities.factor
index 5540e3316a..cd10b4e54e 100644
--- a/basis/compiler/cfg/intrinsics/utilities/utilities.factor
+++ b/basis/compiler/cfg/intrinsics/utilities/utilities.factor
@@ -1,7 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math layouts cpu.architecture ;
+USING: accessors kernel math layouts cpu.architecture
+compiler.cfg.instructions ;
 IN: compiler.cfg.intrinsics.utilities
 
 : value-info-small-tagged? ( value-info -- ? )
     literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
+
+: emit-primitive ( node -- )
+    word>> ##simple-stack-frame ##call ;
diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor
new file mode 100644
index 0000000000..5e866d15db
--- /dev/null
+++ b/basis/compiler/cfg/linearization/linearization-tests.factor
@@ -0,0 +1,4 @@
+IN: compiler.cfg.linearization.tests
+USING: compiler.cfg.linearization tools.test ;
+
+\ build-mr must-infer
diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor
index f9fd4521f7..09d2feba6d 100644
--- a/basis/compiler/cfg/registers/registers.factor
+++ b/basis/compiler/cfg/registers/registers.factor
@@ -16,7 +16,7 @@ TUPLE: ds-loc < loc ;
 C: <ds-loc> ds-loc
 
 TUPLE: rs-loc < loc ;
-C: <rs-loc> ds-loc
+C: <rs-loc> rs-loc
 
 ! Prettyprinting
 : V scan-word scan-word vreg boa parsed ; parsing
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index 73261e0e42..f138f673e0 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -1,201 +1,33 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes classes.private classes.algebra
-combinators hashtables kernel layouts math fry namespaces
-quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order
-combinators.short-circuit cpu.architecture
+USING: math sequences kernel cpu.architecture
 compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.hats ;
 IN: compiler.cfg.stacks
 
-! Converting stack operations into register operations, while
-! doing a bit of optimization along the way.
+: ds-drop ( -- )
+    -1 ##inc-d ;
 
-! A compile-time stack
-TUPLE: phantom-stack { height integer } { stack vector } ;
+: ds-pop ( -- vreg )
+    D 0 ^^peek -1 ##inc-d ;
 
-M: phantom-stack clone
-    call-next-method [ clone ] change-stack ;
+: ds-push ( vreg -- )
+    1 ##inc-d D 0 ##replace ;
 
-GENERIC: finalize-height ( stack -- )
+: ds-load ( n -- vregs )
+    [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
 
-: new-phantom-stack ( class -- stack )
-    new V{ } clone >>stack ; inline
+: ds-store ( vregs -- )
+    <reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
 
-: (loc) ( m stack -- n )
-    #! Utility for methods on <loc>
-    height>> - ; inline
+: rs-load ( n -- vregs )
+    [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
 
-: (finalize-height) ( stack word -- )
-    #! We consolidate multiple stack height changes until the
-    #! last moment, and we emit the final height changing
-    #! instruction here.
-    '[ dup zero? [ drop ] [ _ execute ] if 0 ] change-height drop ; inline
+: rs-store ( vregs -- )
+    <reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
 
-GENERIC: <loc> ( n stack -- loc )
+: 2inputs ( -- vreg1 vreg2 )
+    D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
 
-TUPLE: phantom-datastack < phantom-stack ;
-
-: <phantom-datastack> ( -- stack )
-    phantom-datastack new-phantom-stack ;
-
-M: phantom-datastack <loc> (loc) <ds-loc> ;
-
-M: phantom-datastack finalize-height
-    \ ##inc-d (finalize-height) ;
-
-TUPLE: phantom-retainstack < phantom-stack ;
-
-: <phantom-retainstack> ( -- stack )
-    phantom-retainstack new-phantom-stack ;
-
-M: phantom-retainstack <loc> (loc) <rs-loc> ;
-
-M: phantom-retainstack finalize-height
-    \ ##inc-r (finalize-height) ;
-
-: phantom-locs ( n phantom -- locs )
-    #! A sequence of n ds-locs or rs-locs indexing the stack.
-    [ <reversed> ] dip '[ _ <loc> ] map ;
-
-: phantom-locs* ( phantom -- locs )
-    [ stack>> length ] keep phantom-locs ;
-
-: phantoms ( -- phantom phantom )
-    phantom-datastack get phantom-retainstack get ;
-
-: (each-loc) ( phantom quot -- )
-    >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
-
-: each-loc ( quot -- )
-    phantoms 2array swap '[ _ (each-loc) ] each ; inline
-
-: adjust-phantom ( n phantom -- )
-    swap '[ _ + ] change-height drop ;
-
-: cut-phantom ( n phantom -- seq )
-    swap '[ _ cut* swap ] change-stack drop ;
-
-: phantom-append ( seq stack -- )
-    over length over adjust-phantom stack>> push-all ;
-
-: add-locs ( n phantom -- )
-    2dup stack>> length <= [
-        2drop
-    ] [
-        [ phantom-locs ] keep
-        [ stack>> length head-slice* ] keep
-        [ append >vector ] change-stack drop
-    ] if ;
-
-: phantom-input ( n phantom -- seq )
-    2dup add-locs
-    2dup cut-phantom
-    >r >r neg r> adjust-phantom r> ;
-
-: each-phantom ( quot -- ) phantoms rot bi@ ; inline
-
-: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
-
-GENERIC: lazy-load ( loc/vreg -- vreg )
-M: loc lazy-load ^^peek ;
-M: vreg lazy-load ;
-
-GENERIC: live-loc? ( actual current -- ? )
-M: vreg live-loc? 2drop f ;
-M: loc live-loc? { [ [ class ] bi@ = ] [ [ n>> ] bi@ = not ] } 2&& ;
-
-: (live-locs) ( phantom -- seq )
-    #! Discard locs which haven't moved
-    [ phantom-locs* ] [ stack>> ] bi zip
-    [ live-loc? ] assoc-filter
-    values ;
-
-: live-locs ( -- seq )
-    [ (live-locs) ] each-phantom append prune ;
-
-GENERIC: lazy-store ( dst src -- )
-
-M: vreg lazy-store 2drop ;
-
-M: loc lazy-store
-    2dup live-loc? [
-        \ live-locs get at swap ##replace
-    ] [ 2drop ] if ;
-
-: finalize-locs ( -- )
-    #! Perform any deferred stack shuffling.
-    live-locs [ dup lazy-load ] H{ } map>assoc
-    dup assoc-empty? [ drop ] [
-        \ live-locs set
-        [ lazy-store ] each-loc
-    ] if ;
-
-: finalize-vregs ( -- )
-    #! Store any vregs to their final stack locations.
-    [ dup loc? [ 2drop ] [ swap ##replace ] if ] each-loc ;
-
-: clear-phantoms ( -- )
-    [ stack>> delete-all ] each-phantom ;
-
-: finalize-contents ( -- )
-    finalize-locs finalize-vregs clear-phantoms ;
-
-! Loading stacks to vregs
-: finalize-phantoms ( -- )
-    #! Commit all deferred stacking shuffling, and ensure the
-    #! in-memory data and retain stacks are up to date with
-    #! respect to the compiler's current picture.
-    finalize-contents
-    finalize-heights
-    fresh-objects get [
-        empty? [ ##simple-stack-frame ##gc ] unless
-    ] [ delete-all ] bi ;
-
-: init-phantoms ( -- )
-    V{ } clone fresh-objects set
-    <phantom-datastack> phantom-datastack set
-    <phantom-retainstack> phantom-retainstack set ;
-
-: copy-phantoms ( -- )
-    fresh-objects [ clone ] change
-    phantom-datastack [ clone ] change
-    phantom-retainstack [ clone ] change ;
-
-: phantom-push ( obj -- )
-    1 phantom-datastack get adjust-phantom
-    phantom-datastack get stack>> push ;
-
-: phantom-shuffle ( shuffle -- )
-    [ in>> length phantom-datastack get phantom-input ] keep
-    shuffle phantom-datastack get phantom-append ;
-
-: phantom->r ( n -- )
-    phantom-datastack get phantom-input
-    phantom-retainstack get phantom-append ;
-
-: phantom-r> ( n -- )
-    phantom-retainstack get phantom-input
-    phantom-datastack get phantom-append ;
-
-: phantom-drop ( n -- )
-    phantom-datastack get phantom-input drop ;
-
-: phantom-rdrop ( n -- )
-    phantom-retainstack get phantom-input drop ;
-
-: phantom-load ( n -- vreg )
-    phantom-datastack get phantom-input [ lazy-load ] map ;
-
-: phantom-pop ( -- vreg )
-    1 phantom-load first ;
-
-: 2phantom-pop ( -- vreg1 vreg2 )
-    2 phantom-load first2 ;
-
-: 3phantom-pop ( -- vreg1 vreg2 vreg3 )
-    3 phantom-load first3 ;
-
-: emit-primitive ( node -- )
-    finalize-phantoms word>> ##simple-stack-frame ##call ;
+: 3inputs ( -- vreg1 vreg2 vreg3 )
+    D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;

From 87e9fbb34c274969e003626bbd8163e3c7ad3118 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 21 Oct 2008 03:21:29 -0500
Subject: [PATCH 049/318] Comparison operations

---
 basis/compiler/codegen/codegen.factor         | 45 +++++++++++------
 basis/cpu/architecture/architecture.factor    |  8 ++-
 basis/cpu/x86/32/32.factor                    |  8 ++-
 basis/cpu/x86/64/64.factor                    | 13 +++--
 .../cpu/x86/architecture/architecture.factor  | 50 +++++++++++++++----
 5 files changed, 91 insertions(+), 33 deletions(-)

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 1bc3f4339f..eca909baf7 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -21,6 +21,9 @@ SYMBOL: registers
 : register ( vreg -- operand )
     registers get at [ "Bad value" throw ] unless* ;
 
+: ?register ( obj -- operand )
+    dup vreg? [ register ] when ;
+
 : generate-insns ( insns -- code )
     [
         [
@@ -64,7 +67,7 @@ SYMBOL: labels
     labels get [ drop <label> ] cache ;
 
 M: ##load-immediate generate-insn
-    [ dst>> register ] [ obj>> ] bi %load-immediate ;
+    [ dst>> register ] [ val>> ] bi %load-immediate ;
 
 M: ##load-indirect generate-insn
     [ dst>> register ] [ obj>> ] bi %load-indirect ;
@@ -94,7 +97,7 @@ M: ##dispatch generate-insn
     {
         [ dst>> register ]
         [ obj>> register ]
-        [ slot>> dup vreg? [ register ] when ]
+        [ slot>> ?register ]
         [ tag>> ]
     } cleave ; inline
 
@@ -108,7 +111,7 @@ M: ##slot-imm generate-insn
     {
         [ src>> register ]
         [ obj>> register ]
-        [ slot>> dup vreg? [ register ] when ]
+        [ slot>> ?register ]
         [ tag>> ]
     } cleave ; inline
 
@@ -122,7 +125,9 @@ M: ##set-slot-imm generate-insn
     [ dst>> register ] [ src>> register ] bi ; inline
 
 : dst/src1/src2 ( insn -- dst src1 src2 )
-    [ dst>> register ] [ src1>> register ] [ src2>> register ] tri ; inline
+    [ dst>> register ]
+    [ src1>> register ]
+    [ src2>> ?register ] tri ; inline
 
 M: ##add     generate-insn dst/src1/src2 %add     ;
 M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
@@ -152,15 +157,15 @@ M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
 M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
 M: ##div-float generate-insn dst/src1/src2 %div-float ;
 
-M: ##integer>float generate-insn dst/src/temp %integer>float ;
+M: ##integer>float generate-insn dst/src %integer>float ;
 M: ##float>integer generate-insn dst/src %float>integer ;
 
-M: ##copy             generate-insn dst/src %copy             ;
-M: ##copy-float       generate-insn dst/src %copy-float       ;
-M: ##unbox-float      generate-insn dst/src %unbox-float      ;
-M: ##unbox-any-c-ptr  generate-insn dst/src %unbox-any-c-ptr  ;
-M: ##box-float        generate-insn dst/src/temp %box-float   ;
-M: ##box-alien        generate-insn dst/src/temp %box-alien   ;
+M: ##copy             generate-insn dst/src %copy ;
+M: ##copy-float       generate-insn dst/src %copy-float ;
+M: ##unbox-float      generate-insn dst/src %unbox-float ;
+M: ##unbox-any-c-ptr  generate-insn dst/src/temp %unbox-any-c-ptr ;
+M: ##box-float        generate-insn dst/src/temp %box-float ;
+M: ##box-alien        generate-insn dst/src/temp %box-alien ;
 
 M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
 M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
@@ -172,7 +177,7 @@ M: ##alien-cell       generate-insn dst/src %alien-cell       ;
 M: ##alien-float      generate-insn dst/src %alien-float      ;
 M: ##alien-double     generate-insn dst/src %alien-double     ;
 
-: >alien-setter< [ src>> register ] [ value>> register ] bi ;
+: >alien-setter< [ src>> register ] [ value>> register ] bi ; inline
 
 M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
 M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
@@ -461,13 +466,25 @@ M: _label generate-insn
 M: _branch generate-insn
     label>> lookup-label %jump-label ;
 
+: >compare< ( insn -- label cc src1 src2 )
+    {
+        [ dst>> register ]
+        [ cc>> ]
+        [ src1>> register ]
+        [ src2>> ?register ]
+    } cleave ; inline
+
+M: ##compare generate-insn >compare< %compare ;
+M: ##compare-imm generate-insn >compare< %compare-imm ;
+M: ##compare-float generate-insn >compare< %compare-float ;
+
 : >binary-branch< ( insn -- label cc src1 src2 )
     {
         [ label>> lookup-label ]
         [ cc>> ]
         [ src1>> register ]
-        [ src2>> dup vreg? [ register ] when ]
-    } cleave ;
+        [ src2>> ?register ]
+    } cleave ; inline
 
 M: _compare-branch generate-insn
     >binary-branch< %compare-branch ;
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 2152664c4b..e90f58fd49 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -74,7 +74,7 @@ HOOK: %sar-imm cpu ( dst src1 src2 -- )
 HOOK: %not     cpu ( dst src -- )
 
 HOOK: %integer>bignum cpu ( dst src temp -- )
-HOOK: %bignum>integer cpu ( dst src temp -- )
+HOOK: %bignum>integer cpu ( dst src -- )
 
 HOOK: %add-float cpu ( dst src1 src2 -- )
 HOOK: %sub-float cpu ( dst src1 src2 -- )
@@ -115,6 +115,10 @@ HOOK: %gc cpu ( -- )
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )
 
+HOOK: %compare cpu ( dst cc src1 src2 -- )
+HOOK: %compare-imm cpu ( dst cc src1 src2 -- )
+HOOK: %compare-float cpu ( dst cc src1 src2 -- )
+
 HOOK: %compare-branch cpu ( label cc src1 src2 -- )
 HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
 HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
@@ -193,7 +197,7 @@ M: stack-params param-reg drop ;
 M: stack-params param-regs drop f ;
 
 : if-small-struct ( n size true false -- ? )
-    [ 2dup [ not ] [ struct-small-enough? ] bi and ] 2dip
+    [ 2dup [ not ] [ struct-small-enough? ] bi* and ] 2dip
     [ '[ nip @ ] ] dip if ;
     inline
 
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 0ae92a0c07..fe1f5e5a38 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -74,8 +74,12 @@ M: float-regs store-return-reg
     [ [ align-sub ] [ call ] bi* ]
     [ [ align-add ] [ drop ] bi* ] 2bi ; inline
 
-M: x86.32 %load-indirect
-    0 [] MOV rc-absolute-cell rel-literal ;
+M: x86.64 rel-literal-x86 rc-absolute-cell rel-literal ;
+
+M: x86.32 %prologue ( n -- )
+    dup PUSH
+    0 PUSH rc-absolute-cell rel-this
+    stack-reg swap 3 cells - SUB ;
 
 M: object %load-param-reg 3drop ;
 
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 6938db2afd..1e5922122e 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -32,8 +32,13 @@ M: float-regs return-reg drop XMM0 ;
 M: float-regs param-regs
     drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
-M: x86.64 %load-indirect
-    0 [] MOV rc-relative rel-literal ;
+M: x86.64 rel-literal-x86 rc-relative rel-literal ;
+
+M: x86.64 %prologue ( n -- )
+    temp-reg-1 0 MOV rc-absolute-cell rel-this
+    dup PUSH
+    temp-reg-1 PUSH
+    stack-reg swap 3 cells - SUB ;
 
 M: stack-params %load-param-reg
     drop
@@ -53,8 +58,8 @@ M: stack-params %save-param-reg
     ] with-scope ; inline
 
 ! The ABI for passing structs by value is pretty messed up
-"void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>reg-class)
+<< "void*" c-type clone "__stack_value" define-primitive-type
+stack-params "__stack_value" c-type (>>reg-class) >>
 
 : struct-types&offset ( struct-type -- pairs )
     fields>> [
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 7db725c6a5..9c738d3d34 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -14,6 +14,10 @@ HOOK: temp-reg-2 cpu ( -- reg )
 
 M: x86 %load-immediate MOV ;
 
+HOOK: rel-literal-x86 cpu ( literal -- )
+
+M: x86 %load-indirect swap 0 [] MOV rel-literal-x86 ;
+
 HOOK: ds-reg cpu ( -- reg )
 HOOK: rs-reg cpu ( -- reg )
 
@@ -178,7 +182,7 @@ M: x86 %copy-float MOVSD ;
 M: x86 %unbox-float ( dst src -- )
     float-offset [+] MOVSD ;
 
-M:: x86 %unbox-any-c-ptr ( dst src dst temp -- )
+M:: x86 %unbox-any-c-ptr ( dst src temp -- )
     [
         { "is-byte-array" "end" "start" } [ define-label ] each
         dst 0 MOV
@@ -269,9 +273,9 @@ M:: x86 %box-alien ( dst src temp -- )
 
 : small-reg ( reg size -- reg' )
     {
-        { 1 small-reg-1 }
-        { 2 small-reg-2 }
-        { 4 small-reg-4 }
+        { 1 [ small-reg-1 ] }
+        { 2 [ small-reg-2 ] }
+        { 4 [ small-reg-4 ] }
     } case ;
 
 : small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
@@ -287,7 +291,7 @@ M:: x86 %box-alien ( dst src temp -- )
     #! call the quot with that. Otherwise, we find a small
     #! register that is not equal to src, and call quot, saving
     #! and restoring the small register.
-    dst small-regs memq? [ src quot call ] [
+    dst small-regs memq? [ dst src quot call ] [
         src small-reg-that-isn't
         [ src quot call ]
         with-save/restore
@@ -381,17 +385,39 @@ HOOK: stack-reg cpu ( -- reg )
 : decr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
 
-M: x86 %prologue ( n -- )
-    temp-reg-1 0 MOV rc-absolute-cell rel-this
-    dup PUSH
-    temp-reg-1 PUSH
-    stack-reg swap 3 cells - SUB ;
-
 : incr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
 
 M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 
+: %boolean ( dst word -- )
+    over \ f tag-number MOV
+    0 [] swap execute
+    \ t rel-literal-x86 ; inline
+
+M: x86 %compare ( dst cc src1 src2 -- )
+    CMP {
+        { cc< [ \ CMOVL %boolean ] }
+        { cc<= [ \ CMOVLE %boolean ] }
+        { cc> [ \ CMOVG %boolean ] }
+        { cc>= [ \ CMOVGE %boolean ] }
+        { cc= [ \ CMOVE %boolean ] }
+        { cc/= [ \ CMOVNE %boolean ] }
+    } case ;
+
+M: x86 %compare-imm ( dst cc src1 src2 -- )
+    %compare ;
+
+M: x86 %compare-float ( dst cc src1 src2 -- )
+    UCOMISD {
+        { cc< [ \ CMOVB %boolean ] }
+        { cc<= [ \ CMOVBE %boolean ] }
+        { cc> [ \ CMOVA %boolean ] }
+        { cc>= [ \ CMOVAE %boolean ] }
+        { cc= [ \ CMOVE %boolean ] }
+        { cc/= [ \ CMOVNE %boolean ] }
+    } case ;
+
 M: x86 %compare-branch ( label cc src1 src2 -- )
     CMP {
         { cc< [ JL ] }
@@ -399,6 +425,7 @@ M: x86 %compare-branch ( label cc src1 src2 -- )
         { cc> [ JG ] }
         { cc>= [ JGE ] }
         { cc= [ JE ] }
+        { cc/= [ JNE ] }
     } case ;
 
 M: x86 %compare-imm-branch ( label src1 src2 cc -- )
@@ -411,6 +438,7 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
         { cc> [ JA ] }
         { cc>= [ JAE ] }
         { cc= [ JE ] }
+        { cc/= [ JNE ] }
     } case ;
 
 : stack@ ( n -- op ) stack-reg swap [+] ;

From 1b06ab1b39207b50f9f30cb55bb47c491da58578 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 21 Oct 2008 23:17:32 -0500
Subject: [PATCH 050/318] Fixing various bugs

---
 basis/compiler/cfg/builder/builder.factor     |  2 +-
 basis/compiler/cfg/def-use/def-use.factor     |  2 +
 basis/compiler/cfg/hats/hats.factor           |  4 +-
 .../cfg/instructions/instructions.factor      |  3 +-
 .../cfg/intrinsics/alien/alien.factor         |  1 -
 .../cfg/intrinsics/allot/allot.factor         | 28 +++++----
 .../cfg/intrinsics/fixnum/fixnum.factor       |  4 +-
 .../cfg/intrinsics/float/float.factor         |  8 ++-
 .../cfg/intrinsics/slots/slots.factor         |  1 -
 .../cfg/intrinsics/utilities/utilities.factor |  2 +-
 .../cfg/stack-frame/stack-frame.factor        |  6 ++
 basis/compiler/tests/intrinsics.factor        | 57 ++++++++++---------
 basis/cpu/x86/32/32.factor                    |  2 +-
 basis/cpu/x86/64/64.factor                    |  3 +-
 .../cpu/x86/architecture/architecture.factor  | 46 +++++++++------
 15 files changed, 98 insertions(+), 71 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 7247534b91..28b46e4d19 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -98,7 +98,7 @@ GENERIC: emit-node ( node -- next )
 : emit-call ( word -- next )
     {
         { [ dup loops get key? ] [ loops get at local-recursive-call ] }
-        { [ tail-call? not ] [ ##simple-stack-frame ##call iterate-next ] }
+        { [ tail-call? not ] [ ##call iterate-next ] }
         { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
         [ ##epilogue ##jump stop-iterating ]
     } cond ;
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 37b050eda6..7e3167ea60 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -28,6 +28,8 @@ M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
 M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: ##compare-imm-branch uses-vregs src1>> 1array ;
 M: ##dispatch uses-vregs src>> 1array ;
+M: ##alien-getter uses-vregs src>> 1array ;
+M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
 M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: insn uses-vregs drop f ;
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index 705aa02701..1c6480048c 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -62,8 +62,8 @@ IN: compiler.cfg.hats
 : ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
 : ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
 : ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
-: ^^alien-float ( src -- dst ) ^^i1 ##alien-float ; inline
-: ^^alien-double ( src -- dst ) ^^i1 ##alien-double ; inline
+: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
+: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
 : ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
 : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
 : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 17b9728243..c29b723c6e 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -55,7 +55,6 @@ TUPLE: stack-frame
 spill-counts ;
 
 INSN: ##stack-frame stack-frame ;
- : ##simple-stack-frame ( -- ) T{ stack-frame } ##stack-frame ;
 INSN: ##call word ;
 INSN: ##jump word ;
 INSN: ##return ;
@@ -139,7 +138,7 @@ INSN: ##alien-double < ##alien-getter ;
 INSN: ##set-alien-integer-1 < ##alien-setter ;
 INSN: ##set-alien-integer-2 < ##alien-setter ;
 INSN: ##set-alien-integer-4 < ##alien-setter ;
-INSN: ##set-alien-cell < ##alien-getter ;
+INSN: ##set-alien-cell < ##alien-setter ;
 INSN: ##set-alien-float < ##alien-setter ;
 INSN: ##set-alien-double < ##alien-setter ;
 
diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor
index 087c759384..e49a00ae6f 100644
--- a/basis/compiler/cfg/intrinsics/alien/alien.factor
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@@ -16,7 +16,6 @@ IN: compiler.cfg.intrinsics.alien
 : prepare-alien-accessor ( infos -- offset-vreg )
     <reversed> [ second class>> ] [ first ] bi
     dup value-info-small-tagged? [
-        ds-drop
         literal>> (prepare-alien-accessor-imm)
     ] [ drop (prepare-alien-accessor) ] if ;
 
diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor
index 3c81367cfc..bcd5e713a9 100644
--- a/basis/compiler/cfg/intrinsics/allot/allot.factor
+++ b/basis/compiler/cfg/intrinsics/allot/allot.factor
@@ -13,20 +13,24 @@ IN: compiler.cfg.intrinsics.allot
 : emit-simple-allot ( node -- )
     [ in-d>> length ] [ node-output-infos first class>> ] bi
     [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
-    [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
+    [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi
+    ##gc ;
 
 : tuple-slot-regs ( layout -- vregs )
     [ size>> ds-load ] [ ^^load-literal ] bi prefix ;
 
-:: emit-<tuple-boa> ( node -- )
-    [let | layout [ node node-input-infos peek literal>> ] |
-        layout tuple-layout? [
-            ds-drop
-            layout tuple-slot-regs
-            layout size>> ^^allot-tuple
-            tuple ##set-slots
-        ] [ node emit-primitive ] if
-    ] ;
+: emit-<tuple-boa> ( node -- )
+    dup node-input-infos peek literal>>
+    dup tuple-layout? [
+        nip
+        ds-drop
+        [ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
+        [ tuple ##set-slots ] [ ds-push drop ] 2bi
+        ##gc
+    ] [ drop emit-primitive ] if ;
+
+: store-length ( len reg -- )
+    [ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
 
 : store-initial-element ( elt reg len -- )
     [ 2 + object tag-number ##set-slot-imm ] with with each ;
@@ -40,8 +44,10 @@ IN: compiler.cfg.intrinsics.allot
             [let | elt [ ds-pop ]
                    reg [ len ^^allot-array ] |
                 ds-drop
+                len reg store-length
                 elt reg len store-initial-element
                 reg ds-push
+                ##gc
             ]
         ] [ node emit-primitive ] if
     ] ;
@@ -57,8 +63,10 @@ IN: compiler.cfg.intrinsics.allot
             [let | elt [ 0 ^^load-literal ]
                    reg [ len ^^allot-byte-array ] |
                 ds-drop
+                len reg store-length
                 elt reg len bytes>cells store-initial-element
                 reg ds-push
+                ##gc
             ]
         ] [ node emit-primitive ] if
     ] ;
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index a6e8bf28e7..602a482528 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -3,7 +3,7 @@
 USING: sequences accessors layouts kernel math namespaces
 combinators fry locals
 compiler.tree.propagation.info
-compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.intrinsics.utilities ;
 IN: compiler.cfg.intrinsics.fixnum
 
@@ -60,4 +60,4 @@ IN: compiler.cfg.intrinsics.fixnum
     ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>bignum ( -- )
-    ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
+    ds-pop ^^untag-fixnum ^^integer>bignum ds-push ##gc ;
diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor
index c8bd326475..3d7ec5f433 100644
--- a/basis/compiler/cfg/intrinsics/float/float.factor
+++ b/basis/compiler/cfg/intrinsics/float/float.factor
@@ -1,11 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.stacks compiler.cfg.hats ;
+USING: kernel compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.instructions ;
 IN: compiler.cfg.intrinsics.float
 
 : emit-float-op ( insn -- )
     [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
-    ds-push ; inline
+    ds-push
+    ##gc ; inline
 
 : emit-float-comparison ( cc -- )
     [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
@@ -15,4 +17,4 @@ IN: compiler.cfg.intrinsics.float
     ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>float ( -- )
-    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
+    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ##gc  ;
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index 7817d59770..0b34ec6405 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -45,7 +45,6 @@ IN: compiler.cfg.intrinsics.slots
     dup node-input-infos
     dup second value-tag [
         nip
-        ds-drop
         [
             dup third value-info-small-tagged?
             [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
diff --git a/basis/compiler/cfg/intrinsics/utilities/utilities.factor b/basis/compiler/cfg/intrinsics/utilities/utilities.factor
index cd10b4e54e..bc6442886c 100644
--- a/basis/compiler/cfg/intrinsics/utilities/utilities.factor
+++ b/basis/compiler/cfg/intrinsics/utilities/utilities.factor
@@ -8,4 +8,4 @@ IN: compiler.cfg.intrinsics.utilities
     literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
 
 : emit-primitive ( node -- )
-    word>> ##simple-stack-frame ##call ;
+    word>> ##call ;
diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index 4443ea64f7..a1e006872b 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -21,6 +21,12 @@ M: ##stack-frame compute-stack-frame*
     frame-required? on
     stack-frame>> stack-frame [ max-stack-frame ] change ;
 
+M: ##gc compute-stack-frame*
+    drop frame-required? on ;
+
+M: ##call compute-stack-frame*
+    drop frame-required? on ;
+
 M: _spill compute-stack-frame*
     drop frame-required? on ;
 
diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor
index 530705af46..e012a42cc0 100644
--- a/basis/compiler/tests/intrinsics.factor
+++ b/basis/compiler/tests/intrinsics.factor
@@ -27,7 +27,7 @@ IN: compiler.tests
 
 [ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
 [ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
-[ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-call first ] unit-test
+[ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
 [ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
 [ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
 [ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test
@@ -252,31 +252,34 @@ cell 8 = [
 ! Some randomized tests
 : compiled-fixnum* fixnum* ;
 
-: test-fixnum* ( -- )
-    32 random-bits >fixnum 32 random-bits >fixnum
-    2dup
-    [ fixnum* ] 2keep compiled-fixnum* =
-    [ 2drop ] [ "Oops" throw ] if ;
-
-[ ] [ 10000 [ test-fixnum* ] times ] unit-test
+[ ] [
+    10000 [ 
+        32 random-bits >fixnum 32 random-bits >fixnum
+        2dup
+        [ fixnum* ] 2keep compiled-fixnum* =
+        [ 2drop ] [ "Oops" throw ] if
+    ] times
+] unit-test
 
 : compiled-fixnum>bignum fixnum>bignum ;
 
-: test-fixnum>bignum ( -- )
-    32 random-bits >fixnum
-    dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
-    [ drop ] [ "Oops" throw ] if ;
-
-[ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test
+[ ] [
+    10000 [
+        32 random-bits >fixnum
+        dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
+        [ drop ] [ "Oops" throw ] if
+    ] times
+] unit-test
 
 : compiled-bignum>fixnum bignum>fixnum ;
 
-: test-bignum>fixnum ( -- )
-    5 random [ drop 32 random-bits ] map product >bignum
-    dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
-    [ drop ] [ "Oops" throw ] if ;
-
-[ ] [ 10000 [ test-bignum>fixnum ] times ] unit-test
+[ ] [
+    10000 [
+        5 random [ drop 32 random-bits ] map product >bignum
+        dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
+        [ drop ] [ "Oops" throw ] if
+    ] times
+] unit-test
 
 ! Test overflow check removal
 [ t ] [
@@ -377,25 +380,23 @@ cell 8 = [
 [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
 
-: xword-def ( word -- def ) def>> [ { fixnum } declare ] prepend ;
-
 [ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
 [ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
 
-[ -100 ] [ -100 \ <char> xword-def compile-call *char ] unit-test
-[ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] unit-test
+[ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test
+[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test
 
 [ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
 [ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
 
-[ -1000 ] [ -1000 \ <short> xword-def compile-call *short ] unit-test
-[ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] unit-test
+[ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test
+[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test
 
 [ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
 [ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
 
-[ -100000 ] [ -100000 \ <int> xword-def compile-call *int ] unit-test
-[ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] unit-test
+[ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test
+[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
 
 [ t ] [ pi pi <double> *double = ] unit-test
 
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index fe1f5e5a38..1c597ac98a 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -221,7 +221,7 @@ M: x86.32 %alien-indirect ( -- )
 
 M: x86.32 %alien-callback ( quot -- )
     4 [
-        EAX %load-indirect
+        EAX swap %load-indirect
         EAX PUSH
         "c_to_factor" f %alien-invoke
     ] with-aligned-stack ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 1e5922122e..3b0403a07e 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -200,7 +200,8 @@ M: x86.64 %alien-indirect ( -- )
     RBP CALL ;
 
 M: x86.64 %alien-callback ( quot -- )
-    RDI %load-indirect "c_to_factor" f %alien-invoke ;
+    RDI swap %load-indirect
+    "c_to_factor" f %alien-invoke ;
 
 M: x86.64 %callback-value ( ctype -- )
     ! Save top of data stack
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 9c738d3d34..65067740d9 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -96,7 +96,7 @@ M: x86 %add     [+] LEA ;
 M: x86 %add-imm [+] LEA ;
 M: x86 %sub     2operand SUB ;
 M: x86 %sub-imm neg [+] LEA ;
-M: x86 %mul     2operand IMUL2 ;
+M: x86 %mul     2operand swap IMUL2 ;
 M: x86 %mul-imm 2operand IMUL2 ;
 M: x86 %and     2operand AND ;
 M: x86 %and-imm 2operand AND ;
@@ -146,7 +146,6 @@ M:: x86 %integer>bignum ( dst src temp -- )
 M:: x86 %bignum>integer ( dst src -- )
     [
         "nonzero" define-label
-        "positive" define-label
         "end" define-label
         dst src 1 bignum@ MOV
          ! if the length is 1, its just the sign and nothing else,
@@ -160,20 +159,27 @@ M:: x86 %bignum>integer ( dst src -- )
         dst src 3 bignum@ MOV
         ! is the sign negative?
         src 2 bignum@ 0 CMP
-        "positive" get JE
-        dst -1 IMUL2
-        "positive" resolve-label
-        dst 3 SHL
+        "end" get JE
+        dst NEG
         "end" resolve-label
     ] with-scope ;
 
-M: x86 %add-float 2operand ADDSD ;
-M: x86 %sub-float 2operand SUBSD ;
-M: x86 %mul-float 2operand MULSD ;
-M: x86 %div-float 2operand DIVSD ;
+: ?MOVSD ( dst src -- )
+    2dup = [ 2drop ] [ MOVSD ] if ; inline
 
-M: x86 %integer>float CVTTSD2SI ;
-M: x86 %float>integer CVTSI2SD ;
+: 1operand-fp ( dst src -- dst' )
+    dupd ?MOVSD ; inline
+
+: 2operand-fp ( dst src1 src2 -- dst src )
+    [ 1operand-fp ] dip ; inline
+
+M: x86 %add-float 2operand-fp ADDSD ;
+M: x86 %sub-float 2operand-fp SUBSD ;
+M: x86 %mul-float 2operand-fp MULSD ;
+M: x86 %div-float 2operand-fp DIVSD ;
+
+M: x86 %integer>float CVTSI2SD ;
+M: x86 %float>integer CVTTSD2SI ;
 
 M: x86 %copy ( dst src -- ) MOV ;
 
@@ -210,7 +216,7 @@ M:: x86 %unbox-any-c-ptr ( dst src temp -- )
 
 M:: x86 %box-float ( dst src temp -- )
     dst 16 float temp %allot
-    dst 8 float tag-number - [+] src MOVSD ;
+    dst float-offset [+] src MOVSD ;
 
 : alien@ ( reg n -- op ) cells object tag-number - [+] ;
 
@@ -291,21 +297,23 @@ M:: x86 %box-alien ( dst src temp -- )
     #! call the quot with that. Otherwise, we find a small
     #! register that is not equal to src, and call quot, saving
     #! and restoring the small register.
-    dst small-regs memq? [ dst src quot call ] [
+    dst small-reg-4 small-regs memq? [ dst src quot call ] [
         src small-reg-that-isn't
-        [ src quot call ]
-        with-save/restore
+        [| new-dst |
+            new-dst src quot call
+            dst new-dst MOV
+        ] with-save/restore
     ] if ; inline
 
 : %alien-integer-getter ( dst src size quot -- )
-    '[ [ _ small-reg ] dip @ ] with-small-register ; inline
+    '[ [ dup _ small-reg dup ] [ [] ] bi* MOV @ ]
+    with-small-register ; inline
 
 : %alien-unsigned-getter ( dst src size -- )
     [ MOVZX ] %alien-integer-getter ; inline
 
 M: x86 %alien-unsigned-1 1 %alien-unsigned-getter ;
 M: x86 %alien-unsigned-2 2 %alien-unsigned-getter ;
-M: x86 %alien-unsigned-4 4 %alien-unsigned-getter ;
 
 : %alien-signed-getter ( dst src size -- )
     [ MOVSX ] %alien-integer-getter ; inline
@@ -314,6 +322,8 @@ M: x86 %alien-signed-1 1 %alien-signed-getter ;
 M: x86 %alien-signed-2 2 %alien-signed-getter ;
 M: x86 %alien-signed-4 4 %alien-signed-getter ;
 
+M: x86 %alien-unsigned-4 4 [ 2drop ] %alien-integer-getter ;
+
 M: x86 %alien-cell [] MOV ;
 M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
 M: x86 %alien-double [] MOVSD ;

From f09813f6fd7b6611edf2e77d7507e84cabd67d02 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 22 Oct 2008 18:37:47 -0500
Subject: [PATCH 051/318] Alias analysis

---
 .../alias-analysis-tests.factor               | 122 +++++++
 .../cfg/alias-analysis/alias-analysis.factor  | 301 ++++++++++++++++++
 basis/compiler/cfg/copy-prop/copy-prop.factor |  12 +
 .../cfg/intrinsics/utilities/utilities.factor |  11 -
 basis/compiler/cfg/utilities/utilities.factor |  26 ++
 5 files changed, 461 insertions(+), 11 deletions(-)
 create mode 100644 basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
 create mode 100644 basis/compiler/cfg/alias-analysis/alias-analysis.factor
 create mode 100644 basis/compiler/cfg/copy-prop/copy-prop.factor
 delete mode 100644 basis/compiler/cfg/intrinsics/utilities/utilities.factor
 create mode 100644 basis/compiler/cfg/utilities/utilities.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..1ac6fc8e6f
--- /dev/null
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
@@ -0,0 +1,122 @@
+USING: compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.alias-analysis cpu.architecture tools.test
+kernel ;
+IN: compiler.cfg.alias-analysis.tests
+
+[ ] [
+    {
+        T{ ##load-indirect f V int-regs 1 "hello" }
+        T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
+    } alias-analysis drop
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##replace f V int-regs 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##replace f V int-regs 1 D 0 }
+        T{ ##replace f V int-regs 1 D 1 }
+    } alias-analysis
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##copy f V int-regs 2 V int-regs 1 }
+        T{ ##replace f V int-regs 2 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##copy f V int-regs 2 V int-regs 1 }
+        T{ ##replace f V int-regs 2 D 0 }
+        T{ ##replace f V int-regs 2 D 1 }
+    } alias-analysis
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##peek f V int-regs 2 D 0 }
+        T{ ##copy f V int-regs 3 V int-regs 2 }
+        T{ ##copy f V int-regs 4 V int-regs 1 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 1 }
+        T{ ##peek f V int-regs 2 D 0 }
+        T{ ##copy f V int-regs 3 V int-regs 2 }
+        T{ ##copy f V int-regs 4 V int-regs 1 }
+        T{ ##replace f V int-regs 3 D 0 }
+        T{ ##replace f V int-regs 4 D 1 }
+    } alias-analysis
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##peek f V int-regs 2 D 2 f }
+        T{ ##replace f V int-regs 1 D 0 f }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##peek f V int-regs 2 D 2 f }
+        T{ ##replace f V int-regs 2 D 0 f }
+        T{ ##replace f V int-regs 1 D 0 f }
+    } alias-analysis
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##copy f V int-regs 3 V int-regs 1 f }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##replace f V int-regs 1 D 1 f }
+        T{ ##peek f V int-regs 3 D 1 f }
+        T{ ##replace f V int-regs 4 D 1 f }
+    } alias-analysis
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##peek f V int-regs 2 D 0 f }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##peek f V int-regs 2 D 0 f }
+        T{ ##replace f V int-regs 1 D 0 f }
+        T{ ##replace f V int-regs 2 D 1 f }
+        T{ ##replace f V int-regs 2 D 0 f }
+        T{ ##replace f V int-regs 1 D 1 f }
+    } alias-analysis
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##peek f V int-regs 2 D 0 f }
+        T{ ##copy f V int-regs 3 V int-regs 2 f }
+        T{ ##copy f V int-regs 4 V int-regs 1 f }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##peek f V int-regs 2 D 0 f }
+        T{ ##replace f V int-regs 1 D 0 f }
+        T{ ##replace f V int-regs 2 D 1 f }
+        T{ ##peek f V int-regs 3 D 1 f }
+        T{ ##peek f V int-regs 4 D 0 f }
+        T{ ##replace f V int-regs 3 D 0 f }
+        T{ ##replace f V int-regs 4 D 1 f }
+    } alias-analysis
+] unit-test
diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
new file mode 100644
index 0000000000..e98f6e8bea
--- /dev/null
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -0,0 +1,301 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math namespaces assocs hashtables sequences
+accessors vectors combinators sets classes compiler.cfg
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.instructions.syntax compiler.cfg.copy-prop ;
+IN: compiler.cfg.alias-analysis
+
+! Alias analysis -- must be run after compiler.cfg.height.
+!
+! We try to eliminate redundant slot and stack
+! traffic using some simple heuristics.
+! 
+! All heap-allocated objects which are loaded from the stack, or
+! other object slots are pessimistically assumed to belong to
+! the same alias class.
+!
+! Freshly-allocated objects get their own alias class.
+!
+! The data and retain stack pointer registers are treated
+! uniformly, and each one gets its own alias class.
+! 
+! Simple pseudo-C example showing load elimination:
+! 
+! int *x, *y, z: inputs
+! int a, b, c, d, e: locals
+! 
+! Before alias analysis:
+!
+! a = x[2]
+! b = x[2]
+! c = x[3]
+! y[2] = z
+! d = x[2]
+! e = y[2]
+! f = x[3]
+!
+! After alias analysis:
+!
+! a = x[2]
+! b = a /* ELIMINATED */
+! c = x[3]
+! y[2] = z
+! d = x[2] /* if x=y, d=z, if x!=y, d=b; NOT ELIMINATED */
+! e = z /* ELIMINATED */
+! f = c /* ELIMINATED */
+!
+! Simple pseudo-C example showing store elimination:
+!
+! Before alias analysis:
+!
+! x[0] = a
+! b = x[n]
+! x[0] = c
+! x[1] = d
+! e = x[0]
+! x[1] = c
+!
+! After alias analysis:
+!
+! x[0] = a /* dead if n = 0, live otherwise; NOT ELIMINATED */
+! b = x[n]
+! x[0] = c
+! /* x[1] = d */  /* ELIMINATED */
+! e = c
+! x[1] = c
+
+! Map vregs -> alias classes
+SYMBOL: vregs>acs
+
+: check [ "BUG: static type error detected" throw ] unless* ; inline
+ 
+: vreg>ac ( vreg -- ac )
+    #! Only vregs produced by ##allot, ##peek and ##slot can
+    #! ever be used as valid inputs to ##slot and ##set-slot,
+    #! so we assert this fact by not giving alias classes to
+    #! other vregs.
+    vregs>acs get at check ;
+
+! Map alias classes -> sequence of vregs
+SYMBOL: acs>vregs
+
+: ac>vregs ( ac -- vregs ) acs>vregs get at ;
+
+: aliases ( vreg -- vregs )
+    #! All vregs which may contain the same value as vreg.
+    vreg>ac ac>vregs ;
+
+: each-alias ( vreg quot -- )
+    [ aliases ] dip each ; inline
+
+! Map vregs -> slot# -> vreg
+SYMBOL: live-slots
+
+! Current instruction number
+SYMBOL: insn#
+
+! Load/store history, for dead store elimination
+TUPLE: load insn# ;
+TUPLE: store insn# ;
+
+: new-action ( class -- action )
+    insn# get swap boa ; inline
+
+! Maps vreg -> slot# -> sequence of loads/stores
+SYMBOL: histories
+
+: history ( vreg -- history ) histories get at ;
+
+: set-ac ( vreg ac -- )
+    #! Set alias class of newly-seen vreg.
+    {
+        [ drop H{ } clone swap histories get set-at ]
+        [ drop H{ } clone swap live-slots get set-at ]
+        [ swap vregs>acs get set-at ]
+        [ acs>vregs get push-at ]
+    } 2cleave ;
+
+: live-slot ( slot#/f vreg -- vreg' )
+    #! If the slot number is unknown, we never reuse a previous
+    #! value.
+    over [ live-slots get at at ] [ 2drop f ] if ;
+
+: load-constant-slot ( value slot# vreg -- )
+    live-slots get at check set-at ;
+
+: load-slot ( value slot#/f vreg -- )
+    over [ load-constant-slot ] [ 3drop ] if ;
+
+: record-constant-slot ( slot# vreg -- )
+    #! A load can potentially read every store of this slot#
+    #! in that alias class.
+    [
+        history [ load new-action swap ?push ] change-at
+    ] with each-alias ;
+
+: record-computed-slot ( vreg -- )
+    #! Computed load is like a load of every slot touched so far
+    [
+        history values [ load new-action swap push ] each
+    ] each-alias ;
+
+: remember-slot ( value slot#/f vreg -- )
+    over
+    [ [ record-constant-slot ] [ load-constant-slot ] 2bi ]
+    [ 2nip record-computed-slot ] if ;
+
+SYMBOL: ac-counter
+
+: next-ac ( -- n )
+    ac-counter [ dup 1+ ] change ;
+
+! Alias class for objects which are loaded from the data stack
+! or other object slots. We pessimistically assume that they
+! can all alias each other.
+SYMBOL: heap-ac
+
+: set-heap-ac ( vreg -- ) heap-ac get set-ac ;
+
+: set-new-ac ( vreg -- ) next-ac set-ac ;
+
+: kill-constant-set-slot ( slot# vreg -- )
+    [ live-slots get at delete-at ] with each-alias ;
+
+: record-constant-set-slot ( slot# vreg -- )
+    history [
+        dup empty? [ dup peek store? [ dup pop* ] when ] unless
+        store new-action swap ?push
+    ] change-at ;
+
+: kill-computed-set-slot ( ac -- )
+    [ live-slots get at clear-assoc ] each-alias ;
+
+: remember-set-slot ( slot#/f vreg -- )
+    over [
+        [ record-constant-set-slot ]
+        [ 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 ;
+
+! We treat slot accessors and stack traffic alike
+GENERIC: insn-slot# ( insn -- slot#/f )
+GENERIC: insn-object ( insn -- vreg )
+
+M: ##peek insn-slot# loc>> n>> ;
+M: ##replace insn-slot# loc>> n>> ;
+M: ##slot insn-slot# slot>> constant ;
+M: ##slot-imm insn-slot# slot>> ;
+M: ##set-slot insn-slot# slot>> constant ;
+M: ##set-slot-imm insn-slot# slot>> ;
+
+M: ##peek insn-object loc>> class ;
+M: ##replace insn-object loc>> class ;
+M: ##slot insn-object obj>> resolve ;
+M: ##slot-imm insn-object obj>> resolve ;
+M: ##set-slot insn-object obj>> resolve ;
+M: ##set-slot-imm insn-object obj>> resolve ;
+
+: init-alias-analysis ( -- )
+    H{ } clone histories set
+    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
+    next-ac heap-ac set
+
+    ds-loc next-ac set-ac
+    rs-loc next-ac set-ac ;
+
+GENERIC: analyze-aliases* ( insn -- insn' )
+
+M: ##load-immediate analyze-aliases*
+    dup [ val>> ] [ dst>> ] bi constants get set-at ;
+
+M: ##load-indirect analyze-aliases*
+    dup dst>> set-heap-ac ;
+
+M: ##allot analyze-aliases*
+    #! A freshly allocated object is distinct from any other
+    #! object.
+    dup dst>> set-new-ac ;
+
+M: ##read analyze-aliases*
+    dup dst>> set-heap-ac
+    dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
+    2dup live-slot dup [
+        2nip f \ ##copy boa 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
+    #! from?
+    live-slot = ;
+
+M: ##write analyze-aliases*
+    dup
+    [ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
+    [ remember-set-slot drop ] [ load-slot ] 3bi ;
+
+M: ##copy analyze-aliases*
+    #! The output vreg gets the same alias class as the input
+    #! vreg, since they both contain the same value.
+    dup record-copy ;
+
+M: insn analyze-aliases* ;
+
+: analyze-aliases ( insns -- insns' )
+    [ insn# set analyze-aliases* ] map-index sift ;
+
+SYMBOL: live-stores
+
+: compute-live-stores ( -- )
+    histories get
+    values [
+        values [ [ store? ] filter [ insn#>> ] map ] map concat
+    ] map concat unique
+    live-stores set ;
+
+GENERIC: eliminate-dead-stores* ( insn -- insn' )
+
+: (eliminate-dead-stores) ( insn -- insn' )
+    dup insn-slot# [
+        insn# get live-stores get key? [
+            drop f
+        ] unless
+    ] when ;
+
+M: ##replace eliminate-dead-stores*
+    #! Writes to above the top of the stack can be pruned also.
+    #! This is sound since any such writes are not observable
+    #! after the basic block, and any reads of those locations
+    #! will have been converted to copies by analyze-slot,
+    #! and the final stack height of the basic block is set at
+    #! the beginning by compiler.cfg.stack.
+    dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ;
+
+M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
+
+M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
+
+M: insn eliminate-dead-stores* ;
+
+: eliminate-dead-stores ( insns -- insns' )
+    [ insn# set eliminate-dead-stores* ] map-index sift ;
+
+: alias-analysis ( insns -- insns' )
+    init-alias-analysis
+    analyze-aliases
+    compute-live-stores
+    eliminate-dead-stores ;
diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor
new file mode 100644
index 0000000000..52cc75f047
--- /dev/null
+++ b/basis/compiler/cfg/copy-prop/copy-prop.factor
@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors ;
+IN: compiler.cfg.copy-prop
+
+SYMBOL: copies
+
+: resolve ( vreg -- vreg )
+    dup copies get at swap or ;
+
+: record-copy ( insn -- )
+    [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
diff --git a/basis/compiler/cfg/intrinsics/utilities/utilities.factor b/basis/compiler/cfg/intrinsics/utilities/utilities.factor
deleted file mode 100644
index bc6442886c..0000000000
--- a/basis/compiler/cfg/intrinsics/utilities/utilities.factor
+++ /dev/null
@@ -1,11 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math layouts cpu.architecture
-compiler.cfg.instructions ;
-IN: compiler.cfg.intrinsics.utilities
-
-: value-info-small-tagged? ( value-info -- ? )
-    literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
-
-: emit-primitive ( node -- )
-    word>> ##call ;
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
new file mode 100644
index 0000000000..0c452f8f3c
--- /dev/null
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -0,0 +1,26 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math layouts namespaces cpu.architecture
+namespaces compiler.cfg compiler.cfg.instructions ;
+IN: compiler.cfg.utilities
+
+: value-info-small-tagged? ( value-info -- ? )
+    literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
+
+: set-basic-block ( basic-block -- )
+    [ basic-block set ] [ instructions>> building set ] bi ;
+
+: begin-basic-block ( -- )
+    <basic-block> basic-block get [
+        dupd successors>> push
+    ] when*
+    set-basic-block ;
+
+: end-basic-block ( -- )
+    building off
+    basic-block off ;
+
+: emit-primitive ( node -- )
+    word>> ##call begin-basic-block ;
+
+: need-gc ( -- ) basic-block get t >>gc drop ;

From 73d01452cb627c36723c7c7c04c22c899065502e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 22 Oct 2008 18:38:30 -0500
Subject: [PATCH 052/318] Replace ##gc with a gc flag in the basic block

---
 basis/compiler/cfg/builder/builder.factor      | 18 +++---------------
 basis/compiler/cfg/cfg.factor                  |  9 +++++----
 .../cfg/instructions/instructions.factor       |  5 +++--
 .../compiler/cfg/intrinsics/alien/alien.factor |  2 +-
 .../compiler/cfg/intrinsics/allot/allot.factor | 10 +++++-----
 .../cfg/intrinsics/fixnum/fixnum.factor        |  4 ++--
 .../compiler/cfg/intrinsics/float/float.factor |  7 ++++---
 .../compiler/cfg/intrinsics/slots/slots.factor |  2 +-
 .../cfg/stack-frame/stack-frame.factor         |  4 ++--
 basis/compiler/codegen/codegen.factor          |  2 +-
 10 files changed, 27 insertions(+), 36 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 28b46e4d19..e46233add2 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -12,6 +12,7 @@ compiler.cfg
 compiler.cfg.hats
 compiler.cfg.stacks
 compiler.cfg.iterator
+compiler.cfg.utilities
 compiler.cfg.registers
 compiler.cfg.intrinsics
 compiler.cfg.instructions
@@ -20,19 +21,6 @@ IN: compiler.cfg.builder
 
 ! Convert tree SSA IR to CFG SSA IR.
 
-: set-basic-block ( basic-block -- )
-    [ basic-block set ] [ instructions>> building set ] bi ;
-
-: begin-basic-block ( -- )
-    <basic-block> basic-block get [
-        dupd successors>> push
-    ] when*
-    set-basic-block ;
-
-: end-basic-block ( -- )
-    building off
-    basic-block off ;
-
 : stop-iterating ( -- next ) end-basic-block f ;
 
 SYMBOL: procedures
@@ -98,7 +86,7 @@ GENERIC: emit-node ( node -- next )
 : emit-call ( word -- next )
     {
         { [ dup loops get key? ] [ loops get at local-recursive-call ] }
-        { [ tail-call? not ] [ ##call iterate-next ] }
+        { [ tail-call? not ] [ ##call begin-basic-block iterate-next ] }
         { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
         [ ##epilogue ##jump stop-iterating ]
     } cond ;
@@ -241,7 +229,7 @@ M: #terminate emit-node drop stop-iterating ;
 
 : emit-alien-node ( node quot -- next )
     [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
-    iterate-next ; inline
+    begin-basic-block iterate-next ; inline
 
 M: #alien-invoke emit-node
     [ ##alien-invoke ] emit-alien-node ;
diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 8ce3260153..9e9c26b0f8 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -7,17 +7,18 @@ TUPLE: cfg entry word label ;
 
 C: <cfg> cfg
 
-! - "number" and "visited" is used by linearization.
 TUPLE: basic-block < identity-tuple
-visited
+id
 number
 instructions
-successors ;
+successors
+gc ;
 
 : <basic-block> ( -- basic-block )
     basic-block new
         V{ } clone >>instructions
-        V{ } clone >>successors ;
+        V{ } clone >>successors
+        \ basic-block counter >>id ;
 
 TUPLE: mr { instructions array } word label spill-counts ;
 
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index c29b723c6e..927d806b17 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -29,7 +29,7 @@ TUPLE: ##effect < insn { src vreg } ;
 TUPLE: ##read < ##flushable ;
 TUPLE: ##write < ##effect ;
 
-TUPLE: ##alien-getter < ##read { src vreg } ;
+TUPLE: ##alien-getter < ##flushable { src vreg } ;
 TUPLE: ##alien-setter < ##effect { value vreg } ;
 
 ! Stack operations
@@ -145,7 +145,6 @@ INSN: ##set-alien-double < ##alien-setter ;
 ! Memory allocation
 INSN: ##allot < ##flushable size class { temp vreg } ;
 INSN: ##write-barrier < ##effect card# table ;
-INSN: ##gc ;
 
 ! FFI
 INSN: ##alien-invoke params ;
@@ -194,6 +193,8 @@ INSN: _epilogue stack-frame ;
 
 INSN: _label id ;
 
+INSN: _gc ;
+
 INSN: _branch label ;
 
 TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor
index e49a00ae6f..6b9bc9fcce 100644
--- a/basis/compiler/cfg/intrinsics/alien/alien.factor
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@@ -4,7 +4,7 @@ USING: accessors kernel sequences alien math classes.algebra
 fry locals combinators cpu.architecture
 compiler.tree.propagation.info
 compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
-compiler.cfg.intrinsics.utilities ;
+compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.alien
 
 : (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor
index bcd5e713a9..a42542cb70 100644
--- a/basis/compiler/cfg/intrinsics/allot/allot.factor
+++ b/basis/compiler/cfg/intrinsics/allot/allot.factor
@@ -4,7 +4,7 @@ USING: kernel math math.order sequences accessors arrays
 byte-arrays layouts classes.tuple.private fry locals
 compiler.tree.propagation.info compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.stacks
-compiler.cfg.intrinsics.utilities ;
+compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.allot
 
 : ##set-slots ( regs obj class -- )
@@ -14,7 +14,7 @@ IN: compiler.cfg.intrinsics.allot
     [ in-d>> length ] [ node-output-infos first class>> ] bi
     [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
     [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi
-    ##gc ;
+    need-gc ;
 
 : tuple-slot-regs ( layout -- vregs )
     [ size>> ds-load ] [ ^^load-literal ] bi prefix ;
@@ -26,7 +26,7 @@ IN: compiler.cfg.intrinsics.allot
         ds-drop
         [ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
         [ tuple ##set-slots ] [ ds-push drop ] 2bi
-        ##gc
+        need-gc
     ] [ drop emit-primitive ] if ;
 
 : store-length ( len reg -- )
@@ -47,7 +47,7 @@ IN: compiler.cfg.intrinsics.allot
                 len reg store-length
                 elt reg len store-initial-element
                 reg ds-push
-                ##gc
+                need-gc
             ]
         ] [ node emit-primitive ] if
     ] ;
@@ -66,7 +66,7 @@ IN: compiler.cfg.intrinsics.allot
                 len reg store-length
                 elt reg len bytes>cells store-initial-element
                 reg ds-push
-                ##gc
+                need-gc
             ]
         ] [ node emit-primitive ] if
     ] ;
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index 602a482528..e47b12009d 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -4,7 +4,7 @@ USING: sequences accessors layouts kernel math namespaces
 combinators fry locals
 compiler.tree.propagation.info
 compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.intrinsics.utilities ;
+compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.fixnum
 
 : (emit-fixnum-imm-op) ( infos insn -- dst )
@@ -60,4 +60,4 @@ IN: compiler.cfg.intrinsics.fixnum
     ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>bignum ( -- )
-    ds-pop ^^untag-fixnum ^^integer>bignum ds-push ##gc ;
+    ds-pop ^^untag-fixnum ^^integer>bignum ds-push need-gc ;
diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor
index 3d7ec5f433..0d0a9c45c6 100644
--- a/basis/compiler/cfg/intrinsics/float/float.factor
+++ b/basis/compiler/cfg/intrinsics/float/float.factor
@@ -1,13 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel compiler.cfg.stacks compiler.cfg.hats
-compiler.cfg.instructions ;
+compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.float
 
 : emit-float-op ( insn -- )
     [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
     ds-push
-    ##gc ; inline
+    need-gc ; inline
 
 : emit-float-comparison ( cc -- )
     [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
@@ -17,4 +17,5 @@ IN: compiler.cfg.intrinsics.float
     ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>float ( -- )
-    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ##gc  ;
+    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push
+    need-gc ;
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index 0b34ec6405..3fea26c1af 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -3,7 +3,7 @@
 USING: layouts namespaces kernel accessors sequences
 classes.algebra compiler.tree.propagation.info
 compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.intrinsics.utilities ;
+compiler.cfg.utilities ;
 IN: compiler.cfg.intrinsics.slots
 
 : emit-tag ( -- )
diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index a1e006872b..414fd8f7e7 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -21,10 +21,10 @@ M: ##stack-frame compute-stack-frame*
     frame-required? on
     stack-frame>> stack-frame [ max-stack-frame ] change ;
 
-M: ##gc compute-stack-frame*
+M: ##call compute-stack-frame*
     drop frame-required? on ;
 
-M: ##call compute-stack-frame*
+M: _gc compute-stack-frame*
     drop frame-required? on ;
 
 M: _spill compute-stack-frame*
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index eca909baf7..18e923bbc2 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -201,7 +201,7 @@ M: ##write-barrier generate-insn
     [ table>> register ]
     tri %write-barrier ;
 
-M: ##gc generate-insn drop %gc ;
+M: _gc generate-insn drop %gc ;
 
 ! ##alien-invoke
 GENERIC: reg-size ( register-class -- n )

From 1f693b50b325822e49e0ebe1ec5390e42cf29b79 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 22 Oct 2008 18:39:41 -0500
Subject: [PATCH 053/318] Massive focused action

---
 basis/compiler/cfg/debugger/debugger.factor   |  4 ++-
 .../cfg/linearization/linearization.factor    |  5 +++-
 basis/compiler/cfg/registers/registers.factor |  4 +--
 basis/compiler/cfg/rpo/rpo.factor             | 28 +++++++++++++------
 basis/compiler/cfg/utilities/utilities.factor |  5 ++--
 basis/compiler/compiler.factor                |  6 ++--
 6 files changed, 36 insertions(+), 16 deletions(-)

diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 294238fbbf..47935c193c 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -4,7 +4,8 @@ USING: kernel words sequences quotations namespaces io
 classes.tuple accessors prettyprint prettyprint.config
 compiler.tree.builder compiler.tree.optimizer
 compiler.cfg.builder compiler.cfg.linearization
-compiler.cfg.stack-frame compiler.cfg.linear-scan ;
+compiler.cfg.stack-frame compiler.cfg.linear-scan
+compiler.cfg.optimizer ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -19,6 +20,7 @@ SYMBOL: allocate-registers?
 
 : test-mr ( quot -- mrs )
     test-cfg [
+        optimize-cfg
         build-mr
         allocate-registers? get
         [ linear-scan build-stack-frame ] when
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index a906e77103..06c58ec938 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -53,7 +53,10 @@ M: ##compare-float-branch linearize-insn
     binary-conditional _compare-float-branch emit-branch ;
 
 : linearize-basic-block ( bb -- )
-    [ number>> _label ] [ linearize-insns ] bi ;
+    [ number>> _label ]
+    [ gc>> [ _gc ] when ]
+    [ linearize-insns ]
+    tri ;
 
 : linearize-basic-blocks ( rpo -- insns )
     [ [ linearize-basic-block ] each ] { } make ;
diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor
index 09d2feba6d..21572ec615 100644
--- a/basis/compiler/cfg/registers/registers.factor
+++ b/basis/compiler/cfg/registers/registers.factor
@@ -5,12 +5,12 @@ parser prettyprint.backend prettyprint.sections ;
 IN: compiler.cfg.registers
 
 ! Virtual registers, used by CFG and machine IRs
-TUPLE: vreg reg-class n ;
+TUPLE: vreg { reg-class read-only } { n read-only } ;
 SYMBOL: vreg-counter
 : next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
 
 ! Stack locations
-TUPLE: loc n ;
+TUPLE: loc { n read-only } ;
 
 TUPLE: ds-loc < loc ;
 C: <ds-loc> ds-loc
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index 9fe6d3c90a..7f4b09e68f 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/basis/compiler/cfg/rpo/rpo.factor
@@ -1,20 +1,32 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces make math sequences
-compiler.cfg.instructions ;
+USING: kernel accessors namespaces make math sequences sets
+assocs fry compiler.cfg.instructions ;
 IN: compiler.cfg.rpo
 
-: post-order-traversal ( basic-block -- )
-    dup visited>> [ drop ] [
-        t >>visited
+SYMBOL: visited
+
+: post-order-traversal ( bb -- )
+    dup id>> visited get key? [ drop ] [
+        dup id>> visited get conjoin
         [ successors>> [ post-order-traversal ] each ] [ , ] bi
     ] if ;
 
-: post-order ( procedure -- blocks )
+: post-order ( bb -- blocks )
     [ post-order-traversal ] { } make ;
 
 : number-blocks ( blocks -- )
     [ >>number drop ] each-index ;
 
-: reverse-post-order ( procedure -- blocks )
-    post-order <reversed> dup number-blocks ; inline
+: reverse-post-order ( bb -- blocks )
+    H{ } clone visited [
+        post-order <reversed> dup number-blocks
+    ] with-variable ; inline
+
+: each-basic-block ( cfg quot -- )
+    [ entry>> reverse-post-order ] dip each ; inline
+
+: change-basic-blocks ( cfg quot -- cfg' )
+    [ '[ _ change-instructions drop ] each-basic-block ]
+    [ drop ]
+    2bi ; inline
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index 0c452f8f3c..4afe7a590a 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math layouts namespaces cpu.architecture
-namespaces compiler.cfg compiler.cfg.instructions ;
+USING: accessors kernel math layouts make sequences
+cpu.architecture namespaces compiler.cfg
+compiler.cfg.instructions ;
 IN: compiler.cfg.utilities
 
 : value-info-small-tagged? ( value-info -- ? )
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index c02c1e8fda..f3767ec688 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -6,8 +6,9 @@ threads graphs generic combinators deques search-deques
 stack-checker stack-checker.state stack-checker.inlining
 compiler.errors compiler.units compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.builder
-compiler.cfg.linearization compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.codegen ;
+compiler.cfg.optimizer compiler.cfg.linearization
+compiler.cfg.linear-scan compiler.cfg.stack-frame
+compiler.codegen ;
 IN: compiler
 
 SYMBOL: compile-queue
@@ -73,6 +74,7 @@ t compile-dependencies? set-global
 
 : backend ( nodes word -- )
     build-cfg [
+        optimize-cfg
         build-mr
         linear-scan
         build-stack-frame

From 6d812aaa52ada8bfe28ce69936f9b46e2e3e28b2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 22 Oct 2008 18:41:10 -0500
Subject: [PATCH 054/318] Write barrier elimination

---
 .../write-barrier/write-barrier-tests.factor  | 72 +++++++++++++++++++
 .../cfg/write-barrier/write-barrier.factor    | 43 +++++++++++
 2 files changed, 115 insertions(+)
 create mode 100644 basis/compiler/cfg/write-barrier/write-barrier-tests.factor
 create mode 100644 basis/compiler/cfg/write-barrier/write-barrier.factor

diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
new file mode 100644
index 0000000000..7a4b1c488f
--- /dev/null
+++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
@@ -0,0 +1,72 @@
+USING: compiler.cfg.write-barrier compiler.cfg.instructions
+compiler.cfg.registers cpu.architecture arrays tools.test ;
+IN: compiler.cfg.write-barrier.tests
+
+[
+    {
+        T{ ##peek f V int-regs 4 D 0 f }
+        T{ ##copy f V int-regs 6 V int-regs 4 f }
+        T{ ##allot f V int-regs 7 24 array V int-regs 8 f }
+        T{ ##load-immediate f V int-regs 9 8 f }
+        T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f }
+        T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f }
+        T{ ##replace f V int-regs 7 D 0 f }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 4 D 0 }
+        T{ ##copy f V int-regs 6 V int-regs 4 }
+        T{ ##allot f V int-regs 7 24 array V int-regs 8 }
+        T{ ##load-immediate f V int-regs 9 8 }
+        T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 }
+        T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 }
+        T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
+        T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
+        T{ ##replace f V int-regs 7 D 0 }
+    } eliminate-write-barriers
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 4 24 }
+        T{ ##peek f V int-regs 5 D -1 }
+        T{ ##peek f V int-regs 6 D -2 }
+        T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
+        T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 4 24 }
+        T{ ##peek f V int-regs 5 D -1 }
+        T{ ##peek f V int-regs 6 D -2 }
+        T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
+        T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+    } eliminate-write-barriers
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 19 D -3 }
+        T{ ##peek f V int-regs 22 D -2 }
+        T{ ##copy f V int-regs 23 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
+        T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
+        T{ ##copy f V int-regs 26 V int-regs 19 }
+        T{ ##peek f V int-regs 28 D -1 }
+        T{ ##copy f V int-regs 29 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 19 D -3 }
+        T{ ##peek f V int-regs 22 D -2 }
+        T{ ##copy f V int-regs 23 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
+        T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
+        T{ ##copy f V int-regs 26 V int-regs 19 }
+        T{ ##peek f V int-regs 28 D -1 }
+        T{ ##copy f V int-regs 29 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
+        T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
+    } eliminate-write-barriers
+] unit-test
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
new file mode 100644
index 0000000000..f7e81c8b5c
--- /dev/null
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -0,0 +1,43 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sets sequences locals
+compiler.cfg compiler.cfg.instructions
+compiler.cfg.instructions.syntax compiler.cfg.copy-prop ;
+IN: compiler.cfg.write-barrier
+
+! Eliminate redundant write barrier hits.
+
+! Objects which have already been marked, as well as
+! freshly-allocated objects
+SYMBOL: safe
+
+! Objects which have been mutated
+SYMBOL: mutated
+
+GENERIC: eliminate-write-barrier ( insn -- insn' )
+
+M: ##allot eliminate-write-barrier
+    dup dst>> safe get conjoin ;
+
+M: ##write-barrier eliminate-write-barrier
+    dup src>> resolve dup
+    [ safe get key? not ]
+    [ mutated get key? ] bi and
+    [ safe get conjoin ] [ 2drop f ] if ;
+
+M: ##copy eliminate-write-barrier
+    dup record-copy ;
+
+M: ##set-slot eliminate-write-barrier
+    dup obj>> resolve mutated get conjoin ;
+
+M: ##set-slot-imm eliminate-write-barrier
+    dup obj>> resolve mutated get conjoin ;
+
+M: insn eliminate-write-barrier ;
+
+: eliminate-write-barriers ( insns -- insns' )
+    H{ } clone safe set
+    H{ } clone mutated set
+    H{ } clone copies set
+    [ eliminate-write-barrier ] map sift ;

From 3711aa3bcac26b9d068595bad218cec697b91180 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 22 Oct 2008 18:41:26 -0500
Subject: [PATCH 055/318] Stack height normalization

---
 basis/compiler/cfg/height/height.factor | 55 +++++++++++++++++++++++++
 1 file changed, 55 insertions(+)
 create mode 100644 basis/compiler/cfg/height/height.factor

diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
new file mode 100644
index 0000000000..d14cf4afb4
--- /dev/null
+++ b/basis/compiler/cfg/height/height.factor
@@ -0,0 +1,55 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math namespaces sequences kernel fry
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.instructions.syntax ;
+IN: compiler.cfg.height
+
+! Combine multiple stack height changes into one at the
+! start of the basic block.
+!
+! Alias analysis and value numbering assume this optimization
+! has been performed.
+
+SYMBOL: ds-height
+SYMBOL: rs-height
+
+GENERIC: compute-heights ( insn -- )
+
+M: ##inc-d compute-heights n>> ds-height [ + ] change ;
+M: ##inc-r compute-heights n>> rs-height [ + ] change ;
+M: insn compute-heights drop ;
+
+GENERIC: normalize-height* ( insn -- insn' )
+
+: normalize-inc-d/r ( insn stack -- insn' )
+    swap n>> '[ _ - ] change f ; inline
+
+M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
+M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
+
+GENERIC: loc-stack ( loc -- stack )
+
+M: ds-loc loc-stack drop ds-height ;
+M: rs-loc loc-stack drop rs-height ;
+
+GENERIC: <loc> ( n stack -- loc )
+
+M: ds-loc <loc> drop <ds-loc> ;
+M: rs-loc <loc> drop <rs-loc> ;
+
+: normalize-peek/replace ( insn -- insn' )
+    [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
+
+M: ##peek normalize-height* normalize-peek/replace ;
+M: ##replace normalize-height* normalize-peek/replace ;
+
+M: insn normalize-height* ;
+
+: normalize-height ( insns -- insns' )
+    0 ds-height set
+    0 rs-height set
+    [ [ compute-heights ] each ]
+    [ [ [ normalize-height* ] map sift ] with-scope ] bi
+    ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if
+    rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ;

From 9a07760542985c9fb4910beceae970c7e4f94480 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 22 Oct 2008 18:41:37 -0500
Subject: [PATCH 056/318] CFG optimizer

---
 basis/compiler/cfg/optimizer/optimizer.factor | 12 ++++++++++++
 1 file changed, 12 insertions(+)
 create mode 100644 basis/compiler/cfg/optimizer/optimizer.factor

diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
new file mode 100644
index 0000000000..242189f3f6
--- /dev/null
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg.rpo compiler.cfg.height
+compiler.cfg.alias-analysis compiler.cfg.write-barrier ;
+IN: compiler.cfg.optimizer
+
+: optimize-cfg ( cfg -- cfg' )
+    [
+        normalize-height
+        alias-analysis
+        eliminate-write-barriers
+    ] change-basic-blocks ;

From ba0ed21e1dd9ef43c594e8392ac0ba7191bacd8e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 22 Oct 2008 21:58:37 -0500
Subject: [PATCH 057/318] Better error message

---
 .../cfg/linear-scan/live-intervals/live-intervals.factor         | 1 +
 1 file changed, 1 insertion(+)

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 54cead850c..be151b2002 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -11,6 +11,7 @@ reg spill-to reload-from split-before split-after
 start end uses ;
 
 : add-use ( n live-interval -- )
+    dup live-interval? [ "No def" throw ] unless
     [ (>>end) ] [ uses>> push ] 2bi ;
 
 : <live-interval> ( start vreg -- live-interval )

From 084e64d0bcdddf53dd3d1c770e3c87849c400ec4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 22 Oct 2008 21:58:46 -0500
Subject: [PATCH 058/318] Tweak inheritance

---
 basis/compiler/cfg/instructions/instructions.factor | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 927d806b17..1615227631 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -21,6 +21,7 @@ TUPLE: ##unary/temp < ##unary { temp vreg } ;
 TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ;
 TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ;
 TUPLE: ##commutative < ##binary ;
+TUPLE: ##commutative-imm < ##binary-imm ;
 
 ! Instruction only used for its side effect, produces no values
 TUPLE: ##effect < insn { src vreg } ;
@@ -71,17 +72,17 @@ INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
 
 ! Integer arithmetic
 INSN: ##add < ##commutative ;
-INSN: ##add-imm < ##binary-imm ;
+INSN: ##add-imm < ##commutative-imm ;
 INSN: ##sub < ##binary ;
 INSN: ##sub-imm < ##binary-imm ;
 INSN: ##mul < ##commutative ;
-INSN: ##mul-imm < ##binary-imm ;
+INSN: ##mul-imm < ##commutative-imm ;
 INSN: ##and < ##commutative ;
-INSN: ##and-imm < ##binary-imm ;
+INSN: ##and-imm < ##commutative-imm ;
 INSN: ##or < ##commutative ;
-INSN: ##or-imm < ##binary-imm ;
+INSN: ##or-imm < ##commutative-imm ;
 INSN: ##xor < ##commutative ;
-INSN: ##xor-imm < ##binary-imm ;
+INSN: ##xor-imm < ##commutative-imm ;
 INSN: ##shl-imm < ##binary-imm ;
 INSN: ##shr-imm < ##binary-imm ;
 INSN: ##sar-imm < ##binary-imm ;

From d723b69990d7daf548d96b8466a8e3ed5de32ba7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 22 Oct 2008 21:59:07 -0500
Subject: [PATCH 059/318] Value numbering

---
 basis/compiler/cfg/optimizer/optimizer.factor |  20 ++-
 .../conditions/conditions.factor              |  48 ++++++
 .../constant-fold/constant-fold.factor        |  18 ++
 .../expressions/expressions.factor            |  85 ++++++++--
 .../cfg/value-numbering/graph/graph.factor    |  10 +-
 .../value-numbering/liveness/liveness.factor  |  27 +--
 .../propagate/propagate.factor                |  76 +++++----
 .../value-numbering/simplify/simplify.factor  | 160 ++++++++++++++++++
 .../value-numbering-tests.factor              |  50 ++++++
 .../value-numbering/value-numbering.factor    |  52 +++---
 10 files changed, 446 insertions(+), 100 deletions(-)
 create mode 100644 basis/compiler/cfg/value-numbering/conditions/conditions.factor
 create mode 100644 basis/compiler/cfg/value-numbering/constant-fold/constant-fold.factor
 create mode 100644 basis/compiler/cfg/value-numbering/simplify/simplify.factor
 create mode 100644 basis/compiler/cfg/value-numbering/value-numbering-tests.factor

diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 242189f3f6..598a4bfcea 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -1,12 +1,22 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg.rpo compiler.cfg.height
-compiler.cfg.alias-analysis compiler.cfg.write-barrier ;
+USING: kernel sequences compiler.cfg.rpo
+compiler.cfg.instructions
+compiler.cfg.height
+compiler.cfg.alias-analysis
+compiler.cfg.value-numbering
+compiler.cfg.write-barrier ;
 IN: compiler.cfg.optimizer
 
+: trivial? ( insns -- ? )
+    dup length 1 = [ first ##call? ] [ drop f ] if ;
+
 : optimize-cfg ( cfg -- cfg' )
     [
-        normalize-height
-        alias-analysis
-        eliminate-write-barriers
+        dup trivial? [
+            normalize-height
+            alias-analysis
+            value-numbering
+            eliminate-write-barriers
+        ] unless
     ] change-basic-blocks ;
diff --git a/basis/compiler/cfg/value-numbering/conditions/conditions.factor b/basis/compiler/cfg/value-numbering/conditions/conditions.factor
new file mode 100644
index 0000000000..5ef1c4fbc9
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/conditions/conditions.factor
@@ -0,0 +1,48 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences layouts accessors combinators
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.liveness
+compiler.cfg.value-numbering ;
+IN: compiler.cfg.value-numbering.conditions
+
+! The CFG builder produces naive code for the following code
+! sequence:
+!
+! fixnum< [ ... ] [ ... ] if
+!
+! The fixnum< comparison generates a boolean, which is then
+! tested against f.
+!
+! Using value numbering, we optimize the comparison of a boolean
+! against f where the boolean is the result of comparison.
+
+: ##branch-t? ( insn -- ? )
+    [ cc>> cc/= eq? ] [ src2>> \ f tag-number eq? ] bi and ; inline
+
+: of-boolean? ( insn -- expr/f ? )
+    src1>> vreg>expr dup compare-expr? ; inline
+
+: eliminate-boolean ( insn -- expr/f )
+    dup ##branch-t? [
+        of-boolean? [ drop f ] unless
+    ] [ drop f ] if ; inline
+
+M: ##compare-imm-branch number-values
+    dup eliminate-boolean [
+        [ in1>> live-vn ] [ in2>> live-vn ] bi
+    ] [ call-next-method ] ?if ;
+ 
+: >compare-expr< [ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
+: >compare-imm-expr< [ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
+
+M: ##compare-imm-branch eliminate
+    dup eliminate-boolean [
+        dup op>> {
+            { \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
+            { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
+            { \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
+        } case
+    ] [ call-next-method ] ?if ;
diff --git a/basis/compiler/cfg/value-numbering/constant-fold/constant-fold.factor b/basis/compiler/cfg/value-numbering/constant-fold/constant-fold.factor
new file mode 100644
index 0000000000..ed09bd7cec
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/constant-fold/constant-fold.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.expressions ;
+IN: compiler.cfg.value-numbering.constant-fold
+
+GENERIC: constant-fold ( insn -- insn' )
+
+M: vop constant-fold ;
+
+: expr>insn ( out constant-expr -- constant-op )
+    [ value>> ] [ op>> ] bi new swap >>value swap >>out ;
+
+M: pure-op constant-fold
+    dup out>>
+    dup vreg>expr
+    dup constant-expr? [ expr>insn nip ] [ 2drop ] if ;
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index f8fb0aab29..476ba7d0ab 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -1,23 +1,88 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes kernel math namespaces combinators
+compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
 IN: compiler.cfg.value-numbering.expressions
 
-! Referentially-transparent expressions.
-
+! Referentially-transparent expressions
 TUPLE: expr op ;
-
-! op is always %peek
-TUPLE: peek-expr < expr loc ;
 TUPLE: unary-expr < expr in ;
-TUPLE: load-literal-expr < expr obj ;
+TUPLE: binary-expr < expr in1 in2 ;
+TUPLE: commutative-expr < binary-expr ;
+TUPLE: compare-expr < binary-expr cc ;
+TUPLE: constant-expr < expr value ;
+
+: <constant> ( constant -- expr )
+    f swap constant-expr boa ; inline
+
+M: constant-expr equal?
+    over constant-expr? [
+        [ [ value>> ] bi@ = ]
+        [ [ value>> class ] bi@ = ] 2bi
+        and
+    ] [ 2drop f ] if ;
+
+SYMBOL: input-expr-counter
+
+: next-input-expr ( -- n )
+    input-expr-counter [ dup 1 + ] change ;
+
+! Expressions whose values are inputs to the basic block. We
+! can eliminate a second computation having the same 'n' as
+! the first one; we can also eliminate input-exprs whose
+! result is not used.
+TUPLE: input-expr < expr n ;
+
+: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
 
 GENERIC: >expr ( insn -- expr )
 
-M: ##peek >expr
-    [ class ] [ loc>> ] bi peek-expr boa ;
+M: ##load-immediate >expr val>> <constant> ;
 
-M: ##load-literal >expr
-    [ class ] [ obj>> ] bi load-literal-expr boa ;
+M: ##load-indirect >expr obj>> <constant> ;
 
 M: ##unary >expr
     [ class ] [ src>> vreg>vn ] bi unary-expr boa ;
+
+M: ##binary >expr
+    [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
+    binary-expr boa ;
+
+M: ##binary-imm >expr
+    [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
+    binary-expr boa ;
+
+M: ##commutative >expr
+    [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
+    commutative-expr boa ;
+
+M: ##commutative-imm >expr
+    [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
+    commutative-expr boa ;
+
+: compare>expr ( insn -- expr )
+    {
+        [ class ]
+        [ src1>> vreg>vn ]
+        [ src2>> vreg>vn ]
+        [ cc>> ]
+    } cleave compare-expr boa ; inline
+
+M: ##compare >expr compare>expr ;
+
+: compare-imm>expr ( insn -- expr )
+    {
+        [ class ]
+        [ src1>> vreg>vn ]
+        [ src2>> constant>vn ]
+        [ cc>> ]
+    } cleave compare-expr boa ; inline
+
+M: ##compare-imm >expr compare-imm>expr ;
+
+M: ##compare-float >expr compare>expr ;
+
+M: ##flushable >expr class next-input-expr input-expr boa ;
+
+: init-expressions ( -- )
+    0 input-expr-counter set ;
diff --git a/basis/compiler/cfg/value-numbering/graph/graph.factor b/basis/compiler/cfg/value-numbering/graph/graph.factor
index b0ae044fb7..7ec9eaf7ce 100644
--- a/basis/compiler/cfg/value-numbering/graph/graph.factor
+++ b/basis/compiler/cfg/value-numbering/graph/graph.factor
@@ -1,5 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math namespaces assocs biassocs ;
 IN: compiler.cfg.value-numbering.graph
 
 SYMBOL: vn-counter
@@ -13,7 +14,6 @@ SYMBOL: exprs>vns
 
 : vn>expr ( vn -- expr ) exprs>vns get value-at ;
 
-! biassoc mapping vregs to value numbers
 SYMBOL: vregs>vns
 
 : vreg>vn ( vreg -- vn ) vregs>vns get at ;
@@ -22,11 +22,11 @@ SYMBOL: vregs>vns
 
 : set-vn ( vn vreg -- ) vregs>vns get set-at ;
 
+: vreg>expr ( vreg -- expr ) vreg>vn vn>expr ; inline
+
+: vn>constant ( vn -- constant ) vn>expr value>> ; inline
+
 : init-value-graph ( -- )
     0 vn-counter set
     <bihash> exprs>vns set
     <bihash> vregs>vns set ;
-
-: reset-value-graph ( -- )
-    exprs>vns get clear-assoc
-    vregs>vns get clear-assoc ;
diff --git a/basis/compiler/cfg/value-numbering/liveness/liveness.factor b/basis/compiler/cfg/value-numbering/liveness/liveness.factor
index 127a584091..2dd2e56968 100644
--- a/basis/compiler/cfg/value-numbering/liveness/liveness.factor
+++ b/basis/compiler/cfg/value-numbering/liveness/liveness.factor
@@ -1,9 +1,15 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel assocs sets accessors
+compiler.cfg.instructions
+compiler.cfg.instructions.syntax
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.expressions ;
 IN: compiler.cfg.value-numbering.liveness
 
-! A set of VNs which are (transitively) used by side-effecting
-! instructions.
+! A set of VNs which are (transitively) used by effect-ops. This
+! is precisely the set of VNs whose value is needed outside of
+! the basic block.
 SYMBOL: live-vns
 
 GENERIC: live-expr ( expr -- )
@@ -14,12 +20,12 @@ GENERIC: live-expr ( expr -- )
         [ live-vns get conjoin ] [ vn>expr live-expr ] bi
     ] if ;
 
-M: peek-expr live-expr drop ;
-M: unary-expr live-expr in>> live-vn ;
-M: load-literal-expr live-expr in>> live-vn ;
-
 : live-vreg ( vreg -- ) vreg>vn live-vn ;
 
+M: expr live-expr drop ;
+M: unary-expr live-expr in>> live-vn ;
+M: binary-expr live-expr [ in1>> live-vn ] [ in2>> live-vn ] bi ;
+
 : live? ( vreg -- ? )
     dup vreg>vn tuck vn>vreg =
     [ live-vns get key? ] [ drop f ] if ;
@@ -27,12 +33,7 @@ M: load-literal-expr live-expr in>> live-vn ;
 : init-liveness ( -- )
     H{ } clone live-vns set ;
 
-GENERIC: eliminate ( insn -- insn/f )
+GENERIC: eliminate ( insn -- insn' )
 
-: (eliminate) ( insn -- insn/f )
-    dup dst>> live? [ drop f ] unless ;
-
-M: ##peek eliminate (eliminate) ;
-M: ##unary eliminate (eliminate) ;
-M: ##load-literal eliminate (eliminate) ;
+M: ##flushable eliminate dup dst>> live? [ drop f ] unless ;
 M: insn eliminate ;
diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
index 4bca1714ca..5142c3c776 100644
--- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor
+++ b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
@@ -1,58 +1,64 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs sequences kernel accessors
+compiler.cfg.instructions compiler.cfg.instructions.syntax
+compiler.cfg.value-numbering.graph ;
 IN: compiler.cfg.value-numbering.propagate
 
 ! If two vregs compute the same value, replace references to
 ! the latter with the former.
 
-: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ;
+: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline
 
-GENERIC: propogate ( insn -- insn )
+GENERIC: propagate ( insn -- insn )
 
-M: ##unary-branch propagate [ resolve ] change-src ;
+M: ##effect propagate
+    [ resolve ] change-src ;
 
-M: ##unary propogate [ resolve ] change-src ;
+M: ##unary propagate
+    [ resolve ] change-src ;
 
-M: ##flushable propagate ;
+M: ##binary propagate
+    [ resolve ] change-src1
+    [ resolve ] change-src2 ;
 
-M: ##replace propagate [ resolve ] change-src ;
+M: ##binary-imm propagate
+    [ resolve ] change-src1 ;
 
-M: ##inc-d propagate ;
+M: ##slot propagate
+    [ resolve ] change-obj
+    [ resolve ] change-slot ;
 
-M: ##inc-r propagate ;
+M: ##slot-imm propagate
+    [ resolve ] change-obj ;
 
-M: ##stack-frame propagate ;
+M: ##set-slot propagate
+    call-next-method
+    [ resolve ] change-obj
+    [ resolve ] change-slot ;
 
-M: ##call propagate ;
+M: ##set-slot-imm propagate
+    call-next-method
+    [ resolve ] change-obj ;
 
-M: ##jump propagate ;
+M: ##alien-getter propagate
+    call-next-method
+    [ resolve ] change-src ;
 
-M: ##return propagate ;
+M: ##alien-setter propagate
+    call-next-method
+    [ resolve ] change-value ;
 
-M: ##intrinsic propagate
-    [ [ resolve ] assoc-map ] change-defs-vregs
-    [ [ resolve ] assoc-map ] change-uses-vregs ;
+M: ##conditional-branch propagate
+    [ resolve ] change-src1
+    [ resolve ] change-src2 ;
 
-M: ##dispatch propagate [ resolve ] change-src ;
+M: ##compare-imm-branch propagate
+    [ resolve ] change-src1 ;
 
-M: ##dispatch-label propagate ;
+M: ##dispatch propagate
+    [ resolve ] change-src ;
 
-M: ##write-barrier propagate [ resolve ] change-src ;
+M: insn propagate ;
 
-M: ##alien-invoke propagate ;
-
-M: ##alien-indirect propagate ;
-
-M: ##alien-callback propagate ;
-
-M: ##callback-return propagate ;
-
-M: ##prologue propagate ;
-
-M: ##epilogue propagate ;
-
-M: ##branch propagate ;
-
-M: ##if-intrinsic propagate
-    [ [ resolve ] assoc-map ] change-defs-vregs
-    [ [ resolve ] assoc-map ] change-uses-vregs ;
+M: f propagate ;
diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
new file mode 100644
index 0000000000..4c3589d710
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
@@ -0,0 +1,160 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators classes math layouts
+compiler.cfg.instructions
+compiler.cfg.instructions.syntax
+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 )
+
+: simplify-not ( in -- vn/expr/f )
+    {
+        { [ dup constant-expr? ] [ value>> bitnot <constant> ] }
+        { [ dup op>> \ ##not = ] [ in>> ] }
+        [ drop f ]
+    } cond ;
+
+: simplify-box-float ( in -- vn/expr/f )
+    dup op>> \ ##unbox-float = [ in>> ] [ drop f ] if ;
+
+: simplify-unbox-float ( in -- vn/expr/f )
+    dup op>> \ ##box-float = [ in>> ] [ drop f ] if ;
+
+M: unary-expr simplify*
+    #! Note the copy propagation: a copy always simplifies to
+    #! its source VN.
+    [ in>> vn>expr ] [ op>> ] bi {
+        { \ ##copy [ ] }
+        { \ ##copy-float [ ] }
+        { \ ##not [ simplify-not ] }
+        { \ ##box-float [ simplify-box-float ] }
+        { \ ##unbox-float [ simplify-unbox-float ] }
+        [ 2drop f ]
+    } case ;
+
+! : expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
+! 
+! : expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline
+! 
+! : expr-neg-one? ( expr -- ? ) T{ constant-expr f f -1 } = ; inline
+! 
+! : identity ( in1 in2 val -- expr ) 2nip <constant> ; inline
+! 
+! : constant-fold? ( in1 in2 -- ? )
+!     [ constant-expr? ] both? ;
+! 
+! : constant-fold ( in1 in2 quot -- expr )
+!     2over constant-fold? [
+!         [ [ value>> ] bi@ ] dip call <constant>
+!     ] [ 3drop f ] if ; inline
+! 
+! : simplify-add ( in1 in2 -- vn/expr/f )
+!     {
+!         { [ over expr-zero? ] [ nip ] }
+!         { [ dup expr-zero? ] [ drop ] }
+!         [ [ + ] constant-fold ]
+!     } cond ;
+! 
+! : simplify-mul ( in1 in2 -- vn/expr/f )
+!     {
+!         { [ over expr-one? ] [ nip ] }
+!         { [ dup expr-one? ] [ drop ] }
+!         [ [ * ] constant-fold ]
+!     } cond ;
+! 
+! : simplify-and ( in1 in2 -- vn/expr/f )
+!     {
+!         { [ dup expr-zero? ] [ 0 identity ] }
+!         { [ dup expr-neg-one? ] [ drop ] }
+!         { [ 2dup = ] [ drop ] }
+!         [ [ bitand ] constant-fold ]
+!     } cond ;
+! 
+! : simplify-or ( in1 in2 -- vn/expr/f )
+!     {
+!         { [ dup expr-zero? ] [ drop ] }
+!         { [ dup expr-neg-one? ] [ -1 identity ] }
+!         { [ 2dup = ] [ drop ] }
+!         [ [ bitor ] constant-fold ]
+!     } cond ;
+! 
+! : simplify-xor ( in1 in2 -- vn/expr/f )
+!     {
+!         { [ dup expr-zero? ] [ drop ] }
+!         [ [ bitxor ] constant-fold ]
+!     } cond ;
+! 
+! : commutative-operands ( expr -- in1 in2 )
+!     [ in1>> vn>expr ] [ in2>> vn>expr ] bi
+!     over constant-expr? [ swap ] when ;
+! 
+! M: commutative-expr simplify*
+!     [ commutative-operands ] [ op>> ] bi {
+!         { ##add [ simplify-add ] }
+!         { ##mul [ simplify-mul ] }
+!         { ##and [ simplify-and ] }
+!         { ##or [ simplify-or ] }
+!         { ##xor [ simplify-xor ] }
+!         [ 3drop f ]
+!     } case ;
+! 
+! : simplify-sub ( in1 in2 -- vn/expr/f )
+!     {
+!         { [ dup expr-zero? ] [ drop ] }
+!         { [ 2dup = ] [ 0 identity ] }
+!         [ [ - ] constant-fold ]
+!     } cond ;
+! 
+! : simplify-shl ( in1 in2 -- vn/expr/f )
+!     {
+!         { [ dup expr-zero? ] [ drop ] }
+!         { [ over expr-zero? ] [ drop ] }
+!         [ [ shift ] constant-fold ]
+!     } cond ;
+! 
+! : unsigned ( n -- n' )
+!     cell-bits 2^ 1- bitand ;
+! 
+! : useless-shift? ( in1 in2 -- ? )
+!     over op>> ##shl = [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ;
+! 
+! : simplify-shr ( in1 in2 -- vn/expr/f )
+!     {
+!         { [ dup expr-zero? ] [ drop ] }
+!         { [ over expr-zero? ] [ drop ] }
+!         { [ 2dup useless-shift? ] [ drop in1>> ] }
+!         [ [ neg shift unsigned ] constant-fold ]
+!     } cond ;
+! 
+! : simplify-sar ( in1 in2 -- vn/expr/f )
+!     {
+!         { [ dup expr-zero? ] [ drop ] }
+!         { [ over expr-zero? ] [ drop ] }
+!         { [ 2dup useless-shift? ] [ drop in1>> ] }
+!         [ [ neg shift ] constant-fold ]
+!     } cond ;
+! 
+! : simplify-compare ( in1 in2 -- vn/expr/f )
+!     = [ +eq+ %cconst constant ] [ f ] if ;
+! 
+! M: binary-expr simplify*
+!     [ in1>> vn>expr ] [ in2>> vn>expr ] [ op>> ] tri {
+!         { ##sub [ simplify-isub ] }
+!         { ##shl [ simplify-shl ] }
+!         { ##shr [ simplify-shr ] }
+!         { ##sar [ simplify-sar ] }
+!         { ##compare [ simplify-compare ] }
+!         [ 3drop f ]
+!     } case ;
+
+M: expr simplify* drop f ;
+
+: simplify ( expr -- vn )
+    dup simplify* {
+        { [ dup not ] [ drop expr>vn ] }
+        { [ dup expr? ] [ expr>vn nip ] }
+        { [ dup integer? ] [ nip ] }
+    } cond ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
new file mode 100644
index 0000000000..81121f3fe9
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -0,0 +1,50 @@
+IN: compiler.cfg.value-numbering.tests
+USING: compiler.cfg.value-numbering compiler.cfg.instructions
+compiler.cfg.registers cpu.architecture tools.test kernel ;
+[
+    {
+        T{ ##peek f V int-regs 45 D 1 }
+        T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 45 D 1 }
+        T{ ##copy f V int-regs 48 V int-regs 45 }
+        T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
+    } value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 3 D 0 }
+        T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
+        T{ ##replace f V int-regs 4 D 0 }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 2 8 }
+        T{ ##peek f V int-regs 3 D 0 }
+        T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
+        T{ ##replace f V int-regs 4 D 0 }
+    } value-numbering
+] unit-test
+
+[ t ] [
+    {
+        T{ ##peek f V int-regs 1 D 0 }
+        T{ ##dispatch f V int-regs 1 V int-regs 2 }
+    } dup value-numbering =
+] unit-test
+
+[ t ] [
+    {
+        T{ ##peek f V int-regs 16 D 0 }
+        T{ ##peek f V int-regs 17 D -1 }
+        T{ ##sar-imm f V int-regs 18 V int-regs 17 3 }
+        T{ ##add-imm f V int-regs 19 V int-regs 16 13 }
+        T{ ##add f V int-regs 21 V int-regs 18 V int-regs 19 }
+        T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
+        T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
+        T{ ##replace f V int-regs 23 D 0 }
+    } dup value-numbering =
+] unit-test
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index a2957e59f8..b411efef3a 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -1,46 +1,34 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs biassocs classes kernel math accessors
+sorting sets sequences
+compiler.cfg.def-use
+compiler.cfg.instructions
+compiler.cfg.instructions.syntax
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.liveness
+compiler.cfg.value-numbering.propagate
+compiler.cfg.value-numbering.simplify ;
 IN: compiler.cfg.value-numbering
 
 : insn>vn ( insn -- vn ) >expr simplify ; inline
 
-GENERIC: make-value-node ( insn -- )
+GENERIC: number-values ( insn -- )
 
-M: ##unary-branch make-value-node src>> live-vreg ;
-M: ##unary make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
-M: ##flushable make-value-node drop ;
-M: ##load-literal make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
-M: ##peek make-value-node [ insn>vn ] [ dst>> ] bi set-vn ;
-M: ##replace make-value-node reset-value-graph ;
-M: ##inc-d make-value-node reset-value-graph ;
-M: ##inc-r make-value-node reset-value-graph ;
-M: ##stack-frame make-value-node reset-value-graph ;
-M: ##call make-value-node reset-value-graph ;
-M: ##jump make-value-node reset-value-graph ;
-M: ##return make-value-node reset-value-graph ;
-M: ##intrinsic make-value-node uses-vregs [ live-vreg ] each ;
-M: ##dispatch make-value-node reset-value-graph ;
-M: ##dispatch-label make-value-node reset-value-graph ;
-M: ##allot make-value-node drop ;
-M: ##write-barrier make-value-node drop ;
-M: ##gc make-value-node reset-value-graph ;
-M: ##replace make-value-node reset-value-graph ;
-M: ##alien-invoke make-value-node reset-value-graph ;
-M: ##alien-indirect make-value-node reset-value-graph ;
-M: ##alien-callback make-value-node reset-value-graph ;
-M: ##callback-return make-value-node reset-value-graph ;
-M: ##prologue make-value-node reset-value-graph ;
-M: ##epilogue make-value-node reset-value-graph ;
-M: ##branch make-value-node reset-value-graph ;
-M: ##if-intrinsic make-value-node uses-vregs [ live-vreg ] each ;
+M: ##flushable number-values
+    dup ##pure? [ dup call-next-method ] unless
+    [ insn>vn ] [ dst>> ] bi set-vn ;
+
+M: insn number-values uses-vregs [ live-vreg ] each ;
 
 : init-value-numbering ( -- )
     init-value-graph
     init-expressions
     init-liveness ;
 
-: value-numbering ( instructions -- instructions )
+: value-numbering ( insns -- insns' )
     init-value-numbering
-    [ [ make-value-node ] [ propagate ] bi ] map
-    [ eliminate ] map
-    sift ;
+    [ [ number-values ] each ]
+    [ [ eliminate propagate ] map sift ]
+    bi ;

From 52967c5bf1d51cd350b46271a78df1cbe783b8f7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 23 Oct 2008 02:49:26 -0500
Subject: [PATCH 060/318] Improved value numbering

---
 .../conditions/conditions.factor              |  48 -------
 .../constant-fold/constant-fold.factor        |  18 ---
 .../value-numbering/liveness/liveness.factor  |  39 ------
 .../propagate/propagate.factor                |   2 -
 .../value-numbering/rewrite/rewrite.factor    |  55 ++++++++
 .../value-numbering/simplify/simplify.factor  | 128 +-----------------
 .../value-numbering-tests.factor              |   2 +
 .../value-numbering/value-numbering.factor    |  27 +---
 8 files changed, 66 insertions(+), 253 deletions(-)
 delete mode 100644 basis/compiler/cfg/value-numbering/conditions/conditions.factor
 delete mode 100644 basis/compiler/cfg/value-numbering/constant-fold/constant-fold.factor
 delete mode 100644 basis/compiler/cfg/value-numbering/liveness/liveness.factor
 create mode 100644 basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

diff --git a/basis/compiler/cfg/value-numbering/conditions/conditions.factor b/basis/compiler/cfg/value-numbering/conditions/conditions.factor
deleted file mode 100644
index 5ef1c4fbc9..0000000000
--- a/basis/compiler/cfg/value-numbering/conditions/conditions.factor
+++ /dev/null
@@ -1,48 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences layouts accessors combinators
-compiler.cfg.instructions
-compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions
-compiler.cfg.value-numbering.liveness
-compiler.cfg.value-numbering ;
-IN: compiler.cfg.value-numbering.conditions
-
-! The CFG builder produces naive code for the following code
-! sequence:
-!
-! fixnum< [ ... ] [ ... ] if
-!
-! The fixnum< comparison generates a boolean, which is then
-! tested against f.
-!
-! Using value numbering, we optimize the comparison of a boolean
-! against f where the boolean is the result of comparison.
-
-: ##branch-t? ( insn -- ? )
-    [ cc>> cc/= eq? ] [ src2>> \ f tag-number eq? ] bi and ; inline
-
-: of-boolean? ( insn -- expr/f ? )
-    src1>> vreg>expr dup compare-expr? ; inline
-
-: eliminate-boolean ( insn -- expr/f )
-    dup ##branch-t? [
-        of-boolean? [ drop f ] unless
-    ] [ drop f ] if ; inline
-
-M: ##compare-imm-branch number-values
-    dup eliminate-boolean [
-        [ in1>> live-vn ] [ in2>> live-vn ] bi
-    ] [ call-next-method ] ?if ;
- 
-: >compare-expr< [ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
-: >compare-imm-expr< [ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
-
-M: ##compare-imm-branch eliminate
-    dup eliminate-boolean [
-        dup op>> {
-            { \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
-            { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
-            { \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
-        } case
-    ] [ call-next-method ] ?if ;
diff --git a/basis/compiler/cfg/value-numbering/constant-fold/constant-fold.factor b/basis/compiler/cfg/value-numbering/constant-fold/constant-fold.factor
deleted file mode 100644
index ed09bd7cec..0000000000
--- a/basis/compiler/cfg/value-numbering/constant-fold/constant-fold.factor
+++ /dev/null
@@ -1,18 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel
-compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions ;
-IN: compiler.cfg.value-numbering.constant-fold
-
-GENERIC: constant-fold ( insn -- insn' )
-
-M: vop constant-fold ;
-
-: expr>insn ( out constant-expr -- constant-op )
-    [ value>> ] [ op>> ] bi new swap >>value swap >>out ;
-
-M: pure-op constant-fold
-    dup out>>
-    dup vreg>expr
-    dup constant-expr? [ expr>insn nip ] [ 2drop ] if ;
diff --git a/basis/compiler/cfg/value-numbering/liveness/liveness.factor b/basis/compiler/cfg/value-numbering/liveness/liveness.factor
deleted file mode 100644
index 2dd2e56968..0000000000
--- a/basis/compiler/cfg/value-numbering/liveness/liveness.factor
+++ /dev/null
@@ -1,39 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs sets accessors
-compiler.cfg.instructions
-compiler.cfg.instructions.syntax
-compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions ;
-IN: compiler.cfg.value-numbering.liveness
-
-! A set of VNs which are (transitively) used by effect-ops. This
-! is precisely the set of VNs whose value is needed outside of
-! the basic block.
-SYMBOL: live-vns
-
-GENERIC: live-expr ( expr -- )
-
-: live-vn ( vn -- )
-    #! Mark a VN and all VNs used in its computation as live.
-    dup live-vns get key? [ drop ] [
-        [ live-vns get conjoin ] [ vn>expr live-expr ] bi
-    ] if ;
-
-: live-vreg ( vreg -- ) vreg>vn live-vn ;
-
-M: expr live-expr drop ;
-M: unary-expr live-expr in>> live-vn ;
-M: binary-expr live-expr [ in1>> live-vn ] [ in2>> live-vn ] bi ;
-
-: live? ( vreg -- ? )
-    dup vreg>vn tuck vn>vreg =
-    [ live-vns get key? ] [ drop f ] if ;
-
-: init-liveness ( -- )
-    H{ } clone live-vns set ;
-
-GENERIC: eliminate ( insn -- insn' )
-
-M: ##flushable eliminate dup dst>> live? [ drop f ] unless ;
-M: insn eliminate ;
diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
index 5142c3c776..c1d6ea562f 100644
--- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor
+++ b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
@@ -60,5 +60,3 @@ M: ##dispatch propagate
     [ resolve ] change-src ;
 
 M: insn propagate ;
-
-M: f propagate ;
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
new file mode 100644
index 0000000000..a5fcc58365
--- /dev/null
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -0,0 +1,55 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences layouts accessors combinators namespaces
+math
+compiler.cfg.instructions
+compiler.cfg.instructions.syntax
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.expressions ;
+IN: compiler.cfg.value-numbering.rewrite
+
+GENERIC: rewrite ( insn -- insn' )
+
+: ##branch-t? ( insn -- ? )
+    [ cc>> cc/= eq? ] [ src2>> \ f tag-number eq? ] bi and ; inline
+
+: rewrite-boolean-comparison? ( insn -- ? )
+    dup ##branch-t? [
+        src1>> vreg>expr compare-expr?
+    ] [ drop f ] if ; inline
+ 
+: >compare-expr< ( expr -- in1 in2 cc )
+    [ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
+
+: >compare-imm-expr< ( expr -- in1 in2 cc )
+    [ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
+
+: rewrite-boolean-comparison ( expr -- insn )
+    src1>> vreg>expr dup op>> {
+        { \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
+        { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
+        { \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
+    } case ;
+
+: tag-fixnum-expr? ( expr -- ? )
+    dup op>> \ ##shl-imm eq?
+    [ in2>> vn>expr value>> 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 = ]
+    bi and ; inline
+
+: rewrite-tagged-comparison ( insn -- insn' )
+    [ src1>> vreg>expr in1>> vn>vreg ]
+    [ src2>> tag-bits get neg shift ]
+    [ cc>> ]
+    tri
+    f \ ##compare-imm-branch boa ;
+
+M: ##compare-imm-branch rewrite
+    dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
+    dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when ;
+
+M: insn rewrite ;
diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
index 4c3589d710..e51b0d211f 100644
--- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor
+++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
@@ -10,13 +10,6 @@ IN: compiler.cfg.value-numbering.simplify
 ! Return value of f means we didn't simplify.
 GENERIC: simplify* ( expr -- vn/expr/f )
 
-: simplify-not ( in -- vn/expr/f )
-    {
-        { [ dup constant-expr? ] [ value>> bitnot <constant> ] }
-        { [ dup op>> \ ##not = ] [ in>> ] }
-        [ drop f ]
-    } cond ;
-
 : simplify-box-float ( in -- vn/expr/f )
     dup op>> \ ##unbox-float = [ in>> ] [ drop f ] if ;
 
@@ -29,127 +22,11 @@ M: unary-expr simplify*
     [ in>> vn>expr ] [ op>> ] bi {
         { \ ##copy [ ] }
         { \ ##copy-float [ ] }
-        { \ ##not [ simplify-not ] }
         { \ ##box-float [ simplify-box-float ] }
         { \ ##unbox-float [ simplify-unbox-float ] }
         [ 2drop f ]
     } case ;
 
-! : expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
-! 
-! : expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline
-! 
-! : expr-neg-one? ( expr -- ? ) T{ constant-expr f f -1 } = ; inline
-! 
-! : identity ( in1 in2 val -- expr ) 2nip <constant> ; inline
-! 
-! : constant-fold? ( in1 in2 -- ? )
-!     [ constant-expr? ] both? ;
-! 
-! : constant-fold ( in1 in2 quot -- expr )
-!     2over constant-fold? [
-!         [ [ value>> ] bi@ ] dip call <constant>
-!     ] [ 3drop f ] if ; inline
-! 
-! : simplify-add ( in1 in2 -- vn/expr/f )
-!     {
-!         { [ over expr-zero? ] [ nip ] }
-!         { [ dup expr-zero? ] [ drop ] }
-!         [ [ + ] constant-fold ]
-!     } cond ;
-! 
-! : simplify-mul ( in1 in2 -- vn/expr/f )
-!     {
-!         { [ over expr-one? ] [ nip ] }
-!         { [ dup expr-one? ] [ drop ] }
-!         [ [ * ] constant-fold ]
-!     } cond ;
-! 
-! : simplify-and ( in1 in2 -- vn/expr/f )
-!     {
-!         { [ dup expr-zero? ] [ 0 identity ] }
-!         { [ dup expr-neg-one? ] [ drop ] }
-!         { [ 2dup = ] [ drop ] }
-!         [ [ bitand ] constant-fold ]
-!     } cond ;
-! 
-! : simplify-or ( in1 in2 -- vn/expr/f )
-!     {
-!         { [ dup expr-zero? ] [ drop ] }
-!         { [ dup expr-neg-one? ] [ -1 identity ] }
-!         { [ 2dup = ] [ drop ] }
-!         [ [ bitor ] constant-fold ]
-!     } cond ;
-! 
-! : simplify-xor ( in1 in2 -- vn/expr/f )
-!     {
-!         { [ dup expr-zero? ] [ drop ] }
-!         [ [ bitxor ] constant-fold ]
-!     } cond ;
-! 
-! : commutative-operands ( expr -- in1 in2 )
-!     [ in1>> vn>expr ] [ in2>> vn>expr ] bi
-!     over constant-expr? [ swap ] when ;
-! 
-! M: commutative-expr simplify*
-!     [ commutative-operands ] [ op>> ] bi {
-!         { ##add [ simplify-add ] }
-!         { ##mul [ simplify-mul ] }
-!         { ##and [ simplify-and ] }
-!         { ##or [ simplify-or ] }
-!         { ##xor [ simplify-xor ] }
-!         [ 3drop f ]
-!     } case ;
-! 
-! : simplify-sub ( in1 in2 -- vn/expr/f )
-!     {
-!         { [ dup expr-zero? ] [ drop ] }
-!         { [ 2dup = ] [ 0 identity ] }
-!         [ [ - ] constant-fold ]
-!     } cond ;
-! 
-! : simplify-shl ( in1 in2 -- vn/expr/f )
-!     {
-!         { [ dup expr-zero? ] [ drop ] }
-!         { [ over expr-zero? ] [ drop ] }
-!         [ [ shift ] constant-fold ]
-!     } cond ;
-! 
-! : unsigned ( n -- n' )
-!     cell-bits 2^ 1- bitand ;
-! 
-! : useless-shift? ( in1 in2 -- ? )
-!     over op>> ##shl = [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ;
-! 
-! : simplify-shr ( in1 in2 -- vn/expr/f )
-!     {
-!         { [ dup expr-zero? ] [ drop ] }
-!         { [ over expr-zero? ] [ drop ] }
-!         { [ 2dup useless-shift? ] [ drop in1>> ] }
-!         [ [ neg shift unsigned ] constant-fold ]
-!     } cond ;
-! 
-! : simplify-sar ( in1 in2 -- vn/expr/f )
-!     {
-!         { [ dup expr-zero? ] [ drop ] }
-!         { [ over expr-zero? ] [ drop ] }
-!         { [ 2dup useless-shift? ] [ drop in1>> ] }
-!         [ [ neg shift ] constant-fold ]
-!     } cond ;
-! 
-! : simplify-compare ( in1 in2 -- vn/expr/f )
-!     = [ +eq+ %cconst constant ] [ f ] if ;
-! 
-! M: binary-expr simplify*
-!     [ in1>> vn>expr ] [ in2>> vn>expr ] [ op>> ] tri {
-!         { ##sub [ simplify-isub ] }
-!         { ##shl [ simplify-shl ] }
-!         { ##shr [ simplify-shr ] }
-!         { ##sar [ simplify-sar ] }
-!         { ##compare [ simplify-compare ] }
-!         [ 3drop f ]
-!     } case ;
-
 M: expr simplify* drop f ;
 
 : simplify ( expr -- vn )
@@ -158,3 +35,8 @@ M: expr simplify* drop f ;
         { [ dup expr? ] [ expr>vn nip ] }
         { [ dup integer? ] [ nip ] }
     } cond ;
+
+GENERIC: number-values ( insn -- )
+
+M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ;
+M: insn number-values drop ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 81121f3fe9..c8a1d7884c 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -4,6 +4,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel ;
 [
     {
         T{ ##peek f V int-regs 45 D 1 }
+        T{ ##copy f V int-regs 48 V int-regs 45 }
         T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
     }
 ] [
@@ -16,6 +17,7 @@ compiler.cfg.registers cpu.architecture tools.test kernel ;
 
 [
     {
+        T{ ##load-immediate f V int-regs 2 8 }
         T{ ##peek f V int-regs 3 D 0 }
         T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
         T{ ##replace f V int-regs 4 D 0 }
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index b411efef3a..d17b2a7e1f 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -2,33 +2,14 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs biassocs classes kernel math accessors
 sorting sets sequences
-compiler.cfg.def-use
-compiler.cfg.instructions
-compiler.cfg.instructions.syntax
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions
-compiler.cfg.value-numbering.liveness
 compiler.cfg.value-numbering.propagate
-compiler.cfg.value-numbering.simplify ;
+compiler.cfg.value-numbering.simplify
+compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering
 
-: insn>vn ( insn -- vn ) >expr simplify ; inline
-
-GENERIC: number-values ( insn -- )
-
-M: ##flushable number-values
-    dup ##pure? [ dup call-next-method ] unless
-    [ insn>vn ] [ dst>> ] bi set-vn ;
-
-M: insn number-values uses-vregs [ live-vreg ] each ;
-
-: init-value-numbering ( -- )
+: value-numbering ( insns -- insns' )
     init-value-graph
     init-expressions
-    init-liveness ;
-
-: value-numbering ( insns -- insns' )
-    init-value-numbering
-    [ [ number-values ] each ]
-    [ [ eliminate propagate ] map sift ]
-    bi ;
+    [ [ number-values ] [ rewrite propagate ] bi ] map ;

From 7fb39a14c15b0dfae48ddcf959acb46bfe48e90b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 23 Oct 2008 02:49:55 -0500
Subject: [PATCH 061/318] Compile compiler early

---
 basis/bootstrap/compiler/compiler.factor | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor
index 0b44761f5c..cbd2f0f41e 100644
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@@ -7,7 +7,7 @@ hashtables.private sequences.private math classes.tuple.private
 growable namespaces.private assocs words command-line vocabs io
 io.encodings.string prettyprint libc splitting math.parser
 compiler.units math.order compiler.tree.builder
-compiler.tree.optimizer ;
+compiler.tree.optimizer compiler.cfg.optimizer ;
 IN: bootstrap.compiler
 
 ! Don't bring this in when deploying, since it will store a
@@ -93,6 +93,10 @@ nl
 
 { optimize-tree } compile-uncompiled
 
+{ optimize-cfg } compile-uncompiled
+
+{ (compile) } compile-uncompiled
+
 vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush

From 885adc8dc9009d4fa661fd06e44c285b218301f4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 23 Oct 2008 05:27:54 -0500
Subject: [PATCH 062/318] Various improvements

---
 .../alias-analysis-tests.factor               | 78 +------------------
 .../cfg/alias-analysis/alias-analysis.factor  |  2 +-
 .../cfg/dead-code/dead-code-tests.factor      |  8 ++
 basis/compiler/cfg/dead-code/dead-code.factor | 62 +++++++++++++++
 basis/compiler/cfg/height/height.factor       |  3 -
 .../compiler/cfg/intrinsics/intrinsics.factor |  4 +
 basis/compiler/cfg/optimizer/optimizer.factor |  2 +
 .../value-numbering/rewrite/rewrite.factor    | 20 ++++-
 .../value-numbering/simplify/simplify.factor  | 41 +++++++++-
 .../value-numbering-tests.factor              | 16 ++++
 10 files changed, 148 insertions(+), 88 deletions(-)
 create mode 100644 basis/compiler/cfg/dead-code/dead-code-tests.factor
 create mode 100644 basis/compiler/cfg/dead-code/dead-code.factor

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
index 1ac6fc8e6f..2f0649ed40 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
@@ -10,52 +10,6 @@ IN: compiler.cfg.alias-analysis.tests
     } alias-analysis drop
 ] unit-test
 
-[
-    {
-        T{ ##peek f V int-regs 1 D 1 }
-        T{ ##replace f V int-regs 1 D 0 }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 1 }
-        T{ ##replace f V int-regs 1 D 0 }
-        T{ ##replace f V int-regs 1 D 1 }
-    } alias-analysis
-] unit-test
-
-[
-    {
-        T{ ##peek f V int-regs 1 D 1 }
-        T{ ##copy f V int-regs 2 V int-regs 1 }
-        T{ ##replace f V int-regs 2 D 0 }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 1 }
-        T{ ##copy f V int-regs 2 V int-regs 1 }
-        T{ ##replace f V int-regs 2 D 0 }
-        T{ ##replace f V int-regs 2 D 1 }
-    } alias-analysis
-] unit-test
-
-[
-    {
-        T{ ##peek f V int-regs 1 D 1 }
-        T{ ##peek f V int-regs 2 D 0 }
-        T{ ##copy f V int-regs 3 V int-regs 2 }
-        T{ ##copy f V int-regs 4 V int-regs 1 }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 1 }
-        T{ ##peek f V int-regs 2 D 0 }
-        T{ ##copy f V int-regs 3 V int-regs 2 }
-        T{ ##copy f V int-regs 4 V int-regs 1 }
-        T{ ##replace f V int-regs 3 D 0 }
-        T{ ##replace f V int-regs 4 D 1 }
-    } alias-analysis
-] unit-test
-
 [
     {
         T{ ##peek f V int-regs 1 D 1 f }
@@ -71,42 +25,14 @@ IN: compiler.cfg.alias-analysis.tests
     } alias-analysis
 ] unit-test
 
-[
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##copy f V int-regs 3 V int-regs 1 f }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##replace f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 3 D 1 f }
-        T{ ##replace f V int-regs 4 D 1 f }
-    } alias-analysis
-] unit-test
-
-[
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 0 f }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 0 f }
-        T{ ##replace f V int-regs 1 D 0 f }
-        T{ ##replace f V int-regs 2 D 1 f }
-        T{ ##replace f V int-regs 2 D 0 f }
-        T{ ##replace f V int-regs 1 D 1 f }
-    } alias-analysis
-] unit-test
-
 [
     {
         T{ ##peek f V int-regs 1 D 1 f }
         T{ ##peek f V int-regs 2 D 0 f }
         T{ ##copy f V int-regs 3 V int-regs 2 f }
         T{ ##copy f V int-regs 4 V int-regs 1 f }
+        T{ ##replace f V int-regs 3 D 0 f }
+        T{ ##replace f V int-regs 4 D 1 f }
     }
 ] [
     {
diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index e98f6e8bea..fdfa88c51a 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -6,7 +6,7 @@ compiler.cfg.registers compiler.cfg.instructions
 compiler.cfg.instructions.syntax compiler.cfg.copy-prop ;
 IN: compiler.cfg.alias-analysis
 
-! Alias analysis -- must be run after compiler.cfg.height.
+! Alias analysis -- assumes compiler.cfg.height has already run.
 !
 ! We try to eliminate redundant slot and stack
 ! traffic using some simple heuristics.
diff --git a/basis/compiler/cfg/dead-code/dead-code-tests.factor b/basis/compiler/cfg/dead-code/dead-code-tests.factor
new file mode 100644
index 0000000000..b9c3af5215
--- /dev/null
+++ b/basis/compiler/cfg/dead-code/dead-code-tests.factor
@@ -0,0 +1,8 @@
+USING: compiler.cfg.dead-code compiler.cfg.instructions
+compiler.cfg.registers cpu.architecture tools.test ;
+IN: compiler.cfg.dead-code.tests
+
+[ { } ] [
+    { T{ ##load-immediate f V int-regs 134 16 } }
+    eliminate-dead-code
+] unit-test
diff --git a/basis/compiler/cfg/dead-code/dead-code.factor b/basis/compiler/cfg/dead-code/dead-code.factor
new file mode 100644
index 0000000000..6ac5c1a9a6
--- /dev/null
+++ b/basis/compiler/cfg/dead-code/dead-code.factor
@@ -0,0 +1,62 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sets kernel namespaces sequences
+compiler.cfg.instructions compiler.cfg.instructions.syntax
+compiler.cfg.def-use ;
+IN: compiler.cfg.dead-code
+
+! Dead code elimination -- assumes compiler.cfg.alias-analysis
+! has already run.
+
+! Maps vregs to sequences of vregs
+SYMBOL: liveness-graph
+
+! vregs which participate in side effects and thus are always live
+SYMBOL: live-vregs
+
+! mapping vregs to stack locations
+SYMBOL: vregs>locs
+
+: init-dead-code ( -- )
+    H{ } clone liveness-graph set
+    H{ } clone live-vregs set
+    H{ } clone vregs>locs set ;
+
+GENERIC: compute-liveness ( insn -- )
+
+M: ##flushable compute-liveness
+    [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
+
+M: ##peek compute-liveness
+    [ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ]
+    [ call-next-method ]
+    bi ;
+
+: live-replace? ( ##replace -- ? )
+    [ src>> vregs>locs get at ] [ loc>> ] bi = not ;
+
+M: ##replace compute-liveness
+    dup live-replace? [ call-next-method ] [ drop ] if ;
+
+: record-live ( vregs -- )
+    [
+        dup live-vregs get key? [ drop ] [
+            [ live-vregs get conjoin ]
+            [ liveness-graph get at record-live ]
+            bi
+        ] if
+    ] each ;
+
+M: insn compute-liveness uses-vregs record-live ;
+
+GENERIC: live-insn? ( insn -- ? )
+
+M: ##flushable live-insn? dst>> live-vregs get key? ;
+
+M: ##replace live-insn? live-replace? ;
+
+M: insn live-insn? drop t ;
+
+: eliminate-dead-code ( insns -- insns' )
+    init-dead-code
+    [ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ;
diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
index d14cf4afb4..1c3f1744b4 100644
--- a/basis/compiler/cfg/height/height.factor
+++ b/basis/compiler/cfg/height/height.factor
@@ -7,9 +7,6 @@ IN: compiler.cfg.height
 
 ! Combine multiple stack height changes into one at the
 ! start of the basic block.
-!
-! Alias analysis and value numbering assume this optimization
-! has been performed.
 
 SYMBOL: ds-height
 SYMBOL: rs-height
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index f42b53a91e..338eaab955 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -72,6 +72,10 @@ IN: compiler.cfg.intrinsics
         math.private:float/f
         math.private:fixnum>float
         math.private:float>fixnum
+        math.private:float<
+        math.private:float<=
+        math.private:float>
+        math.private:float>=
         alien.accessors:alien-float
         alien.accessors:set-alien-float
         alien.accessors:alien-double
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 598a4bfcea..05084e32a8 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -5,6 +5,7 @@ compiler.cfg.instructions
 compiler.cfg.height
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
+compiler.cfg.dead-code
 compiler.cfg.write-barrier ;
 IN: compiler.cfg.optimizer
 
@@ -17,6 +18,7 @@ IN: compiler.cfg.optimizer
             normalize-height
             alias-analysis
             value-numbering
+            eliminate-dead-code
             eliminate-write-barriers
         ] unless
     ] change-basic-blocks ;
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index a5fcc58365..748a965d92 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -5,13 +5,23 @@ math
 compiler.cfg.instructions
 compiler.cfg.instructions.syntax
 compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.simplify
 compiler.cfg.value-numbering.expressions ;
 IN: compiler.cfg.value-numbering.rewrite
 
 GENERIC: rewrite ( insn -- insn' )
 
+M: ##mul-imm rewrite
+    dup src2>> dup power-of-2? [
+        [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa
+        dup number-values
+    ] [ drop ] if ;
+
 : ##branch-t? ( insn -- ? )
-    [ cc>> cc/= eq? ] [ src2>> \ f tag-number eq? ] bi and ; inline
+    dup ##compare-imm-branch? [
+        [ cc>> cc/= eq? ]
+        [ src2>> \ f tag-number eq? ] bi and
+    ] [ drop f ] if ; inline
 
 : rewrite-boolean-comparison? ( insn -- ? )
     dup ##branch-t? [
@@ -37,9 +47,11 @@ GENERIC: rewrite ( insn -- insn' )
 
 : rewrite-tagged-comparison? ( insn -- ? )
     #! Are we comparing two tagged fixnums? Then untag them.
-    [ src1>> vreg>expr tag-fixnum-expr? ]
-    [ src2>> tag-mask get bitand 0 = ]
-    bi and ; inline
+    dup ##compare-imm-branch? [
+        [ src1>> vreg>expr tag-fixnum-expr? ]
+        [ src2>> tag-mask get bitand 0 = ]
+        bi and
+    ] [ drop f ] if ; inline
 
 : rewrite-tagged-comparison ( insn -- insn' )
     [ src1>> vreg>expr in1>> vn>vreg ]
diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
index e51b0d211f..d63b84a86f 100644
--- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor
+++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
@@ -10,11 +10,14 @@ IN: compiler.cfg.value-numbering.simplify
 ! Return value of f means we didn't simplify.
 GENERIC: simplify* ( expr -- vn/expr/f )
 
-: simplify-box-float ( in -- vn/expr/f )
-    dup op>> \ ##unbox-float = [ in>> ] [ drop f ] if ;
+: simplify-unbox ( in boxer -- vn/expr/f )
+    over op>> eq? [ in>> ] [ drop f ] if ; inline
 
 : simplify-unbox-float ( in -- vn/expr/f )
-    dup op>> \ ##box-float = [ in>> ] [ drop f ] if ;
+    \ ##box-float simplify-unbox ; inline
+
+: simplify-unbox-alien ( in -- vn/expr/f )
+    \ ##box-alien simplify-unbox ; inline
 
 M: unary-expr simplify*
     #! Note the copy propagation: a copy always simplifies to
@@ -22,8 +25,38 @@ M: unary-expr simplify*
     [ in>> vn>expr ] [ op>> ] bi {
         { \ ##copy [ ] }
         { \ ##copy-float [ ] }
-        { \ ##box-float [ simplify-box-float ] }
         { \ ##unbox-float [ simplify-unbox-float ] }
+        { \ ##unbox-alien [ simplify-unbox-alien ] }
+        { \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
+        [ 2drop f ]
+    } case ;
+
+: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
+
+: >binary-expr< ( expr -- in1 in2 )
+    [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
+
+: simplify-add ( expr -- vn/expr/f )
+    >binary-expr< {
+        { [ over expr-zero? ] [ nip ] }
+        { [ dup expr-zero? ] [ drop ] }
+        [ 2drop f ]
+    } cond ; inline
+
+: useless-shift? ( in1 in2 -- ? )
+    over op>> \ ##shl-imm eq?
+    [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
+
+: simplify-shift ( expr -- vn/expr/f )
+    >binary-expr<
+    2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline
+
+M: binary-expr simplify*
+    dup op>> {
+        { \ ##add [ simplify-add ] }
+        { \ ##add-imm [ simplify-add ] }
+        { \ ##shr-imm [ simplify-shift ] }
+        { \ ##sar-imm [ simplify-shift ] }
         [ 2drop f ]
     } case ;
 
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index c8a1d7884c..a33c2f28c4 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -50,3 +50,19 @@ compiler.cfg.registers cpu.architecture tools.test kernel ;
         T{ ##replace f V int-regs 23 D 0 }
     } dup value-numbering =
 ] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 0 }
+        T{ ##shl-imm f V int-regs 2 V int-regs 1 3 }
+        T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
+        T{ ##replace f V int-regs 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 0 }
+        T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
+        T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
+        T{ ##replace f V int-regs 3 D 0 }
+    } value-numbering
+] unit-test

From 95eb0f696ba2347acfd8f883686eef47864f7409 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 23 Oct 2008 05:28:04 -0500
Subject: [PATCH 063/318] Rice

---
 core/generic/standard/engines/tag/tag.factor | 8 +++++---
 1 file changed, 5 insertions(+), 3 deletions(-)

diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index 5bb5b42243..e27498b492 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -43,17 +43,19 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
 : num-hi-tags ( -- n ) num-types get num-tags get - ;
 
 : hi-tag-number ( class -- n )
-    "type" word-prop num-tags get - ;
+    "type" word-prop ;
 
 : hi-tag-quot ( -- quot )
-    \ hi-tag def>> num-tags get [ fixnum-fast ] curry compose ;
+    \ hi-tag def>> ;
 
 M: hi-tag-dispatch-engine engine>quot
-    methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
+    methods>> engines>quots* [ >r "type" word-prop r> ] assoc-map
     [
         picker % hi-tag-quot % [
             linear-dispatch-quot
         ] [
+            num-tags get , \ fixnum-fast ,
+            [ >r num-tags get - r> ] assoc-map
             num-hi-tags direct-dispatch-quot
         ] if-small? %
     ] [ ] make ;

From 69a0ad5e4280a890e2279c6efe0119126e9ab1c2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 23 Oct 2008 05:49:32 -0500
Subject: [PATCH 064/318] Ricing locals

---
 basis/cpu/x86/bootstrap.factor      | 20 ++++++++++++++++++--
 basis/locals/backend/backend.factor | 10 ++--------
 core/bootstrap/primitives.factor    |  3 +++
 3 files changed, 23 insertions(+), 10 deletions(-)

diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 95e0072dc4..7fc32da9a4 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.x86.assembler layouts compiler.units math
-math.private compiler.constants vocabs
-slots.private words words.private ;
+math.private compiler.constants vocabs slots.private words
+words.private locals.backend ;
 IN: bootstrap.x86
 
 big-endian off
@@ -302,4 +302,20 @@ big-endian off
     ds-reg [] arg0 MOV                         ! save
 ] f f f \ fixnum-bitnot define-sub-primitive
 
+[
+    arg0 ds-reg [] MOV                         ! load local number
+    fixnum>slot@                               ! turn local number into offset
+    arg1 bootstrap-cell MOV                    ! load base
+    arg1 arg0 SUB                              ! turn it into a stack offset
+    arg0 rs-reg arg1 [+] MOV                   ! load local value
+    ds-reg [] arg0 MOV                         ! push to stack
+] f f f \ get-local define-sub-primitive
+
+[
+    arg0 ds-reg [] MOV                         ! load local count
+    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    fixnum>slot@                               ! turn local number into offset
+    rs-reg arg0 SUB                            ! decrement retain stack pointer
+] f f f \ drop-locals define-sub-primitive
+
 [ "bootstrap.x86" forget-vocab ] with-compilation-unit
diff --git a/basis/locals/backend/backend.factor b/basis/locals/backend/backend.factor
index 27772d19d0..0d9ee6a64e 100644
--- a/basis/locals/backend/backend.factor
+++ b/basis/locals/backend/backend.factor
@@ -1,17 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel slots.private sequences effects words ;
+USING: math.private kernel slots.private sequences effects words ;
 IN: locals.backend
 
 : load-locals ( n -- )
-    dup zero? [ drop ] [ swap >r 1- load-locals ] if ;
-
-: get-local ( n -- value )
-    dup zero? [ drop dup ] [ r> swap 1- get-local swap >r ] if ;
+    dup 0 eq? [ drop ] [ swap >r 1 fixnum-fast load-locals ] if ;
 
 : local-value 2 slot ; inline
 
 : set-local-value 2 set-slot ; inline
-
-: drop-locals ( n -- )
-    dup zero? [ drop ] [ r> drop 1- drop-locals ] if ;
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 62d4ec9273..f55942603d 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -80,6 +80,7 @@ bootstrapping? on
     "io.files"
     "io.files.private"
     "io.streams.c"
+    "locals.backend"
     "kernel"
     "kernel.private"
     "math"
@@ -370,6 +371,8 @@ tuple
     { "eq?" "kernel" }
     { "tag" "kernel.private" }
     { "slot" "slots.private" }
+    { "get-local" "locals.backend" }
+    { "drop-locals" "locals.backend" }
 } [ make-sub-primitive ] assoc-each
 
 ! Primitive words

From 1912c57bb5ff94cd8f74806163727aa7e6255ec9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 23 Oct 2008 05:55:50 -0500
Subject: [PATCH 065/318] Fix comment

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

diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor
index 49f2eb0281..2d2e429994 100644
--- a/basis/compiler/tree/finalization/finalization.factor
+++ b/basis/compiler/tree/finalization/finalization.factor
@@ -11,9 +11,10 @@ IN: compiler.tree.finalization
 ! See the comment in compiler.tree.late-optimizations.
 
 ! This pass runs after propagation, so that it can expand
-! built-in type predicates; these cannot
-! be expanded before propagation since we need to see 'fixnum?'
-! instead of 'tag 0 eq?' and so on, for semantic reasoning.
+! built-in type predicates; these cannot be expanded before
+! propagation since we need to see 'fixnum?' instead of
+! 'tag 0 eq?' and so on, for semantic reasoning.
+
 ! We also delete empty stack shuffles and copies to facilitate
 ! tail call optimization in the code generator.
 

From 492a15e3455146f61731e19f1b63b1542907aadb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 24 Oct 2008 09:17:06 -0500
Subject: [PATCH 066/318] Move insn class to compiler.cfg.instructions

---
 basis/compiler/cfg/alias-analysis/alias-analysis.factor   | 2 +-
 basis/compiler/cfg/dead-code/dead-code.factor             | 3 +--
 basis/compiler/cfg/def-use/def-use.factor                 | 3 +--
 basis/compiler/cfg/height/height.factor                   | 3 +--
 basis/compiler/cfg/instructions/instructions.factor       | 1 +
 basis/compiler/cfg/instructions/syntax/syntax.factor      | 8 ++++++--
 basis/compiler/cfg/linearization/linearization.factor     | 3 +--
 basis/compiler/cfg/stack-frame/stack-frame.factor         | 2 +-
 .../cfg/value-numbering/propagate/propagate.factor        | 3 +--
 basis/compiler/cfg/value-numbering/rewrite/rewrite.factor | 1 -
 .../compiler/cfg/value-numbering/simplify/simplify.factor | 1 -
 basis/compiler/cfg/write-barrier/write-barrier.factor     | 3 +--
 12 files changed, 15 insertions(+), 18 deletions(-)

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index fdfa88c51a..e68d304047 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -3,7 +3,7 @@
 USING: kernel math namespaces assocs hashtables sequences
 accessors vectors combinators sets classes compiler.cfg
 compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.instructions.syntax compiler.cfg.copy-prop ;
+compiler.cfg.copy-prop ;
 IN: compiler.cfg.alias-analysis
 
 ! Alias analysis -- assumes compiler.cfg.height has already run.
diff --git a/basis/compiler/cfg/dead-code/dead-code.factor b/basis/compiler/cfg/dead-code/dead-code.factor
index 6ac5c1a9a6..73aa7b4a5a 100644
--- a/basis/compiler/cfg/dead-code/dead-code.factor
+++ b/basis/compiler/cfg/dead-code/dead-code.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sets kernel namespaces sequences
-compiler.cfg.instructions compiler.cfg.instructions.syntax
-compiler.cfg.def-use ;
+compiler.cfg.instructions compiler.cfg.def-use ;
 IN: compiler.cfg.dead-code
 
 ! Dead code elimination -- assumes compiler.cfg.alias-analysis
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 7e3167ea60..8df048d956 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -1,7 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel compiler.cfg.instructions
-compiler.cfg.instructions.syntax ;
+USING: accessors arrays kernel compiler.cfg.instructions ;
 IN: compiler.cfg.def-use
 
 GENERIC: defs-vregs ( insn -- seq )
diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
index 1c3f1744b4..9312f6f133 100644
--- a/basis/compiler/cfg/height/height.factor
+++ b/basis/compiler/cfg/height/height.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math namespaces sequences kernel fry
-compiler.cfg compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.instructions.syntax ;
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions ;
 IN: compiler.cfg.height
 
 ! Combine multiple stack height changes into one at the
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 1615227631..f70345d1e8 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -7,6 +7,7 @@ compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
 ! Virtual CPU instructions, used by CFG and machine IRs
+TUPLE: insn ;
 
 ! Instruction with no side effects; if 'out' is never read, we
 ! can eliminate it.
diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor
index 6d533d2059..5a5df88112 100644
--- a/basis/compiler/cfg/instructions/syntax/syntax.factor
+++ b/basis/compiler/cfg/instructions/syntax/syntax.factor
@@ -4,11 +4,15 @@ USING: classes.tuple classes.tuple.parser kernel words
 make fry sequences parser ;
 IN: compiler.cfg.instructions.syntax
 
-TUPLE: insn ;
+: insn-word ( -- word )
+    #! We want to put the insn tuple in compiler.cfg.instructions,
+    #! but we cannot have circularity between that vocabulary and
+    #! this one.
+    "insn" "compiler.cfg.instructions" lookup ;
 
 : INSN:
     parse-tuple-definition "regs" suffix
-    [ dup tuple eq? [ drop insn ] when ] dip
+    [ dup tuple eq? [ drop insn-word ] when ] dip
     [ define-tuple-class ]
     [ 2drop save-location ]
     [ 2drop dup '[ f _ boa , ] define-inline ]
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 06c58ec938..591c386c1c 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -4,8 +4,7 @@ USING: kernel math accessors sequences namespaces make
 combinators
 compiler.cfg
 compiler.cfg.rpo
-compiler.cfg.instructions
-compiler.cfg.instructions.syntax ;
+compiler.cfg.instructions ;
 IN: compiler.cfg.linearization
 
 ! Convert CFG IR to machine IR.
diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index 414fd8f7e7..aa8506a01f 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math.order assocs kernel sequences
 combinators make cpu.architecture compiler.cfg.instructions
-compiler.cfg.instructions.syntax compiler.cfg.registers ;
+compiler.cfg.registers ;
 IN: compiler.cfg.stack-frame
 
 SYMBOL: frame-required?
diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
index c1d6ea562f..d08f233995 100644
--- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor
+++ b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs sequences kernel accessors
-compiler.cfg.instructions compiler.cfg.instructions.syntax
-compiler.cfg.value-numbering.graph ;
+compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
 IN: compiler.cfg.value-numbering.propagate
 
 ! If two vregs compute the same value, replace references to
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 748a965d92..16a3b57829 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -3,7 +3,6 @@
 USING: kernel sequences layouts accessors combinators namespaces
 math
 compiler.cfg.instructions
-compiler.cfg.instructions.syntax
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.simplify
 compiler.cfg.value-numbering.expressions ;
diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
index d63b84a86f..e70ba4b54b 100644
--- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor
+++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
@@ -2,7 +2,6 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors combinators classes math layouts
 compiler.cfg.instructions
-compiler.cfg.instructions.syntax
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions ;
 IN: compiler.cfg.value-numbering.simplify
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index f7e81c8b5c..4a55cb3266 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces assocs sets sequences locals
-compiler.cfg compiler.cfg.instructions
-compiler.cfg.instructions.syntax compiler.cfg.copy-prop ;
+compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ;
 IN: compiler.cfg.write-barrier
 
 ! Eliminate redundant write barrier hits.

From db4db19cd934b77a93607aad0dccce85c07eff2c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 28 Oct 2008 02:38:37 -0700
Subject: [PATCH 067/318] Start working on coalescing

---
 .../live-intervals/live-intervals.factor      |  7 ++-
 .../cfg/two-operand/two-operand.factor        | 60 ++++++++++++++++++
 basis/compiler/compiler.factor                |  5 +-
 basis/cpu/architecture/architecture.factor    |  2 +
 .../cpu/x86/architecture/architecture.factor  | 62 ++++++++-----------
 5 files changed, 95 insertions(+), 41 deletions(-)
 create mode 100644 basis/compiler/cfg/two-operand/two-operand.factor

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 be151b2002..5ac733114b 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -31,8 +31,11 @@ M: live-interval clone
 SYMBOL: live-intervals
 
 : new-live-interval ( n vreg live-intervals -- )
-    2dup key? [ "Multiple defs" throw ] when
-    [ [ <live-interval> ] keep ] dip set-at ;
+    2dup key? [
+        at add-use
+    ] [
+        [ [ <live-interval> ] keep ] dip set-at
+    ] if ;
 
 : compute-live-intervals* ( insn n -- )
     live-intervals get
diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor
new file mode 100644
index 0000000000..e943fb4828
--- /dev/null
+++ b/basis/compiler/cfg/two-operand/two-operand.factor
@@ -0,0 +1,60 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel sequences sequences.deep
+compiler.cfg.instructions cpu.architecture ;
+IN: compiler.cfg.two-operand
+
+! On x86, instructions take the form x = x op y
+! Our SSA IR is x = y op z
+
+! We don't bother with ##add, ##add-imm or ##sub-imm since x86
+! has a LEA instruction which is effectively a three-operand
+! addition
+
+: make-copy ( dst src -- insn ) f \ ##copy boa ; inline
+
+: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline
+
+: convert-two-operand/integer ( insn -- insns )
+    [ [ dst>> ] [ src1>> ] bi make-copy ]
+    [ dup dst>> >>src1 ]
+    bi 2array ; inline
+
+: convert-two-operand/float ( insn -- insns )
+    [ [ dst>> ] [ src1>> ] bi make-copy/float ]
+    [ dup dst>> >>src1 ]
+    bi 2array ; inline
+
+GENERIC: convert-two-operand* ( insn -- insns )
+
+M: ##not convert-two-operand*
+    [ [ dst>> ] [ src>> ] bi make-copy ]
+    [ dup dst>> >>src ]
+    bi 2array ;
+
+M: ##sub convert-two-operand* convert-two-operand/integer ;
+M: ##mul convert-two-operand* convert-two-operand/integer ;
+M: ##mul-imm convert-two-operand* convert-two-operand/integer ;
+M: ##and convert-two-operand* convert-two-operand/integer ;
+M: ##and-imm convert-two-operand* convert-two-operand/integer ;
+M: ##or convert-two-operand* convert-two-operand/integer ;
+M: ##or-imm convert-two-operand* convert-two-operand/integer ;
+M: ##xor convert-two-operand* convert-two-operand/integer ;
+M: ##xor-imm convert-two-operand* convert-two-operand/integer ;
+M: ##shl-imm convert-two-operand* convert-two-operand/integer ;
+M: ##shr-imm convert-two-operand* convert-two-operand/integer ;
+M: ##sar-imm convert-two-operand* convert-two-operand/integer ;
+
+M: ##add-float convert-two-operand* convert-two-operand/float ;
+M: ##sub-float convert-two-operand* convert-two-operand/float ;
+M: ##mul-float convert-two-operand* convert-two-operand/float ;
+M: ##div-float convert-two-operand* convert-two-operand/float ;
+
+M: insn convert-two-operand* ;
+
+: convert-two-operand ( mr -- mr' )
+    [
+        two-operand? [
+            [ convert-two-operand* ] map flatten
+        ] when
+    ] change-instructions ;
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index f3767ec688..0a21749d84 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -7,8 +7,8 @@ stack-checker stack-checker.state stack-checker.inlining
 compiler.errors compiler.units compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.builder
 compiler.cfg.optimizer compiler.cfg.linearization
-compiler.cfg.linear-scan compiler.cfg.stack-frame
-compiler.codegen ;
+compiler.cfg.two-operand compiler.cfg.linear-scan
+compiler.cfg.stack-frame compiler.codegen ;
 IN: compiler
 
 SYMBOL: compile-queue
@@ -76,6 +76,7 @@ t compile-dependencies? set-global
     build-cfg [
         optimize-cfg
         build-mr
+        convert-two-operand
         linear-scan
         build-stack-frame
         generate
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index e90f58fd49..f7cce8e70a 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -35,6 +35,8 @@ GENERIC: param-reg ( n register-class -- reg )
 
 M: object param-reg param-regs nth ;
 
+HOOK: two-operand? cpu ( -- ? )
+
 HOOK: %load-immediate cpu ( reg obj -- )
 HOOK: %load-indirect cpu ( reg obj -- )
 
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 65067740d9..615550587c 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -9,6 +9,8 @@ compiler.cfg.instructions compiler.codegen
 compiler.codegen.fixup ;
 IN: cpu.x86.architecture
 
+M: x86 two-operand? t ;
+
 HOOK: temp-reg-1 cpu ( -- reg )
 HOOK: temp-reg-2 cpu ( -- reg )
 
@@ -83,31 +85,22 @@ M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
 M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ;
 M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
 
-: ?MOV ( dst src -- )
-    2dup = [ 2drop ] [ MOV ] if ; inline
-
-: 1operand ( dst src -- dst' )
-    dupd ?MOV ; inline
-
-: 2operand ( dst src1 src2 -- dst src )
-    [ 1operand ] dip ; inline
-
 M: x86 %add     [+] LEA ;
 M: x86 %add-imm [+] LEA ;
-M: x86 %sub     2operand SUB ;
+M: x86 %sub     nip SUB ;
 M: x86 %sub-imm neg [+] LEA ;
-M: x86 %mul     2operand swap IMUL2 ;
-M: x86 %mul-imm 2operand IMUL2 ;
-M: x86 %and     2operand AND ;
-M: x86 %and-imm 2operand AND ;
-M: x86 %or      2operand OR ;
-M: x86 %or-imm  2operand OR ;
-M: x86 %xor     2operand XOR ;
-M: x86 %xor-imm 2operand XOR ;
-M: x86 %shl-imm 2operand SHL ;
-M: x86 %shr-imm 2operand SHR ;
-M: x86 %sar-imm 2operand SAR ;
-M: x86 %not     1operand NOT ;
+M: x86 %mul     nip swap IMUL2 ;
+M: x86 %mul-imm nip IMUL2 ;
+M: x86 %and     nip AND ;
+M: x86 %and-imm nip AND ;
+M: x86 %or      nip OR ;
+M: x86 %or-imm  nip OR ;
+M: x86 %xor     nip XOR ;
+M: x86 %xor-imm nip XOR ;
+M: x86 %shl-imm nip SHL ;
+M: x86 %shr-imm nip SHR ;
+M: x86 %sar-imm nip SAR ;
+M: x86 %not     drop NOT ;
 
 : bignum@ ( reg n -- op )
     cells bignum tag-number - [+] ; inline
@@ -164,26 +157,21 @@ M:: x86 %bignum>integer ( dst src -- )
         "end" resolve-label
     ] with-scope ;
 
-: ?MOVSD ( dst src -- )
-    2dup = [ 2drop ] [ MOVSD ] if ; inline
-
-: 1operand-fp ( dst src -- dst' )
-    dupd ?MOVSD ; inline
-
-: 2operand-fp ( dst src1 src2 -- dst src )
-    [ 1operand-fp ] dip ; inline
-
-M: x86 %add-float 2operand-fp ADDSD ;
-M: x86 %sub-float 2operand-fp SUBSD ;
-M: x86 %mul-float 2operand-fp MULSD ;
-M: x86 %div-float 2operand-fp DIVSD ;
+M: x86 %add-float nip ADDSD ;
+M: x86 %sub-float nip SUBSD ;
+M: x86 %mul-float nip MULSD ;
+M: x86 %div-float nip DIVSD ;
 
 M: x86 %integer>float CVTSI2SD ;
 M: x86 %float>integer CVTTSD2SI ;
 
-M: x86 %copy ( dst src -- ) MOV ;
+: ?MOV ( dst src -- )
+    2dup = [ 2drop ] [ MOV ] if ; inline
 
-M: x86 %copy-float MOVSD ;
+M: x86 %copy ( dst src -- ) ?MOV ;
+
+M: x86 %copy-float ( dst src -- )
+    2dup = [ 2drop ] [ MOVSD ] if ;
 
 M: x86 %unbox-float ( dst src -- )
     float-offset [+] MOVSD ;

From 19b703abfc8854a3cc066dda5f955766fc1b7d9f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 28 Oct 2008 16:17:08 -0700
Subject: [PATCH 068/318] Remove unneeded dependency

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

diff --git a/extra/soundex/soundex.factor b/extra/soundex/soundex.factor
index d0da0b1347..416ec4a6bc 100644
--- a/extra/soundex/soundex.factor
+++ b/extra/soundex/soundex.factor
@@ -1,7 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences sequences.lib grouping assocs kernel ascii
-unicode.case tr ;
+USING: sequences grouping assocs kernel ascii unicode.case tr ;
 IN: soundex
 
 TR: soundex-tr

From 5388945ef0d58faeffee7c429673f3fb9554a750 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 28 Oct 2008 16:18:47 -0700
Subject: [PATCH 069/318] Tweak

---
 extra/slides/lib.factor    | 52 ++++++++++++++++++++++++++++++++++++++
 extra/slides/slides.factor |  4 +--
 2 files changed, 54 insertions(+), 2 deletions(-)
 create mode 100755 extra/slides/lib.factor

diff --git a/extra/slides/lib.factor b/extra/slides/lib.factor
new file mode 100755
index 0000000000..f9708b3ca7
--- /dev/null
+++ b/extra/slides/lib.factor
@@ -0,0 +1,52 @@
+USING: arrays assocs kernel vectors sequences namespaces
+       random math.parser math fry ;
+
+IN: assocs.lib
+
+: set-assoc-stack ( value key seq -- )
+    dupd [ key? ] with find-last nip set-at ;
+
+: at-default ( key assoc -- value/key )
+    dupd at [ nip ] when* ;
+
+: replace-at ( assoc value key -- assoc )
+    >r >r dup r> 1vector r> rot set-at ;
+
+: peek-at* ( assoc key -- obj ? )
+    swap at* dup [ >r peek r> ] when ;
+
+: peek-at ( assoc key -- obj )
+    peek-at* drop ;
+
+: >multi-assoc ( assoc -- new-assoc )
+    [ 1vector ] assoc-map ;
+
+: multi-assoc-each ( assoc quot -- )
+    [ with each ] curry assoc-each ; inline
+
+: insert ( value variable -- ) namespace push-at ;
+
+: generate-key ( assoc -- str )
+    >r 32 random-bits >hex r>
+    2dup key? [ nip generate-key ] [ drop ] if ;
+
+: set-at-unique ( value assoc -- key )
+    dup generate-key [ swap set-at ] keep ;
+
+: histogram ( assoc quot -- assoc' )
+    H{ } clone [
+        swap [ change-at ] 2curry assoc-each
+    ] keep ; inline
+
+: inc-at ( key assoc -- )
+    [ 0 or 1 + ] change-at ;
+
+: ?at ( obj assoc -- value/obj ? )
+    dupd at* [ [ nip ] [ drop ] if ] keep ;
+
+: if-at ( obj assoc quot1 quot2 -- )
+    [ ?at ] 2dip if ; inline
+
+: when-at ( obj assoc quot -- ) [ ] if-at ; inline
+
+: unless-at ( obj assoc quot -- ) [ ] swap if-at ; inline
diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor
index a3031a7557..2940bcbfcb 100755
--- a/extra/slides/slides.factor
+++ b/extra/slides/slides.factor
@@ -16,7 +16,7 @@ IN: slides
         }
         { default-block-style
             H{
-                { wrap-margin 1000 }
+                { wrap-margin 1100 }
             }
         }
         { code-style
@@ -34,7 +34,7 @@ IN: slides
             }
         }
         { table-content-style
-            H{ { wrap-margin 800 } }
+            H{ { wrap-margin 1000 } }
         }
         { list-style
             H{ { table-gap { 10 20 } } }

From 500ee302662b1ea3a4d0ce6e0fa1358c5b619f4d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 28 Oct 2008 16:20:22 -0700
Subject: [PATCH 070/318] Add a main word to webapps.ip

---
 extra/webapps/ip/ip.factor | 11 +++++++++--
 1 file changed, 9 insertions(+), 2 deletions(-)

diff --git a/extra/webapps/ip/ip.factor b/extra/webapps/ip/ip.factor
index 7124d4a5c4..4e22de60bc 100644
--- a/extra/webapps/ip/ip.factor
+++ b/extra/webapps/ip/ip.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors furnace.actions http.server.dispatchers
-html.forms io.servers.connection namespaces prettyprint ;
+USING: accessors furnace.actions http.server
+http.server.dispatchers html.forms io.servers.connection
+namespaces prettyprint ;
 IN: webapps.ip
 
 TUPLE: ip-app < dispatcher ;
@@ -14,3 +15,9 @@ TUPLE: ip-app < dispatcher ;
 : <ip-app> ( -- dispatcher )
     ip-app new-dispatcher
         <display-ip-action> "" add-responder ;
+
+: run-ip-app ( -- )
+    <ip-app> main-responder set-global
+    8080 httpd ;
+
+MAIN: run-ip-app

From 2fb17458e35715ad70ce8742699357b48407020e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 28 Oct 2008 16:22:54 -0700
Subject: [PATCH 071/318] Fix duplication

---
 core/generic/standard/engines/tag/tag.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index e27498b492..2043c99741 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -49,7 +49,7 @@ C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
     \ hi-tag def>> ;
 
 M: hi-tag-dispatch-engine engine>quot
-    methods>> engines>quots* [ >r "type" word-prop r> ] assoc-map
+    methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
     [
         picker % hi-tag-quot % [
             linear-dispatch-quot

From 310ed5585cc25154970c2c2078ab953502f8f736 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 30 Oct 2008 16:16:03 -0700
Subject: [PATCH 072/318] working on screen capture

---
 extra/cap/cap.factor                | 53 +++++++++++++++++++++++++++++
 extra/graphics/bitmap/bitmap.factor | 18 +++++++---
 2 files changed, 66 insertions(+), 5 deletions(-)
 create mode 100644 extra/cap/cap.factor

diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor
new file mode 100644
index 0000000000..858ec3e596
--- /dev/null
+++ b/extra/cap/cap.factor
@@ -0,0 +1,53 @@
+USING: accessors arrays byte-arrays kernel math namespaces
+opengl.gl sequences math.vectors ui graphics.bitmap graphics.viewer
+models opengl.framebuffers ui.gadgets.worlds ui.gadgets fry ;
+IN: cap
+
+: screenshot-array ( world -- byte-array )
+    dim>> product 3 * <byte-array> ;
+
+: gl-screenshot ( gadget -- byte-array )
+    [
+        GL_COLOR_ATTACHMENT0_EXT glReadBuffer
+        GL_PACK_ALIGNMENT 1 glPixelStorei
+        0 0
+    ] dip
+    [ dim>> first2 GL_BGR GL_UNSIGNED_BYTE ]
+    [ screenshot-array ] bi
+    [ glReadPixels ] keep ;
+
+: screenshot ( window -- bitmap )
+    [ gl-screenshot ]
+    [ dim>> first2 ] bi
+    bgr>bitmap ;
+
+: gadget-world ( gadget -- world )
+    "fake" f <model> <world> ;
+
+: draw-world-to-fbo ( world fbo -- )
+    [ relayout-1 ] with-framebuffer ;
+
+: <fbo> ( w h -- fbo )
+    GL_DEPTH_TEST glDisable
+    gen-framebuffer [ '[
+        gen-renderbuffer
+        GL_RENDERBUFFER_EXT over glBindRenderbufferEXT
+        GL_RENDERBUFFER_EXT GL_RGB _ _ glRenderbufferStorageEXT
+        GL_FRAMEBUFFER_EXT
+        GL_COLOR_ATTACHMENT0_EXT
+        GL_RENDERBUFFER_EXT roll glFramebufferRenderbufferEXT
+        check-framebuffer
+    ] with-framebuffer ] keep ;
+
+: draw-gadget-to-bgr ( gadget -- byte-array )
+    [ [ prefer ] [ gadget-world ] bi ] [ dim>> first2 <fbo> ] bi
+    [ gl-screenshot ] with-framebuffer ;
+
+: save-screenshot ( window path -- )
+    [ screenshot ] dip save-bitmap ;
+
+: screenshot. ( window -- )
+    screenshot <graphics-gadget> "Screenshot" open-window ;
+
+
+
diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor
index 82fdc334cb..651c5f7ca1 100755
--- a/extra/graphics/bitmap/bitmap.factor
+++ b/extra/graphics/bitmap/bitmap.factor
@@ -15,6 +15,14 @@ TUPLE: bitmap magic size reserved offset header-length width
     height planes bit-count compression size-image
     x-pels y-pels color-used color-important rgb-quads color-index array ;
 
+: bgr>bitmap ( array height width -- bitmap )
+    bitmap new
+        2over * 3 * >>size-image
+        swap >>height
+        swap >>width
+        swap [ >>array ] [ >>color-index ] bi
+        24 >>bit-count ;
+
 : raw-bitmap>string ( str n -- str )
     {
         { 32 [ "32bit" throw ] }
@@ -74,7 +82,7 @@ M: bitmap-magic summary
 
 : save-bitmap ( bitmap path -- )
     binary [
-        "BM" write
+        "BM" >byte-array write
         dup array>> length 14 + 40 + 4 >le write
         0 4 >le write
         54 4 >le write
@@ -87,10 +95,10 @@ M: bitmap-magic summary
             [ bit-count>> 24 or 2 >le write ]
             [ compression>> 0 or 4 >le write ]
             [ size-image>> 4 >le write ]
-            [ x-pels>> 4 >le write ]
-            [ y-pels>> 4 >le write ]
-            [ color-used>> 4 >le write ]
-            [ color-important>> 4 >le write ]
+            [ x-pels>> 0 or 4 >le write ]
+            [ y-pels>> 0 or 4 >le write ]
+            [ color-used>> 0 or 4 >le write ]
+            [ color-important>> 0 or 4 >le write ]
             [ rgb-quads>> write ]
             [ color-index>> write ]
         } cleave

From f860d97d43c4dc3160d5ad491a567d422d80400e Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@s0i054.powellsbooks.ptp>
Date: Thu, 30 Oct 2008 16:54:55 -0700
Subject: [PATCH 073/318] remove the fbo code, use the gadget title

---
 extra/cap/cap.factor | 26 ++------------------------
 1 file changed, 2 insertions(+), 24 deletions(-)

diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor
index 858ec3e596..5f3ee7b960 100644
--- a/extra/cap/cap.factor
+++ b/extra/cap/cap.factor
@@ -8,7 +8,7 @@ IN: cap
 
 : gl-screenshot ( gadget -- byte-array )
     [
-        GL_COLOR_ATTACHMENT0_EXT glReadBuffer
+        GL_BACK glReadBuffer
         GL_PACK_ALIGNMENT 1 glPixelStorei
         0 0
     ] dip
@@ -21,33 +21,11 @@ IN: cap
     [ dim>> first2 ] bi
     bgr>bitmap ;
 
-: gadget-world ( gadget -- world )
-    "fake" f <model> <world> ;
-
-: draw-world-to-fbo ( world fbo -- )
-    [ relayout-1 ] with-framebuffer ;
-
-: <fbo> ( w h -- fbo )
-    GL_DEPTH_TEST glDisable
-    gen-framebuffer [ '[
-        gen-renderbuffer
-        GL_RENDERBUFFER_EXT over glBindRenderbufferEXT
-        GL_RENDERBUFFER_EXT GL_RGB _ _ glRenderbufferStorageEXT
-        GL_FRAMEBUFFER_EXT
-        GL_COLOR_ATTACHMENT0_EXT
-        GL_RENDERBUFFER_EXT roll glFramebufferRenderbufferEXT
-        check-framebuffer
-    ] with-framebuffer ] keep ;
-
-: draw-gadget-to-bgr ( gadget -- byte-array )
-    [ [ prefer ] [ gadget-world ] bi ] [ dim>> first2 <fbo> ] bi
-    [ gl-screenshot ] with-framebuffer ;
-
 : save-screenshot ( window path -- )
     [ screenshot ] dip save-bitmap ;
 
 : screenshot. ( window -- )
-    screenshot <graphics-gadget> "Screenshot" open-window ;
+    [ screenshot <graphics-gadget> ] [ title>> ] bi open-window ;
 
 
 

From f2538d015679a569fb1fc70490b56a10ca9752b5 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 30 Oct 2008 22:04:44 -0400
Subject: [PATCH 074/318] Clean up Project Euler solutions

---
 extra/project-euler/006/006.factor       |  8 ++++----
 extra/project-euler/009/009.factor       | 16 ++++++++--------
 extra/project-euler/014/014.factor       |  3 +--
 extra/project-euler/016/016.factor       |  6 +++---
 extra/project-euler/017/017.factor       |  9 ++++-----
 extra/project-euler/020/020.factor       |  6 +++---
 extra/project-euler/023/023.factor       |  3 +--
 extra/project-euler/025/025.factor       |  4 ++--
 extra/project-euler/028/028.factor       |  4 ++--
 extra/project-euler/031/031.factor       | 16 ++++++++--------
 extra/project-euler/032/032.factor       |  6 +++---
 extra/project-euler/common/common.factor | 13 +++++++------
 12 files changed, 46 insertions(+), 48 deletions(-)

diff --git a/extra/project-euler/006/006.factor b/extra/project-euler/006/006.factor
index fb4fb954fa..3e2bf19f4a 100644
--- a/extra/project-euler/006/006.factor
+++ b/extra/project-euler/006/006.factor
@@ -1,6 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007-2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.ranges sequences ;
+USING: kernel math math.ranges sequences ;
 IN: project-euler.006
 
 ! http://projecteuler.net/index.php?section=problems&id=6
@@ -35,9 +35,9 @@ IN: project-euler.006
 PRIVATE>
 
 : euler006 ( -- answer )
-    1 100 [a,b] dup sum-of-squares swap square-of-sum - abs ;
+    100 [1,b] [ sum-of-squares ] [ square-of-sum ] bi - abs ;
 
 ! [ euler006 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.24 SD (100 trials)
 
 MAIN: euler006
diff --git a/extra/project-euler/009/009.factor b/extra/project-euler/009/009.factor
index c1a4a16918..2578808926 100644
--- a/extra/project-euler/009/009.factor
+++ b/extra/project-euler/009/009.factor
@@ -1,6 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007-2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions namespaces make sequences sorting ;
+USING: kernel make math sequences sorting ;
 IN: project-euler.009
 
 ! http://projecteuler.net/index.php?section=problems&id=9
@@ -30,14 +30,14 @@ IN: project-euler.009
 
 : abc ( p q -- triplet )
     [
-        2dup * ,                    ! a = p * q
-        [ sq ] bi@ 2dup - 2 / ,  ! b = (p² - q²) / 2
-        + 2 / ,                     ! c = (p² + q²) / 2
+        2dup * ,         ! a = p * q
+        [ sq ] bi@
+        [ - 2 / , ]      ! b = (p² - q²) / 2
+        [ + 2 / , ] 2bi  ! c = (p² + q²) / 2
     ] { } make natural-sort ;
 
 : (ptriplet) ( target p q triplet -- target p q )
-    roll [ swap sum = ] keep -roll
-    [ next-pq 2dup abc (ptriplet) ] unless ;
+    sum [ pick ] dip = [ next-pq 2dup abc (ptriplet) ] unless ;
 
 : ptriplet ( target -- triplet )
    3 1 { 3 4 5 } (ptriplet) abc nip ;
@@ -48,6 +48,6 @@ PRIVATE>
     1000 ptriplet product ;
 
 ! [ euler009 ] 100 ave-time
-! 1 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.73 SD (100 trials)
 
 MAIN: euler009
diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor
index dc0c060b22..93ed0c7754 100644
--- a/extra/project-euler/014/014.factor
+++ b/extra/project-euler/014/014.factor
@@ -1,7 +1,6 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.short-circuit kernel
-math math.ranges namespaces make sequences sorting ;
+USING: combinators.short-circuit kernel make math math.ranges sequences ;
 IN: project-euler.014
 
 ! http://projecteuler.net/index.php?section=problems&id=14
diff --git a/extra/project-euler/016/016.factor b/extra/project-euler/016/016.factor
index 00747a9317..80bbbbaec3 100644
--- a/extra/project-euler/016/016.factor
+++ b/extra/project-euler/016/016.factor
@@ -1,6 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007-2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.functions math.parser project-euler.common sequences ;
+USING: math.functions project-euler.common sequences ;
 IN: project-euler.016
 
 ! http://projecteuler.net/index.php?section=problems&id=16
@@ -20,6 +20,6 @@ IN: project-euler.016
     2 1000 ^ number>digits sum ;
 
 ! [ euler016 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.67 SD (100 trials)
 
 MAIN: euler016
diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor
index 5f6541873a..b47e2429f2 100644
--- a/extra/project-euler/017/017.factor
+++ b/extra/project-euler/017/017.factor
@@ -1,7 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007-2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.ranges math.text.english sequences strings
-    ascii combinators.short-circuit ;
+USING: ascii kernel math.ranges math.text.english sequences ;
 IN: project-euler.017
 
 ! http://projecteuler.net/index.php?section=problems&id=17
@@ -26,7 +25,7 @@ IN: project-euler.017
 : euler017 ( -- answer )
     1000 [1,b] SBUF" " clone [ number>text over push-all ] reduce [ Letter? ] count ;
 
-! [ euler017a ] 100 ave-time
-! 14 ms run / 0 ms GC ave time - 100 trials
+! [ euler017 ] 100 ave-time
+! 15 ms ave run time - 1.71 SD (100 trials)
 
 MAIN: euler017
diff --git a/extra/project-euler/020/020.factor b/extra/project-euler/020/020.factor
index 8ac75bd9ff..42d352858c 100644
--- a/extra/project-euler/020/020.factor
+++ b/extra/project-euler/020/020.factor
@@ -1,6 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007-2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.combinatorics math.parser project-euler.common sequences ;
+USING: math.combinatorics project-euler.common sequences ;
 IN: project-euler.020
 
 ! http://projecteuler.net/index.php?section=problems&id=20
@@ -20,6 +20,6 @@ IN: project-euler.020
     100 factorial number>digits sum ;
 
 ! [ euler020 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.55 (100 trials)
 
 MAIN: euler020
diff --git a/extra/project-euler/023/023.factor b/extra/project-euler/023/023.factor
index 6b38a2b6ac..80aa40f449 100644
--- a/extra/project-euler/023/023.factor
+++ b/extra/project-euler/023/023.factor
@@ -1,7 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables kernel math math.ranges project-euler.common sequences
-    sorting sets ;
+USING: kernel math math.ranges project-euler.common sequences sets sorting ;
 IN: project-euler.023
 
 ! http://projecteuler.net/index.php?section=problems&id=23
diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor
index 2786d9f0e6..6d15a9f6ec 100644
--- a/extra/project-euler/025/025.factor
+++ b/extra/project-euler/025/025.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math math.constants math.functions math.parser
-    math.ranges memoize project-euler.common sequences ;
+USING: kernel math math.constants math.functions math.parser memoize
+    project-euler.common sequences ;
 IN: project-euler.025
 
 ! http://projecteuler.net/index.php?section=problems&id=25
diff --git a/extra/project-euler/028/028.factor b/extra/project-euler/028/028.factor
index d0f3892956..cd359c70a9 100644
--- a/extra/project-euler/028/028.factor
+++ b/extra/project-euler/028/028.factor
@@ -30,7 +30,7 @@ IN: project-euler.028
 <PRIVATE
 
 : sum-corners ( n -- sum )
-    dup 1 = [ [ sq 4 * ] keep 6 * - 6 + ] unless ;
+    dup 1 = [ [ sq 4 * ] [ 6 * ] bi - 6 + ] unless ;
 
 : sum-diags ( n -- sum )
     1 swap 2 <range> [ sum-corners ] sigma ;
@@ -41,6 +41,6 @@ PRIVATE>
     1001 sum-diags ;
 
 ! [ euler028 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.39 SD (100 trials)
 
 MAIN: euler028
diff --git a/extra/project-euler/031/031.factor b/extra/project-euler/031/031.factor
index 4be866dc03..1b6d1c83eb 100644
--- a/extra/project-euler/031/031.factor
+++ b/extra/project-euler/031/031.factor
@@ -30,25 +30,25 @@ IN: project-euler.031
     drop 1 ;
 
 : 2p ( m -- n )
-    dup 0 >= [ [ 2 - 2p ] keep 1p + ] [ drop 0 ] if ;
+    dup 0 >= [ [ 2 - 2p ] [ 1p ] bi + ] [ drop 0 ] if ;
 
 : 5p ( m -- n )
-    dup 0 >= [ [ 5 - 5p ] keep 2p + ] [ drop 0 ] if ;
+    dup 0 >= [ [ 5 - 5p ] [ 2p ] bi + ] [ drop 0 ] if ;
 
 : 10p ( m -- n )
-    dup 0 >= [ [ 10 - 10p ] keep 5p + ] [ drop 0 ] if ;
+    dup 0 >= [ [ 10 - 10p ] [ 5p ] bi + ] [ drop 0 ] if ;
 
 : 20p ( m -- n )
-    dup 0 >= [ [ 20 - 20p ] keep 10p + ] [ drop 0 ] if ;
+    dup 0 >= [ [ 20 - 20p ] [ 10p ] bi + ] [ drop 0 ] if ;
 
 : 50p ( m -- n )
-    dup 0 >= [ [ 50 - 50p ] keep 20p + ] [ drop 0 ] if ;
+    dup 0 >= [ [ 50 - 50p ] [ 20p ] bi + ] [ drop 0 ] if ;
 
 : 100p ( m -- n )
-    dup 0 >= [ [ 100 - 100p ] keep 50p + ] [ drop 0 ] if ;
+    dup 0 >= [ [ 100 - 100p ] [ 50p ] bi + ] [ drop 0 ] if ;
 
 : 200p ( m -- n )
-    dup 0 >= [ [ 200 - 200p ] keep 100p + ] [ drop 0 ] if ;
+    dup 0 >= [ [ 200 - 200p ] [ 100p ] bi + ] [ drop 0 ] if ;
 
 PRIVATE>
 
@@ -56,7 +56,7 @@ PRIVATE>
     200 200p ;
 
 ! [ euler031 ] 100 ave-time
-! 4 ms run / 0 ms GC ave time - 100 trials
+! 3 ms ave run time - 0.91 SD (100 trials)
 
 ! TODO: generalize to eliminate duplication; use a sequence to specify denominations?
 
diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor
index f9667c75fe..02c1d44e43 100755
--- a/extra/project-euler/032/032.factor
+++ b/extra/project-euler/032/032.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables kernel math math.combinatorics math.functions
-    math.parser math.ranges project-euler.common sequences sets ;
+USING: kernel math math.combinatorics math.functions math.parser math.ranges
+    project-euler.common sequences sets ;
 IN: project-euler.032
 
 ! http://projecteuler.net/index.php?section=problems&id=32
@@ -38,7 +38,7 @@ IN: project-euler.032
     [ string>number ] tri@ [ * ] dip = ;
 
 : valid? ( n -- ? )
-    dup 1and4 swap 2and3 or ;
+    [ 1and4 ] [ 2and3 ] bi or ;
 
 : products ( seq -- m )
     [ 10 4 ^ mod ] map ;
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index 094893616b..aa7781dc46 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -1,7 +1,8 @@
-USING: arrays kernel math math.functions math.miller-rabin
-math.matrices math.order math.parser math.primes.factors
-math.ranges namespaces make sequences sequences.lib sorting
-unicode.case ;
+! Copyright (c) 2007-2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math math.functions math.miller-rabin math.matrices
+    math.order math.parser math.primes.factors math.ranges make namespaces
+    sequences sequences.lib sorting unicode.case ;
 IN: project-euler.common
 
 ! A collection of words used by more than one Project Euler solution
@@ -26,7 +27,7 @@ IN: project-euler.common
 
 
 : nth-pair ( n seq -- nth next )
-    over 1+ over nth >r nth r> ;
+    2dup [ 1+ ] dip [ nth ] 2bi@ ;
 
 : perfect-square? ( n -- ? )
     dup sqrt mod zero? ;
@@ -34,7 +35,7 @@ IN: project-euler.common
 <PRIVATE
 
 : count-shifts ( seq width -- n )
-    >r length 1+ r> - ;
+    [ length 1+ ] dip - ;
 
 : max-children ( seq -- seq )
     [ dup length 1- [ over nth-pair max , ] each ] { } make nip ;

From 3127cfdddced93985cdc053bef4c1e3ef37cff82 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 30 Oct 2008 23:34:32 -0400
Subject: [PATCH 075/318] Use clump instead of collect-consecutive in PE

---
 extra/project-euler/008/008.factor       |  8 ++++----
 extra/project-euler/011/011.factor       |  9 ++++-----
 extra/project-euler/common/common.factor | 18 +++---------------
 3 files changed, 11 insertions(+), 24 deletions(-)

diff --git a/extra/project-euler/008/008.factor b/extra/project-euler/008/008.factor
index 8b32d5651e..24ccbb443a 100644
--- a/extra/project-euler/008/008.factor
+++ b/extra/project-euler/008/008.factor
@@ -1,6 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.parser project-euler.common sequences ;
+USING: grouping math.parser sequences ;
 IN: project-euler.008
 
 ! http://projecteuler.net/index.php?section=problems&id=8
@@ -64,9 +64,9 @@ IN: project-euler.008
 PRIVATE>
 
 : euler008 ( -- answer )
-    source-008 5 collect-consecutive [ string>digits product ] map supremum ;
+    source-008 5 clump [ string>digits product ] map supremum ;
 
 ! [ euler008 ] 100 ave-time
-! 11 ms run / 0 ms GC ave time - 100 trials
+! 2 ms ave run time - 0.79 SD (100 trials)
 
 MAIN: euler008
diff --git a/extra/project-euler/011/011.factor b/extra/project-euler/011/011.factor
index f4e549c7c0..0940695726 100644
--- a/extra/project-euler/011/011.factor
+++ b/extra/project-euler/011/011.factor
@@ -1,7 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make project-euler.common sequences
-splitting grouping ;
+USING: grouping kernel make sequences ;
 IN: project-euler.011
 
 ! http://projecteuler.net/index.php?section=problems&id=11
@@ -88,7 +87,7 @@ IN: project-euler.011
     horizontal pad-front pad-back flip ;
 
 : max-product ( matrix width -- n )
-    [ collect-consecutive ] curry map concat
+    [ clump ] curry map concat
     [ product ] map supremum ; inline
 
 PRIVATE>
@@ -100,6 +99,6 @@ PRIVATE>
     ] { } make supremum ;
 
 ! [ euler011 ] 100 ave-time
-! 4 ms run / 0 ms GC ave time - 100 trials
+! 3 ms ave run time - 0.77 SD (100 trials)
 
 MAIN: euler011
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index aa7781dc46..5d1aa16a32 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -1,8 +1,8 @@
 ! Copyright (c) 2007-2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions math.miller-rabin math.matrices
-    math.order math.parser math.primes.factors math.ranges make namespaces
-    sequences sequences.lib sorting unicode.case ;
+USING: arrays kernel make math math.functions math.matrices math.miller-rabin
+    math.order math.parser math.primes.factors math.ranges sequences
+    sequences.lib sorting unicode.case ;
 IN: project-euler.common
 
 ! A collection of words used by more than one Project Euler solution
@@ -12,7 +12,6 @@ IN: project-euler.common
 ! -------------------------------
 ! alpha-value - #22, #42
 ! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
-! collect-consecutive - #8, #11
 ! log10 - #25, #134
 ! max-path - #18, #67
 ! nth-triangle - #12, #42
@@ -34,9 +33,6 @@ IN: project-euler.common
 
 <PRIVATE
 
-: count-shifts ( seq width -- n )
-    [ length 1+ ] dip - ;
-
 : max-children ( seq -- seq )
     [ dup length 1- [ over nth-pair max , ] each ] { } make nip ;
 
@@ -44,9 +40,6 @@ IN: project-euler.common
 : propagate ( bottom top -- newtop )
     [ over rest rot first2 max rot + ] map nip ;
 
-: shift-3rd ( seq obj obj -- seq obj obj )
-    rot rest -rot ;
-
 : (sum-divisors) ( n -- sum )
     dup sqrt >fixnum [1,b] [
         [ 2dup mod zero? [ 2dup / + , ] [ drop ] if ] each
@@ -64,11 +57,6 @@ PRIVATE>
 : cartesian-product ( seq1 seq2 -- seq1xseq2 )
     swap [ swap [ 2array ] map-with ] map-with concat ;
 
-: collect-consecutive ( seq width -- seq )
-    [
-        2dup count-shifts [ 2dup head shift-3rd , ] times
-    ] { } make 2nip ;
-
 : log10 ( m -- n )
     log 10 log / ;
 

From 852c16a79b663ca9bc29d21e2a32e52477ee6f7b Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Fri, 31 Oct 2008 01:35:37 -0400
Subject: [PATCH 076/318] Fix sorting string equality issue in Project Euler

---
 extra/project-euler/006/006.factor       | 2 +-
 extra/project-euler/009/009.factor       | 2 +-
 extra/project-euler/016/016.factor       | 2 +-
 extra/project-euler/017/017.factor       | 2 +-
 extra/project-euler/020/020.factor       | 2 +-
 extra/project-euler/038/038.factor       | 3 ++-
 extra/project-euler/common/common.factor | 2 +-
 7 files changed, 8 insertions(+), 7 deletions(-)

diff --git a/extra/project-euler/006/006.factor b/extra/project-euler/006/006.factor
index 3e2bf19f4a..2149353658 100644
--- a/extra/project-euler/006/006.factor
+++ b/extra/project-euler/006/006.factor
@@ -1,4 +1,4 @@
-! Copyright (c) 2007-2008 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.ranges sequences ;
 IN: project-euler.006
diff --git a/extra/project-euler/009/009.factor b/extra/project-euler/009/009.factor
index 2578808926..a1040d2bf2 100644
--- a/extra/project-euler/009/009.factor
+++ b/extra/project-euler/009/009.factor
@@ -1,4 +1,4 @@
-! Copyright (c) 2007-2008 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel make math sequences sorting ;
 IN: project-euler.009
diff --git a/extra/project-euler/016/016.factor b/extra/project-euler/016/016.factor
index 80bbbbaec3..216fcb3523 100644
--- a/extra/project-euler/016/016.factor
+++ b/extra/project-euler/016/016.factor
@@ -1,4 +1,4 @@
-! Copyright (c) 2007-2008 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math.functions project-euler.common sequences ;
 IN: project-euler.016
diff --git a/extra/project-euler/017/017.factor b/extra/project-euler/017/017.factor
index b47e2429f2..21e277da00 100644
--- a/extra/project-euler/017/017.factor
+++ b/extra/project-euler/017/017.factor
@@ -1,4 +1,4 @@
-! Copyright (c) 2007-2008 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: ascii kernel math.ranges math.text.english sequences ;
 IN: project-euler.017
diff --git a/extra/project-euler/020/020.factor b/extra/project-euler/020/020.factor
index 42d352858c..e75747b57c 100644
--- a/extra/project-euler/020/020.factor
+++ b/extra/project-euler/020/020.factor
@@ -1,4 +1,4 @@
-! Copyright (c) 2007-2008 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math.combinatorics project-euler.common sequences ;
 IN: project-euler.020
diff --git a/extra/project-euler/038/038.factor b/extra/project-euler/038/038.factor
index 78e3848a33..05bab5fc36 100755
--- a/extra/project-euler/038/038.factor
+++ b/extra/project-euler/038/038.factor
@@ -1,6 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser math.ranges project-euler.common sequences ;
+USING: kernel math math.parser math.ranges project-euler.common sequences
+    strings ;
 IN: project-euler.038
 
 ! http://projecteuler.net/index.php?section=problems&id=38
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index 5d1aa16a32..c609d82747 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -77,7 +77,7 @@ PRIVATE>
     number>string dup reverse = ;
 
 : pandigital? ( n -- ? )
-    number>string natural-sort "123456789" = ;
+    number>string natural-sort >string "123456789" = ;
 
 : pentagonal? ( n -- ? )
     dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;

From aa9552f291ed082a8ed216c1b4dadcd6189eb9e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 31 Oct 2008 21:07:00 -0500
Subject: [PATCH 077/318] Slides from recent presentations

---
 extra/galois-talk/galois-talk.factor          | 312 ++++++++++
 .../google-tech-talk/google-tech-talk.factor  | 569 ++++++++++++++++++
 extra/vpri-talk/vpri-talk.factor              | 492 +++++++++++++++
 3 files changed, 1373 insertions(+)
 create mode 100644 extra/galois-talk/galois-talk.factor
 create mode 100644 extra/google-tech-talk/google-tech-talk.factor
 create mode 100644 extra/vpri-talk/vpri-talk.factor

diff --git a/extra/galois-talk/galois-talk.factor b/extra/galois-talk/galois-talk.factor
new file mode 100644
index 0000000000..259fa446af
--- /dev/null
+++ b/extra/galois-talk/galois-talk.factor
@@ -0,0 +1,312 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slides help.markup math arrays hashtables namespaces
+sequences kernel sequences parser memoize io.encodings.binary
+locals kernel.private tools.vocabs.browser assocs quotations
+urls peg.ebnf tools.vocabs tools.annotations tools.crossref
+help.topics math.functions compiler.tree.optimizer
+compiler.cfg.optimizer fry ;
+IN: galois-talk
+
+: galois-slides
+{
+    { $slide "Factor!"
+        { $url "http://factorcode.org" }
+        "Development started in 2003"
+        "Open source (BSD license)"
+        "Influenced by Forth, Lisp, and Smalltalk"
+        "Blurs the line between language and library"
+        "Interactive development"
+    }
+    { $slide "Words and the stack"
+        "Stack based, dynamically typed"
+        { $code "{ 1 1 3 4 4 8 9 9 } dup duplicates diff ." }
+        "Words: named code snippets"
+        { $code ": remove-duplicates ( seq -- seq' )" "    dup duplicates diff ;" }
+        { $code "{ 1 1 3 4 4 8 9 9 } remove-duplicates ." }
+    }
+    { $slide "Vocabularies"
+        "Vocabularies: named sets of words"
+        { $link "vocab-index" }
+        { { $link POSTPONE: USING: } " loads dependencies" }
+        "Source, docs, tests in one place"
+    }
+    { $slide "Interactive development"
+        "Programming is hard, let's play tetris"
+        { $vocab-link "tetris" }
+        "Tetris is hard too... let's cheat"
+        "Factor workflow: change code, F2, test, repeat"
+    }
+    { $slide "Quotations"
+        "Quotation: unnamed block of code"
+        "Combinators: words taking quotations"
+        { $code "10 dup 0 < [ 1 - ] [ 1 + ] if ." }
+        { $code "{ -1 1 -2 0 3 } [ 0 max ] map ." }
+        "Partial application:"
+        { $code ": clamp ( seq n -- seq' ) '[ _ max ] map ;" "{ -1 1 -2 0 3 } 0 clamp" }
+    }
+    { $slide "Object system"
+        "CLOS with single dispatch"
+        "A tuple is a user-defined class which holds named values."
+        { $code
+            "TUPLE: rectangle width height ;"
+            "TUPLE: circle radius ;"
+        }
+    }
+    { $slide "Object system"
+        "Constructing instances:"
+        { $code "rectangle new" }
+        { $code "rectangle boa" }
+        "Let's encapsulate:"
+        { $code
+            ": <rectangle> ( w h -- r ) rectangle boa ;"
+            ": <circle> ( r -- c ) circle boa ;"
+        }
+    }
+    { $slide "Object system"
+        "Generic words and methods"
+        { $code "GENERIC: area ( shape -- n )" }
+        "Two methods:"
+        { $code
+            "USE: math.constants"
+            ""
+            "M: rectangle area"
+            "    [ width>> ] [ height>> ] bi * ;"
+            ""
+            "M: circle area radius>> sq pi * ;"
+        }
+    }
+    { $slide "Object system"
+        "We can compute areas now."
+        { $code "100 20 <rectangle> area ." }
+        { $code "3 <circle> area ." }
+    }
+    { $slide "Object system"
+        "Object system handles dynamic redefinition very well"
+        { $code "TUPLE: person name age occupation ;" }
+        "Make an instance..."
+    }
+    { $slide "Object system"
+        "Let's add a new slot:"
+        { $code "TUPLE: person name age address occupation ;" }
+        "Fill it in with inspector..."
+        "Change the order:"
+        { $code "TUPLE: person name occupation address ;" }
+    }
+    { $slide "Object system"
+        "How does it work?"
+        "Objects are not hashtables; slot access is very fast"
+        "Redefinition walks the heap; expensive but rare"
+    }
+    { $slide "Object system"
+        "Supports \"duck typing\""
+        "Two tuples can have a slot with the same name"
+        "Code that uses accessors will work on both"
+        "Accessors are auto-generated generic words"
+    }
+    { $slide "Object system"
+        "Predicate classes"
+        { $code
+            "PREDICATE: positive < integer 0 > ;"
+            "PREDICATE: negative < integer 0 < ;"
+            ""
+            "GENERIC: abs ( n -- )"
+            ""
+            "M: positive abs ;"
+            "M: negative abs -1 * ;"
+            "M: integer abs ;"
+        }
+    }
+    { $slide "Object system"
+        "More: inheritance, type declarations, read-only slots, union, intersection, singleton classes, reflection"
+        "Object system is entirely implemented in Factor"
+    }
+    { $slide "The parser"
+        "All data types have a literal syntax"
+        "Literal hashtables and arrays are very useful in data-driven code"
+        "\"Code is data\" because quotations are objects (enables Lisp-style macros)"
+        { $code "H{ { \"cookies\" 12 } { \"milk\" 10 } }" }
+        "Libraries can define new parsing words"
+    }
+    { $slide "Example: regexp"
+        { $vocab-link "regexp" }
+        "Pre-compiles regexp at parse time"
+        "Implemented with library code"
+        { $code "USE: regexp" }
+        { $code "\"ababbc\" \"[ab]+c\" <regexp> matches? ." }
+        { $code "\"ababbc\" R/ [ab]+c/ matches? ." }
+    }
+    { $slide "Example: memoization"
+        { "Memoization with " { $link POSTPONE: MEMO: } }
+        { $code
+            ": fib ( m -- n )"
+            "    dup 1 > ["
+            "        [ 1 - fib ] [ 2 - fib ] bi +"
+            "    ] when ;"
+        }
+        "Very slow! Let's profile it..."
+    }
+    { $slide "Example: memoization"
+        { "Let's use " { $link POSTPONE: : } " instead of " { $link POSTPONE: MEMO: } }
+        { $code
+            "MEMO: fib ( m -- n )"
+            "    dup 1 > ["
+            "        [ 1 - fib ] [ 2 - fib ] bi +"
+            "    ] when ;"
+        }
+        "Much faster"
+    }
+    { $slide "Meta-circularity"
+        { { $link POSTPONE: MEMO: } " is just a library word" }
+        { "But so is " { $link POSTPONE: : } }
+        "Factor's parser is written in Factor"
+        { "All syntax is just parsing words: " { $link POSTPONE: [ } ", " { $link POSTPONE: " } }
+    }
+    { $slide "Extensible syntax, DSLs"
+        "Most parsing words fall in one of two categories"
+        "First category: literal syntax for new data types"
+        "Second category: defining new types of words"
+        "Some parsing words are more complicated"
+    }
+    { $slide "Example: printf"
+        { { $link POSTPONE: EBNF: } ": a complex parsing word" }
+        "Implements a custom syntax for expressing parsers: like OMeta!"
+        { "Example: " { $vocab-link "printf-example" } }
+        { $code "\"vegan\" \"cheese\" \"%s is not %s\\n\" printf" }
+        { $code "5 \"Factor\" \"%s is %d years old\\n\" printf" }
+    }
+    { $slide "Example: simple web browser"
+        { $vocab-link "webkit-demo" }
+        "Demonstrates Cocoa binding"
+        "Let's deploy a stand-alone binary with the deploy tool"
+        "Deploy tool generates binaries with no external dependencies"
+    }
+    { $slide "Locals and lexical scope"
+        "Sometimes, there's no good stack solution to a problem"
+        "Or, you're porting existing code in a quick-and-dirty way"
+        "Our solution: implement named locals as a DSL in Factor"
+        "Influenced by Scheme and Lisp"
+    }
+    { $slide "Locals and lexical scope"
+        { "Define lambda words with " { $link POSTPONE: :: } }
+        { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+        "Mutable bindings with correct semantics"
+        { "Named inputs for quotations with " { $link POSTPONE: [| } }
+        "Full closures"
+    }
+    { $slide "Locals and lexical scope"
+        "Combinator with 5 parameters!"
+        { $code
+            ":: branch ( a b neg zero pos -- )"
+            "    a b = zero [ a b < neg pos if ] if ; inline"
+        }
+        "Unwieldy with the stack"
+    }
+    { $slide "Locals and lexical scope"
+        { $code
+            ": check-drinking-age ( age -- )"
+            "    21"
+            "    [ \"You're underage!\" print ]"
+            "    [ \"Grats, you're now legal\" print ]"
+            "    [ \"Go get hammered\" print ]"
+            "    branch ;"
+        }
+    }
+    { $slide "Locals and lexical scope"
+        "Locals are entirely implemented in Factor"
+        "Example of compile-time meta-programming"
+        "No performance penalty -vs- using the stack"
+        "In the base image, only 59 words out of 13,000 use locals"
+    }
+    { $slide "More about partial application"
+        { { $link POSTPONE: '[ } " is \"fry syntax\"" }
+        { $code "'[ _ + ] == [ + ] curry" }
+        { $code "'[ @ t ] == [ t ] compose" }
+        { $code "'[ _ nth @ ] == [ [ nth ] curry ] dip compose" }
+        { $code "'[ [ _ ] dip nth ] == [ [ ] curry dip nth ] curry" }
+        { "Fry and locals desugar to " { $link curry } ", " { $link compose } }
+    }
+    { $slide "Help system"
+        "Help markup is just literal data"
+        { "Look at the help for " { $link T{ link f + } } }
+        "These slides are built with the help system and a custom style sheet"
+        { $vocab-link "galois-talk" }
+    }
+    { $slide "Why stack-based?"
+        "Because nobody else is doing it"
+        "Interesting properties: concatenation is composition, chaining functions together, \"fluent\" interfaces, new combinators"
+        { $vocab-link "smtp-example" }
+        { $code
+            "{ \"chicken\" \"beef\" \"pork\" \"turkey\" }"
+            "[ 5 short head ] map ."
+        }
+    }
+    { $slide "Implementation"
+        "VM: garbage collection, bignums, ..."
+        "Bootstrap image: parser, hashtables, object system, ..."
+        "Non-optimizing compiler"
+        "Stage 2 bootstrap: optimizing compiler, UI, ..."
+        "Full image contains machine code"
+    }
+    { $slide "Compiler"
+        { "Let's look at " { $vocab-link "benchmark.mandel" } }
+        "A naive implementation would be very slow"
+        "Combinators, partial application"
+        "Boxed complex numbers"
+        "Boxed floats"
+        { "Redundancy in " { $link absq } " and " { $link sq } }
+    }
+    { $slide "Compiler: high-level optimizer"
+        "High-level SSA IR"
+        "Type inference (classes, intervals, arrays with a fixed length, literals, ...)"
+        "Escape analysis and tuple unboxing"
+    }
+    { $slide "Compiler: high-level optimizer"
+        "Loop index becomes a fixnum, complex numbers unboxed, generic arithmetic inlined, higher-order code become first-order..."
+        { $code "[ c pixel ] optimized." }
+    }
+    { $slide "Compiler: low-level optimizer"
+        "Low-level SSA IR"
+        "Alias analysis"
+        "Value numbering"
+        "Linear scan register allocation"
+    }
+    { $slide "Compiler: low-level optimizer"
+        "Redundant stack operations eliminated, intermediate floats unboxed..."
+        { $code "[ c pixel ] test-mr mr." }
+    }
+    { $slide "Garbage collection"
+        "All roots are identified precisely"
+        "Generational copying for data"
+        "Mark sweep for native code"
+    }
+    { $slide "Project infrastructure"
+        { $url "http://factorcode.org" }
+        { $url "http://concatenative.org" }
+        { $url "http://docs.factorcode.org" }
+        { $url "http://planet.factorcode.org" }
+        "Uses our HTTP server, SSL, DB, Atom libraries..."
+    }
+    { $slide "Project infrastructure"
+        "Build farm, written in Factor"
+        "12 platforms"
+        "Builds Factor and all libraries, runs tests, makes binaries"
+        "Saves us from the burden of making releases by hand"
+        "Maintains stability"
+    }
+    { $slide "Community"
+        "#concatenative irc.freenode.net: 50-60 members"
+        "factor-talk@lists.sf.net: 180 subscribers"
+        "About 30 people have code in the Factor repository"
+        "Easy to get started: binaries, lots of docs, friendly community..."
+    }
+    { $slide "That's all, folks"
+        "It is hard to cover everything in a single talk"
+        "Factor has many cool things that I didn't talk about"
+        "Questions?"
+    }
+} ;
+
+: galois-talk ( -- ) galois-slides slides-window ;
+
+MAIN: galois-talk
diff --git a/extra/google-tech-talk/google-tech-talk.factor b/extra/google-tech-talk/google-tech-talk.factor
new file mode 100644
index 0000000000..3477fbe4bd
--- /dev/null
+++ b/extra/google-tech-talk/google-tech-talk.factor
@@ -0,0 +1,569 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slides help.markup math arrays hashtables namespaces
+sequences kernel sequences parser memoize io.encodings.binary
+locals kernel.private tools.vocabs.browser assocs quotations
+urls peg.ebnf tools.vocabs tools.annotations tools.crossref
+help.topics math.functions compiler.tree.optimizer
+compiler.cfg.optimizer fry ;
+IN: google-tech-talk
+
+: google-slides
+{
+    { $slide "Factor!"
+        { $url "http://factorcode.org" }
+        "Development started in 2003"
+        "Open source (BSD license)"
+        "First result for \"Factor\" on Google :-)"
+        "Influenced by Forth, Lisp, and Smalltalk (but don't worry if you don't know them)"
+    }
+    { $slide "Language overview"
+        "Words operate on a stack"
+        "Functional"
+        "Object-oriented"
+        "Rich collections library"
+        "Rich input/output library"
+        "Optional named local variables"
+        "Extensible syntax"
+    }
+    { $slide "Example: factorial"
+        "Lame example, but..."
+        { $code "USE: math.ranges" ": factorial ( n -- n! )" "    1 [a,b] product ;" }
+        { $code "100 factorial ." }
+    }
+    { $slide "Example: sending an e-mail"
+        { $vocab-link "smtp-example" }
+        "Demonstrates basic stack syntax and tuple slot setters"
+    }
+    { $slide "Functional programming"
+        "Code is data in Factor"
+        { { $snippet "[ ... ]" } " is a block of code pushed on the stack" }
+        { "We call them " { $emphasis "quotations" } }
+        { "Words which take quotations as input are called " { $emphasis "combinators" } }
+    }
+    { $slide "Functional programming"
+        { $code "10 dup 0 < [ 1 - ] [ 1 + ] if ." }
+        { $code "10 [ \"Hello Googlers!\" print ] times" }
+        { $code
+            "USING: io.encodings.ascii unicode.case ;"
+            "{ \"tomato\" \"orange\" \"banana\" }"
+            "\"out.txt\" ascii ["
+            "    [ >upper print ] each"
+            "] with-file-writer"
+        }
+    }
+    { $slide "Object system: motivation"
+        "Encapsulation, polymorphism, inheritance"
+        "Smalltalk, Python, Java approach: methods inside classes"
+        "Often the \"message sending\" metaphor is used to describe such systems"
+    }
+    { $slide "Object system: motivation"
+        { $code
+            "class Rect {"
+            "  int x, y;"
+            "  int area() { ... }"
+            "  int perimeter() { ... }"
+            "}"
+            ""
+            "class Circle {"
+            "  int radius;"
+            "  int area() { ... }"
+            "  int perimeter() { ... }"
+            "}"
+        }
+    }
+    { $slide "Object system: motivation"
+        "Classical functional language approach: functions switch on a type"
+        { $code
+            "data Shape = Rect w h | Circle r"
+            ""
+            "area s = s of"
+            "  (Rect w h) = ..."
+            "| (Circle r) = ..."
+            ""
+            "perimeter s = s of"
+            "  (Rect w h) = ..."
+            "| (Circle r) = ..."
+        }
+    }
+    { $slide "Object system: motivation"
+        "First approach: hard to extend existing types with new operations (open classes, etc are a hack)"
+        "Second approach: hard to extend existing operations with new types"
+        "Common Lisp Object System (CLOS): decouples classes from methods."
+        "Factor's object system is a simplified CLOS"
+    }
+    { $slide "Object system"
+        "A tuple is a user-defined class which holds named values."
+        { $code
+            "TUPLE: rectangle width height ;"
+            "TUPLE: circle radius ;"
+        }
+    }
+    { $slide "Object system"
+        "Constructing instances:"
+        { $code "rectangle new" }
+        { $code "rectangle boa" }
+        "Let's encapsulate:"
+        { $code
+            ": <rectangle> ( w h -- r ) rectangle boa ;"
+            ": <circle> ( r -- c ) circle boa ;"
+        }
+    }
+    { $slide "Object system"
+        "Generic words and methods"
+        { $code "GENERIC: area ( shape -- n )" }
+        "Two methods:"
+        { $code
+            "USE: math.constants"
+            ""
+            "M: rectangle area"
+            "    [ width>> ] [ height>> ] bi * ;"
+            ""
+            "M: circle area radius>> sq pi * ;"
+        }
+    }
+    { $slide "Object system"
+        "We can compute areas now."
+        { $code "100 20 <rectangle> area ." }
+        { $code "3 <circle> area ." }
+    }
+    { $slide "Object system"
+        "New operation, existing types:"
+        { $code
+            "GENERIC: perimeter ( shape -- n )"
+            ""
+            "M: rectangle perimeter"
+            "    [ width>> ] [ height>> ] bi + 2 * ;"
+            ""
+            "M: circle perimeter"
+            "    radius>> 2 * pi * ;"
+        }
+    }
+    { $slide "Object system"
+        "We can compute perimeters now."
+        { $code "100 20 <rectangle> perimeter ." }
+        { $code "3 <circle> perimeter ." }
+    }
+    { $slide "Object system"
+        "New type, extending existing operations:"
+        { $code
+            "TUPLE: triangle base height ;"
+            ""
+            ": <triangle> ( b h -- t ) triangle boa ;"
+            ""
+            "M: triangle area"
+            "    [ base>> ] [ height>> ] bi * 2 / ;"
+        }
+    }
+    { $slide "Object system"
+        "New type, extending existing operations:"
+        { $code
+            ": hypotenuse ( x y -- z ) [ sq ] bi@ + sqrt ;"
+            ""
+            "M: triangle perimeter"
+            "    [ base>> ] [ height>> ] bi"
+            "    [ + ] [ hypotenuse ] 2bi + ;"
+        }
+    }
+    { $slide "Object system"
+        "We can ask an object if its a rectangle:"
+        { $code "70 65 <rectangle> rectangle? ." }
+        { $code "13 <circle> rectangle? ." }
+        { "How do we tell if something is a " { $emphasis "shape" } "?" }
+    }
+    { $slide "Object system"
+        "We define a mixin class for shapes, and add our existing data types as instances:"
+        { $code
+            "MIXIN: shape"
+            "INSTANCE: rectangle shape"
+            "INSTANCE: circle shape"
+            "INSTANCE: triangle shape"
+        }
+    }
+    { $slide "Object system"
+        "Now, we can ask objects if they are shapes or not:"
+        { $code "13 <circle> shape? ." }
+        { $code "3.14 shape? ." }
+    }
+    { $slide "Object system"
+        "Or put methods on shapes:"
+        { $code
+            "GENERIC: tell-me ( obj -- )"
+            ""
+            "M: shape tell-me"
+            "    \"My area is \" write area . ;"
+            ""
+            "M: integer tell-me"
+            "    \"I am \" write"
+            "    even? \"even\" \"odd\" ? print ;"
+        }
+    }
+    { $slide "Object system"
+        "Let's test our new generic word:"
+        { $code "13 <circle> tell-me" }
+        { $code "103 76 <rectangle> tell-me" }
+        { $code "101 tell-me" }
+        { { $link integer } ", " { $link array } ", and others area built-in classes" }
+    }
+    { $slide "Object system"
+        "Anyone can define new shapes..."
+        { $code
+            "TUPLE: parallelogram ... ;"
+            ""
+            "INSTANCE: parallelogram shape"
+            ""
+            "M: parallelogram area ... ;"
+            ""
+            "M: parallelogram perimeter ... ;"
+        }
+    }
+    { $slide "Object system"
+        "More: inheritance, type declarations, read-only slots, predicate, intersection, singleton classes, reflection"
+        "Object system is entirely implemented in Factor: 2184 lines"
+        { { $vocab-link "generic" } ", " { $vocab-link "classes" } ", " { $vocab-link "slots" } }
+    }
+    { $slide "Collections"
+        "Sequences (arrays, vector, strings, ...)"
+        "Associative mappings (hashtables, ...)"
+        { "More: deques, heaps, purely functional structures, disjoint sets, and more: "
+        { $link T{ vocab-tag f "collections" } } }
+    }
+    { $slide "Sequences"
+        { "Protocol: " { $link length } ", " { $link set-length } ", " { $link nth } ", " { $link set-nth } }
+        { "Combinators: " { $link each } ", " { $link map } ", " { $link filter } ", " { $link produce } ", and more: " { $link "sequences-combinators" } }
+        { "Utilities: " { $link append } ", " { $link reverse } ", " { $link first } ",  " { $link second } ", ..." }
+    }
+    { $slide "Example: bin packing"
+        { "We have " { $emphasis "m" } " objects and " { $emphasis "n" } " bins, and we want to distribute these objects as evenly as possible." }
+        { $vocab-link "distribute-example" }
+        "Demonstrates various sequence utilities and vector words"
+        { $code "20 13 distribute ." }
+    }
+    { $slide "Unicode strings"
+        "Strings are sequences of 21-bit Unicode code points"
+        "Efficient implementation: ASCII byte string unless it has chars > 127"
+        "If a byte char has high bit set, the remaining 14 bits come from auxilliary vector"
+    }
+    { $slide "Unicode strings"
+        "Unicode-aware case conversion, char classes, collation, word breaks, and so on..."
+        { $code "USE: unicode.case" "\"ß\" >upper ." }
+    }
+    { $slide "Unicode strings"
+        "All external byte I/O is encoded/decoded"
+        "ASCII, UTF8, UTF16, EBCDIC..."
+        { $code "USE: io.encodings.utf8" "\"document.txt\" utf8" "[ readln ] with-file-reader" }
+        { "Binary I/O is supported as well with the " { $link binary } " encoding" }
+    }
+    { $slide "Associative mappings"
+        { "Protocol: " { $link assoc-size } ", " { $link at* } ", " { $link set-at } ", " { $link delete-at } }
+        { "Combinators: " { $link assoc-each } ", " { $link assoc-map } ", " { $link assoc-filter } ", and more: " { $link "assocs-combinators" } }
+        { "Utilities: " { $link at } ", " { $link key? } ", ..." }
+    }
+    ! { $slide "Example: soundex"
+    !     { $vocab-link "soundex" }
+    !     "From Wikipedia: \"Soundex is a phonetic algorithm for indexing names by sound, as pronounced in English.\""
+    !     "Factored into many small words, uses sequence and assoc operations, no explicit loops"
+    ! }
+    { $slide "Locals and lexical scope"
+        "Sometimes, there's no good stack solution to a problem"
+        "Or, you're porting existing code in a quick-and-dirty way"
+        "Our solution: implement named locals as a DSL in Factor"
+        "Influenced by Scheme and Lisp"
+    }
+    { $slide "Locals and lexical scope"
+        { "Define lambda words with " { $link POSTPONE: :: } }
+        { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+        "Mutable bindings with correct semantics"
+        { "Named inputs for quotations with " { $link POSTPONE: [| } }
+        "Full closures"
+    }
+    { $slide "Locals and lexical scope"
+        "Two examples:"
+        { $vocab-link "lambda-quadratic" }
+        { $vocab-link "closures-example" }
+    }
+    { $slide "Locals and lexical scope"
+        "Locals are entirely implemented in Factor: 477 lines"
+        "Example of compile-time meta-programming"
+        "No performance penalty -vs- using the stack"
+        "In the base image, only 59 words out of 13,000 use locals"
+    }
+    { $slide "The parser"
+        "All data types have a literal syntax"
+        "Literal hashtables and arrays are very useful in data-driven code"
+        "\"Code is data\" because quotations are objects (enables Lisp-style macros)"
+        { $code "H{ { \"cookies\" 12 } { \"milk\" 10 } }" }
+        "Libraries can define new parsing words"
+    }
+    { $slide "The parser"
+        { "Example: URLs define a " { $link POSTPONE: URL" } " word" }
+        { $code "URL\" http://paste.factorcode.org/paste?id=81\"" }
+    }
+    { $slide "Example: memoization"
+        { "Memoization with " { $link POSTPONE: MEMO: } }
+        { $code
+            ": fib ( m -- n )"
+            "    dup 1 > ["
+            "        [ 1 - fib ] [ 2 - fib ] bi +"
+            "    ] when ;"
+        }
+        "Very slow! Let's profile it..."
+    }
+    { $slide "Example: memoization"
+        { "Let's use " { $link POSTPONE: : } " instead of " { $link POSTPONE: MEMO: } }
+        { $code
+            "MEMO: fib ( m -- n )"
+            "    dup 1 > ["
+            "        [ 1 - fib ] [ 2 - fib ] bi +"
+            "    ] when ;"
+        }
+        "Much faster"
+    }
+    { $slide "Meta-circularity"
+        { { $link POSTPONE: MEMO: } " is just a library word" }
+        { "But so is " { $link POSTPONE: : } }
+        "Factor's parser is written in Factor"
+        { "All syntax is just parsing words: " { $link POSTPONE: [ } ", " { $link POSTPONE: " } }
+    }
+    { $slide "Extensible syntax, DSLs"
+        "Most parsing words fall in one of two categories"
+        "First category: literal syntax for new data types"
+        "Second category: defining new types of words"
+        "Some parsing words are more complicated"
+    }
+    { $slide "Parser expression grammars"
+        { { $link POSTPONE: EBNF: } ": a complex parsing word" }
+        "Implements a custom syntax for expressing parsers"
+        { "Example: " { $vocab-link "printf-example" } }
+        { $code "\"vegan\" \"cheese\" \"%s is not %s\\n\" printf" }
+        { $code "5 \"Factor\" \"%s is %d years old\\n\" printf" }
+    }
+    { $slide "Input/output library"
+        "One of Factor's strongest points: portable, full-featured, efficient"
+        { $vocab-link "io.files" }
+        { $vocab-link "io.launcher" }
+        { $vocab-link "io.monitors" }
+        { $vocab-link "io.mmap" }
+        { $vocab-link "http.client" }
+        "... and so on"
+    }
+    { $slide "Example: file system monitors"
+        { $code
+            "USE: io.monitors"
+            ""
+            ": forever ( quot -- ) '[ @ t ] loop ; inline"
+            ""
+            "\"/tmp\" t <monitor>"
+            "'[ _ next-change . . ] forever"
+        }
+    }
+    { $slide "Example: time server"
+        { $vocab-link "time-server" }
+        { "Demonstrates " { $vocab-link "io.servers.connection" } " vocabulary, threads" }
+    }
+    { $slide "Example: what is my IP?"
+        { $vocab-link "webapps.ip" }
+        "Simple web app, defines a single action, use an XHTML template"
+        "Web framework supports more useful features: sessions, SSL, form validation, ..."
+    }
+    { $slide "Example: Yahoo! web search"
+        { $vocab-link "yahoo" }
+        { "Demonstrates " { $vocab-link "http.client" } ", " { $vocab-link "xml" } }
+    }
+    { $slide "Example: simple web browser"
+        { $vocab-link "webkit-demo" }
+        "Demonstrates Cocoa binding"
+        "Let's deploy a stand-alone binary with the deploy tool"
+        "Deploy tool generates binaries with no external dependencies"
+    }
+    { $slide "Example: environment variables"
+        { $vocab-link "environment" }
+        "Hooks are generic words which dispatch on dynamically-scoped variables"
+        { "Implemented in an OS-specific way: " { $vocab-link "environment.unix" } ", " { $vocab-link "environment.winnt" } }
+    }
+    { $slide "Example: environment variables"
+        "Implementations use C FFI"
+        "Call C functions, call function pointers, call Factor from C, structs, floats, ..."
+        "No need to write C wrapper code"
+    }
+    { $slide "Implementation"
+        "VM: 12,000 lines of C"
+        "Generational garbage collection"
+        "core: 9,000 lines of Factor"
+        "Optimizing native code compiler for x86, PowerPC"
+        "basis: 80,000 lines of Factor"
+    }
+    { $slide "Compiler"
+        { "Let's look at " { $vocab-link "benchmark.mandel" } }
+        "A naive implementation would be very slow"
+        "Combinators, currying, partial application"
+        "Boxed complex numbers"
+        "Boxed floats"
+        { "Redundancy in " { $link absq } " and " { $link sq } }
+    }
+    { $slide "Compiler: front-end"
+        "Builds high-level tree SSA IR"
+        "Stack code with uniquely-named values"
+        "Inlines combinators and calls to quotations"
+        { $code "USING: compiler.tree.builder compiler.tree.debugger ;" "[ c pixel ] build-tree nodes>quot ." }
+    }
+    { $slide "Compiler: high-level optimizer"
+        "12 optimization passes"
+        { $link optimize-tree }
+        "Some passes collect information, others use the results of past analysis to rewrite the code"
+    }
+    { $slide "Compiler: propagation pass"
+        "Propagation pass computes types with type function"
+        { "Example: output type of " { $link + } " depends on the types of inputs" }
+        "Type: can be a class, a numeric interval, array with a certain length, tuple with certain type slots, literal value, ..."
+        "Mandelbrot: we infer that we're working on complex floats"
+    }
+    { $slide "Compiler: propagation pass"
+        "Propagation also supports \"constraints\""
+        { $code "[ dup array? [ first ] when ] optimized." }
+        { $code "[ >fixnum dup 0 < [ 1 + ] when ] optimized." }
+        { $code
+            "["
+            "    >fixnum"
+            "    dup [ -10 > ] [ 10 < ] bi and"
+            "    [ 1 + ] when"
+            "] optimized."
+        }
+    }
+    { $slide "Compiler: propagation pass"
+        "Eliminates method dispatch, inlines method bodies"
+        "Mandelbrot: we infer that integer indices are fixnums"
+        "Mandelbrot: we eliminate generic arithmetic"
+    }
+    { $slide "Compiler: escape analysis"
+        "We identify allocations for tuples which are never returned or passed to other words (except slot access)"
+        { "Partial application with " { $link POSTPONE: '[ } }
+        "Complex numbers"
+    }
+    { $slide "Compiler: escape analysis"
+        { "Virtual sequences: " { $link <slice> } ", " { $link <reversed> } }
+        { $code "[ <reversed> [ . ] each ] optimized." }
+        { "Mandelbrot: we unbox " { $link curry } ", complex number allocations" }
+    }
+    { $slide "Compiler: dead code elimination"
+        "Cleans up the mess from previous optimizations"
+        "After inlining and dispatch elimination, dead code comes up because of unused generality"
+        { "No-ops like " { $snippet "0 +" } ", " { $snippet "1 *" } }
+        "Literals which are never used"
+        "Side-effect-free words whose outputs are dropped"
+    }
+    { $slide "Compiler: low level IR"
+        "Register-based SSA"
+        "Stack operations expand into low-level instructions"
+        { $code "[ 5 ] test-mr mr." }
+        { $code "[ swap ] test-mr mr." }
+        { $code "[ append reverse ] test-mr mr." }
+    }
+    { $slide "Compiler: low-level optimizer"
+        "5 optimization passes"
+        { $link optimize-cfg }
+        "Gets rid of redundancy which is hidden in high-level stack code"
+    }
+    { $slide "Compiler: optimize memory"
+        "First pass optimizes stack and memory operations"
+        { "Example: " { $link 2array } }
+        { { $link <array> } " fills array with initial value" }
+        "What if we immediately store new values into the array?"
+        { $code "\\ 2array test-mr mr." }
+        "Mandelbrot: we optimize stack operations"
+    }
+    { $slide "Compiler: value numbering"
+        "Identifies expressions which are computed more than once in a basic block"
+        "Simplifies expressions with various identities"
+        "Mandelbrot: redundant float boxing and unboxing, redundant arithmetic"
+    }
+    { $slide "Compiler: dead code elimination"
+        "Dead code elimination for low-level IR"
+        "Again, cleans up results of prior optimizations"
+    }
+    { $slide "Compiler: register allocation"
+        "IR assumes an infinite number of registers which are only assigned once"
+        "Real CPUs have a finite set of registers which can be assigned any number of times"
+        "\"Linear scan register allocation with second-chance binpacking\""
+    }
+    { $slide "Compiler: register allocation"
+        "3 steps:"
+        "Compute live intervals"
+        "Allocate registers"
+        "Assign registers and insert spills"
+    }
+    { $slide "Compiler: register allocation"
+        "Step 1: compute live intervals"
+        "We number all instructions consecutively"
+        "A live interval associates a virtual register with a list of usages"
+    }
+    { $slide "Compiler: register allocation"
+        "Step 2: allocate registers"
+        "We scan through sorted live intervals"
+        "If a physical register is available, assign"
+        "Otherwise, find live interval with furthest away use, split it, look at both parts again"
+    }
+    { $slide "Compiler: register allocation"
+        "Step 3: assign registers and insert spills"
+        "Simple IR rewrite step"
+        "After register allocation, one vreg may have several live intervals, and different physical registers at different points in time"
+        "Hence, \"second chance\""
+        { "Mandelbrot: " { $code "[ c pixel ] test-mr mr." } }
+    }
+    { $slide "Compiler: code generation"
+        "Iterate over list of instructions"
+        "Extract tuple slots and call hooks"
+        { $vocab-link "cpu.architecture" }
+        "Finally, we hand the code to the VM"
+        { $code "\\ 2array disassemble" }
+    }
+    { $slide "Garbage collection"
+        "All roots are identified precisely"
+        "Generational copying for data"
+        "Mark sweep for native code"
+    }
+    { $slide "Project infrastructure"
+        { $url "http://factorcode.org" }
+        { $url "http://concatenative.org" }
+        { $url "http://docs.factorcode.org" }
+        { $url "http://planet.factorcode.org" }
+        "Uses our HTTP server, SSL, DB, Atom libraries..."
+    }
+    { $slide "Project infrastructure"
+        "Build farm, written in Factor"
+        "12 platforms"
+        "Builds Factor and all libraries, runs tests, makes binaries"
+        "Saves us from the burden of making releases by hand"
+        "Maintains stability"
+    }
+    { $slide "Community"
+        "#concatenative irc.freenode.net: 50-60 members"
+        "factor-talk@lists.sf.net: 180 subscribers"
+        "About 30 people have code in the Factor repository"
+        "Easy to get started: binaries, lots of docs, friendly community..."
+    }
+    { $slide "Future direction: Factor 1.0"
+        "Continue doing what we're doing:"
+        "Polish off some language features"
+        "Stability"
+        "Performance"
+        "Documentation"
+        "Developer tools"
+    }
+    { $slide "Future direction: Factor 2.0"
+        "Native threads"
+        "Syntax-aware Factor editor"
+        "Embedding Factor in C apps"
+        "Cross-compilation for smaller devices"
+    }
+    { $slide "That's all, folks"
+        "It is hard to cover everything in a single talk"
+        "Factor has many cool things that I didn't talk about"
+        "Put your prejudices aside and give it a shot!"
+    }
+    { $slide "Questions?" }
+} ;
+
+: google-talk ( -- ) google-slides slides-window ;
+
+MAIN: google-talk
diff --git a/extra/vpri-talk/vpri-talk.factor b/extra/vpri-talk/vpri-talk.factor
new file mode 100644
index 0000000000..131b569a92
--- /dev/null
+++ b/extra/vpri-talk/vpri-talk.factor
@@ -0,0 +1,492 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slides help.markup math arrays hashtables namespaces
+sequences kernel sequences parser memoize io.encodings.binary
+locals kernel.private tools.vocabs.browser assocs quotations
+urls peg.ebnf tools.vocabs tools.annotations tools.crossref
+help.topics math.functions compiler.tree.optimizer
+compiler.cfg.optimizer fry ;
+IN: vpri-talk
+
+: vpri-slides
+{
+    { $slide "Factor!"
+        { $url "http://factorcode.org" }
+        "Development started in 2003"
+        "Open source (BSD license)"
+        "Influenced by Forth, Lisp, and Smalltalk"
+        "Blurs the line between language and library"
+        "Interactive development"
+    }
+    { $slide "Programming is hard"
+        "Let's play tetris instead"
+        { $vocab-link "tetris" }
+        "Tetris is hard too... let's cheat"
+        "Factor workflow: change code, F2, test, repeat"
+    }
+    { $slide "Basics"
+        "Stack based, dynamically typed"
+        { $code "{ 1 1 3 4 4 8 9 9 } dup duplicates diff ." }
+        "Words: named code snippets"
+        { $code ": remove-duplicates ( seq -- seq' )" "    dup duplicates diff ;" }
+        { $code "{ 1 1 3 4 4 8 9 9 } remove-duplicates ." }
+        "Vocabularies: named sets of words"
+        { $link "vocab-index" }
+    }
+    { $slide "Quotations"
+        "Quotation: unnamed block of code"
+        "Combinators: words taking quotations"
+        { $code "{ 1 1 3 4 4 8 9 9 }" "[ { 1 3 8 } member? ] filter ." }
+        { $code "{ -1 1 -2 0 3 } [ 0 max ] map" }
+        "Partial application:"
+        { $code ": clamp ( seq n -- seq' ) '[ _ max ] map" "{ -1 1 -2 0 3 } 0 clamp ;" }
+    }
+    { $slide "Object system"
+        "CLOS with single dispatch"
+        "A tuple is a user-defined class which holds named values."
+        { $code
+            "TUPLE: rectangle width height ;"
+            "TUPLE: circle radius ;"
+        }
+    }
+    { $slide "Object system"
+        "Constructing instances:"
+        { $code "rectangle new" }
+        { $code "rectangle boa" }
+        "Let's encapsulate:"
+        { $code
+            ": <rectangle> ( w h -- r ) rectangle boa ;"
+            ": <circle> ( r -- c ) circle boa ;"
+        }
+    }
+    { $slide "Object system"
+        "Generic words and methods"
+        { $code "GENERIC: area ( shape -- n )" }
+        "Two methods:"
+        { $code
+            "USE: math.constants"
+            ""
+            "M: rectangle area"
+            "    [ width>> ] [ height>> ] bi * ;"
+            ""
+            "M: circle area radius>> sq pi * ;"
+        }
+    }
+    { $slide "Object system"
+        "We can compute areas now."
+        { $code "100 20 <rectangle> area ." }
+        { $code "3 <circle> area ." }
+    }
+    { $slide "Object system"
+        "New operation, existing types:"
+        { $code
+            "GENERIC: perimiter ( shape -- n )"
+            ""
+            "M: rectangle perimiter"
+            "    [ width>> ] [ height>> ] bi + 2 * ;"
+            ""
+            "M: circle perimiter"
+            "    radius>> 2 * pi * ;"
+        }
+    }
+    { $slide "Object system"
+        "We can compute perimiters now."
+        { $code "100 20 <rectangle> perimiter ." }
+        { $code "3 <circle> perimiter ." }
+    }
+    { $slide "Object system"
+        "New type, extending existing operations:"
+        { $code
+            "TUPLE: triangle base height ;"
+            ""
+            ": <triangle> ( b h -- t ) triangle boa ;"
+            ""
+            "M: triangle area"
+            "    [ base>> ] [ height>> ] bi * 2 / ;"
+        }
+    }
+    { $slide "Object system"
+        "New type, extending existing operations:"
+        { $code
+            ": hypotenuse ( x y -- z ) [ sq ] bi@ + sqrt ;"
+            ""
+            "M: triangle perimiter"
+            "    [ base>> ] [ height>> ] bi"
+            "    [ + ] [ hypotenuse ] 2bi + ;"
+        }
+    }
+    { $slide "Object system"
+        "Object system handles dynamic redefinition very well"
+        { $code "TUPLE: person name age occupation ;" }
+        "Make an instance..."
+    }
+    { $slide "Object system"
+        "Let's add a new slot:"
+        { $code "TUPLE: person name age address occupation ;" }
+        "Fill it in with inspector..."
+        "Change the order:"
+        { $code "TUPLE: person name occupation address ;" }
+    }
+    { $slide "Object system"
+        "How does it work?"
+        "Objects are not hashtables; slot access is very fast"
+        "Redefinition walks the heap; expensive but rare"
+    }
+    { $slide "Object system"
+        "Supports \"duck typing\""
+        "Two tuples can have a slot with the same name"
+        "Code that uses accessors will work on both"
+        "Accessors are auto-generated generic words"
+    }
+    { $slide "Object system"
+        "More: inheritance, type declarations, read-only slots, predicate, intersection, singleton classes, reflection"
+        "Object system is entirely implemented in Factor"
+        { { $vocab-link "generic" } ", " { $vocab-link "classes" } ", " { $vocab-link "slots" } }
+    }
+    { $slide "The parser"
+        "All data types have a literal syntax"
+        "Literal hashtables and arrays are very useful in data-driven code"
+        "\"Code is data\" because quotations are objects (enables Lisp-style macros)"
+        { $code "H{ { \"cookies\" 12 } { \"milk\" 10 } }" }
+        "Libraries can define new parsing words"
+    }
+    { $slide "Example: float arrays"
+        { $vocab-link "float-arrays" }
+        "Avoids boxing and unboxing overhead"
+        "Implemented with library code"
+        { $code "F{ 3.14 7.6 10.3 }" }
+    }
+    { $slide "Example: memoization"
+        { "Memoization with " { $link POSTPONE: MEMO: } }
+        { $code
+            ": fib ( m -- n )"
+            "    dup 1 > ["
+            "        [ 1 - fib ] [ 2 - fib ] bi +"
+            "    ] when ;"
+        }
+        "Very slow! Let's profile it..."
+    }
+    { $slide "Example: memoization"
+        { "Let's use " { $link POSTPONE: : } " instead of " { $link POSTPONE: MEMO: } }
+        { $code
+            "MEMO: fib ( m -- n )"
+            "    dup 1 > ["
+            "        [ 1 - fib ] [ 2 - fib ] bi +"
+            "    ] when ;"
+        }
+        "Much faster"
+    }
+    { $slide "Meta-circularity"
+        { { $link POSTPONE: MEMO: } " is just a library word" }
+        { "But so is " { $link POSTPONE: : } }
+        "Factor's parser is written in Factor"
+        { "All syntax is just parsing words: " { $link POSTPONE: [ } ", " { $link POSTPONE: " } }
+    }
+    { $slide "Extensible syntax, DSLs"
+        "Most parsing words fall in one of two categories"
+        "First category: literal syntax for new data types"
+        "Second category: defining new types of words"
+        "Some parsing words are more complicated"
+    }
+    { $slide "Example: printf"
+        { { $link POSTPONE: EBNF: } ": a complex parsing word" }
+        "Implements a custom syntax for expressing parsers: like OMeta!"
+        { "Example: " { $vocab-link "printf-example" } }
+        { $code "\"vegan\" \"cheese\" \"%s is not %s\\n\" printf" }
+        { $code "5 \"Factor\" \"%s is %d years old\\n\" printf" }
+    }
+    { $slide "Example: simple web browser"
+        { $vocab-link "webkit-demo" }
+        "Demonstrates Cocoa binding"
+        "Let's deploy a stand-alone binary with the deploy tool"
+        "Deploy tool generates binaries with no external dependencies"
+    }
+    { $slide "Locals and lexical scope"
+        "Sometimes, there's no good stack solution to a problem"
+        "Or, you're porting existing code in a quick-and-dirty way"
+        "Our solution: implement named locals as a DSL in Factor"
+        "Influenced by Scheme and Lisp"
+    }
+    { $slide "Locals and lexical scope"
+        { "Define lambda words with " { $link POSTPONE: :: } }
+        { "Establish bindings with " { $link POSTPONE: [let } " and " { $link POSTPONE: [let* } }
+        "Mutable bindings with correct semantics"
+        { "Named inputs for quotations with " { $link POSTPONE: [| } }
+        "Full closures"
+    }
+    { $slide "Locals and lexical scope"
+        "Combinator with 5 parameters!"
+        { $code
+            ":: branch ( a b neg zero pos -- )"
+            "    a b = zero [ a b < neg pos if ] if ; inline"
+        }
+        "Unwieldy with the stack"
+    }
+    { $slide "Locals and lexical scope"
+        { $code
+            "ERROR: underage-exception ;"
+            ""
+            ": check-drinking-age ( age -- )"
+            "    21"
+            "    [ underage-exception ]"
+            "    [ \"Grats, you're now legal\" print ]"
+            "    [ \"Go get hammered\" print ]"
+            "    branch ;"
+        }
+    }
+    { $slide "Locals and lexical scope"
+        "Locals are entirely implemented in Factor"
+        "Example of compile-time meta-programming"
+        "No performance penalty -vs- using the stack"
+        "In the base image, only 59 words out of 13,000 use locals"
+    }
+    { $slide "More about partial application"
+        { { $link POSTPONE: '[ } " is \"fry syntax\"" }
+        { $code "'[ _ + ] == [ + ] curry" }
+        { $code "'[ @ t ] == [ t ] compose" }
+        { $code "'[ _ nth @ ] == [ [ nth ] curry ] dip compose" }
+        { $code "'[ [ _ ] dip nth ] == [ [ ] curry dip nth ] curry" }
+        { "Fry and locals desugar to " { $link curry } ", " { $link compose } }
+    }
+    { $slide "More about partial application"
+        { { $link call } " is fundamental" }
+        { { $link quotation } ", " { $link curry } " and " { $link compose } " are classes" }
+        { $code
+            "GENERIC: call ( quot -- )"
+            "M: curry call uncurry call ;"
+            "M: compose call uncompose slip call ;"
+            "M: quotation call (call) ;"
+        }
+        { "So " { $link curry } ", " { $link compose } " are library features" }
+    }
+    { $slide "Why stack-based?"
+        "Because nobody else is doing it"
+        "Interesting properties: concatenation is composition, chaining functions together, \"fluent\" interfaces, new combinators"
+        { $vocab-link "smtp-example" }
+        { $code
+            "{ \"chicken\" \"beef\" \"pork\" \"turkey\" }"
+            "[ 5 short head ] map ."
+        }
+        "To rattle people's cages"
+    }
+    { $slide "Help system"
+        "Help markup is just literal data"
+        { "Look at the help for " { $link T{ link f + } } }
+        "These slides are built with the help system and a custom style sheet"
+        { $vocab-link "vpri-talk" }
+    }
+    { $slide "Some line counts"
+        "VM: 12,000 lines of C"
+        "core: 9,000 lines of Factor"
+        "basis: 80,000 lines of Factor"
+    }
+    { $slide "More line counts"
+        "Object system (core): 2184 lines"
+        "Dynamic variables (core): 40 lines"
+        "Deterministic scoped destructors (core): 56 lines"
+        "Optimizing compiler (basis): 12938 lines"
+        "Lexical variables and closures (basis): 477 lines"
+        "Fry (basis): 51 lines"
+        "Help system (basis): 1831 lines"
+    }
+    { $slide "Implementation"
+        "VM: garbage collection, bignums, ..."
+        "Bootstrap image: parser, hashtables, object system, ..."
+        "Non-optimizing compiler"
+        "Stage 2 bootstrap: optimizing compiler, UI, ..."
+        "Full image contains machine code"
+    }
+    { $slide "Compiler"
+        { "Let's look at " { $vocab-link "benchmark.mandel" } }
+        "A naive implementation would be very slow"
+        "Combinators, currying, partial application"
+        "Boxed complex numbers"
+        "Boxed floats"
+        { "Redundancy in " { $link absq } " and " { $link sq } }
+    }
+    { $slide "Compiler: front-end"
+        "Builds high-level tree SSA IR"
+        "Stack code with uniquely-named values"
+        "Inlines combinators and calls to quotations"
+        { $code "USING: compiler.tree.builder compiler.tree.debugger ;" "[ c pixel ] build-tree nodes>quot ." }
+    }
+    { $slide "Compiler: high-level optimizer"
+        "12 optimization passes"
+        { $link optimize-tree }
+        "Some passes collect information, others use the results of past analysis to rewrite the code"
+    }
+    { $slide "Compiler: propagation pass"
+        "Propagation pass computes types with type function"
+        { "Example: output type of " { $link + } " depends on the types of inputs" }
+        "Type: can be a class, a numeric interval, array with a certain length, tuple with certain type slots, literal value, ..."
+        "Mandelbrot: we infer that we're working on complex floats"
+    }
+    { $slide "Compiler: propagation pass"
+        "Propagation also supports \"constraints\""
+        { $code "[ dup array? [ first ] when ] optimized." }
+        { $code "[ >fixnum dup 0 < [ 1 + ] when ] optimized." }
+        { $code
+            "["
+            "    >fixnum"
+            "    dup [ -10 > ] [ 10 < ] bi and"
+            "    [ 1 + ] when"
+            "] optimized."
+        }
+    }
+    { $slide "Compiler: propagation pass"
+        "Eliminates method dispatch, inlines method bodies"
+        "Mandelbrot: we infer that integer indices are fixnums"
+        "Mandelbrot: we eliminate generic arithmetic"
+    }
+    { $slide "Compiler: escape analysis"
+        "We identify allocations for tuples which are never returned or passed to other words (except slot access)"
+        { "Partial application with " { $link curry } " and " { $link compose } }
+        "Complex numbers"
+    }
+    { $slide "Compiler: escape analysis"
+        { "Virtual sequences: " { $link <slice> } ", " { $link <reversed> } }
+        { $code "[ <reversed> [ . ] each ] optimized." }
+        { "Mandelbrot: we unbox " { $link curry } ", complex number allocations" }
+    }
+    { $slide "Compiler: dead code elimination"
+        "Cleans up the mess from previous optimizations"
+        "After inlining and dispatch elimination, dead code comes up because of unused generality"
+        { "No-ops like " { $snippet "0 +" } ", " { $snippet "1 *" } }
+        "Literals which are never used"
+        "Side-effect-free words whose outputs are dropped"
+        { $code "[ c pixel ] optimized." }
+    }
+    { $slide "Compiler: low level IR"
+        "Register-based SSA"
+        "Stack operations expand into low-level instructions"
+        { $code "[ 5 ] test-mr mr." }
+        { $code "[ swap ] test-mr mr." }
+        { $code "[ append reverse ] test-mr mr." }
+    }
+    { $slide "Compiler: low-level optimizer"
+        "5 optimization passes"
+        { $link optimize-cfg }
+        "Gets rid of redundancy which is hidden in high-level stack code"
+    }
+    { $slide "Compiler: optimize memory"
+        "First pass optimizes stack and memory operations"
+        { "Example: " { $link 2array } }
+        { { $link <array> } " fills array with initial value" }
+        "What if we immediately store new values into the array?"
+        { $code "\\ 2array test-mr mr." }
+        "Mandelbrot: we optimize stack operations"
+    }
+    { $slide "Compiler: value numbering"
+        "Identifies expressions which are computed more than once in a basic block"
+        "Simplifies expressions with various identities"
+        "Mandelbrot: redundant float boxing and unboxing, redundant arithmetic"
+    }
+    { $slide "Compiler: dead code elimination"
+        "Dead code elimination for low-level IR"
+        "Again, cleans up results of prior optimizations"
+    }
+    { $slide "Compiler: register allocation"
+        "IR assumes an infinite number of registers which are only assigned once"
+        "Real CPUs have a finite set of registers which can be assigned any number of times"
+        "\"Linear scan register allocation with second-chance binpacking\""
+    }
+    { $slide "Compiler: register allocation"
+        "3 steps:"
+        "Compute live intervals"
+        "Allocate registers"
+        "Assign registers and insert spills"
+    }
+    { $slide "Compiler: register allocation"
+        "Step 1: compute live intervals"
+        "We number all instructions consecutively"
+        "A live interval associates a virtual register with a list of usages"
+    }
+    { $slide "Compiler: register allocation"
+        "Step 2: allocate registers"
+        "We scan through sorted live intervals"
+        "If a physical register is available, assign"
+        "Otherwise, find live interval with furthest away use, split it, look at both parts again"
+    }
+    { $slide "Compiler: register allocation"
+        "Step 3: assign registers and insert spills"
+        "Simple IR rewrite step"
+        "After register allocation, one vreg may have several live intervals, and different physical registers at different points in time"
+        "Hence, \"second chance\""
+        { "Mandelbrot: " { $code "[ c pixel ] test-mr mr." } }
+    }
+    { $slide "Compiler: code generation"
+        "Iterate over list of instructions"
+        "Extract tuple slots and call hooks"
+        { $vocab-link "cpu.architecture" }
+        "Finally, we hand the code to the VM"
+        { $code "\\ 2array disassemble" }
+    }
+    { $slide "Garbage collection"
+        "All roots are identified precisely"
+        "Generational copying for data"
+        "Mark sweep for native code"
+    }
+    { $slide "History"
+        "Started in 2003, implemented in Java"
+        "Scripting language for a 2D shooter game"
+        "Interactive development is addictive"
+        "I wanted to write entire applications in Factor"
+        "Added JVM bytecode compiler pretty early on"
+    }
+    { $slide "History"
+        "Wrote native C implementation, mid-2004"
+        "Added native compiler at some point"
+        "Added an FFI, SDL bindings, then UI"
+        "Switched UI to OpenGL and native APIs"
+        "Generational GC"
+        "Got rid of interpreter"
+    }
+    { $slide "Project infrastructure"
+        { $url "http://factorcode.org" }
+        { $url "http://concatenative.org" }
+        { $url "http://docs.factorcode.org" }
+        { $url "http://planet.factorcode.org" }
+        "Uses our HTTP server, SSL, DB, Atom libraries..."
+    }
+    { $slide "Project infrastructure"
+        "Build farm, written in Factor"
+        "12 platforms"
+        "Builds Factor and all libraries, runs tests, makes binaries"
+        "Saves us from the burden of making releases by hand"
+        "Maintains stability"
+    }
+    { $slide "Community"
+        "#concatenative irc.freenode.net: 50-60 members"
+        "factor-talk@lists.sf.net: 180 subscribers"
+        "About 30 people have code in the Factor repository"
+        "Easy to get started: binaries, lots of docs, friendly community..."
+    }
+    { $slide "Future direction: Factor 1.0"
+        "Continue doing what we're doing:"
+        "Polish off some language features"
+        "Stability"
+        "Performance"
+        "Documentation"
+        "Developer tools"
+    }
+    { $slide "Future direction: Factor 2.0"
+        "Native threads"
+        "Syntax-aware Factor editor"
+        "Embedding Factor in C apps"
+        "Cross-compilation for smaller devices"
+    }
+    { $slide "Research areas"
+        "Identify areas where stack languages are lacking, and try to find idioms, abstractions or DSLs to solve these problems"
+        "Factor is a good platform for DSLs (fry, locals, EBNF, help, ...); what about implementing a complete language on top?"
+        "Static typing, soft typing, for stack-based languages"
+    }
+    { $slide "That's all, folks"
+        "It is hard to cover everything in a single talk"
+        "Factor has many cool things that I didn't talk about"
+        "Questions?"
+    }
+} ;
+
+: vpri-talk ( -- ) vpri-slides slides-window ;
+
+MAIN: vpri-talk

From 0ae87275f761daad4431b28da8054cf9fb253107 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 31 Oct 2008 21:07:18 -0500
Subject: [PATCH 078/318] Add WebKit demo

---
 extra/webkit-demo/deploy.factor      | 15 ++++++++++++
 extra/webkit-demo/webkit-demo.factor | 35 ++++++++++++++++++++++++++++
 2 files changed, 50 insertions(+)
 create mode 100644 extra/webkit-demo/deploy.factor
 create mode 100644 extra/webkit-demo/webkit-demo.factor

diff --git a/extra/webkit-demo/deploy.factor b/extra/webkit-demo/deploy.factor
new file mode 100644
index 0000000000..684bbc57b5
--- /dev/null
+++ b/extra/webkit-demo/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-ui? f }
+    { deploy-compiler? t }
+    { deploy-c-types? f }
+    { deploy-reflection 1 }
+    { deploy-random? f }
+    { deploy-name "WebKit demo" }
+    { deploy-io 1 }
+    { deploy-math? f }
+    { deploy-word-props? f }
+    { "stop-after-last-window?" t }
+    { deploy-word-defs? f }
+    { deploy-threads? f }
+}
diff --git a/extra/webkit-demo/webkit-demo.factor b/extra/webkit-demo/webkit-demo.factor
new file mode 100644
index 0000000000..83f06ec137
--- /dev/null
+++ b/extra/webkit-demo/webkit-demo.factor
@@ -0,0 +1,35 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel
+cocoa
+cocoa.application
+cocoa.types
+cocoa.classes
+cocoa.windows ;
+IN: webkit-demo
+
+FRAMEWORK: /System/Library/Frameworks/WebKit.framework
+IMPORT: WebView
+
+: rect ( -- rect ) 0 0 700 500 <NSRect> ;
+
+: <WebView> ( -- id )
+    WebView -> alloc
+    rect f f -> initWithFrame:frameName:groupName: ;
+
+: <WebWindow> ( -- id )
+    <WebView> rect <ViewWindow> ;
+
+: load-url ( window url -- )
+    [ -> contentView ] [ <NSString> ] bi* -> setMainFrameURL: ;
+
+: webkit-demo ( -- )
+    <WebWindow>
+    [ -> center ]
+    [ f -> makeKeyAndOrderFront: ]
+    [ "http://factorcode.org" load-url ] tri ;
+
+: run-webkit-demo ( -- )
+    [ webkit-demo ] cocoa-app ;
+
+MAIN: run-webkit-demo

From 804c6f93ea6c59de423ae51688087c5bccf054ac Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 31 Oct 2008 21:07:41 -0500
Subject: [PATCH 079/318] Fix x86.32

---
 basis/compiler/cfg/builder/builder.factor        | 2 +-
 basis/compiler/cfg/intrinsics/slots/slots.factor | 4 ++--
 basis/cpu/x86/32/32.factor                       | 8 +++++---
 vm/cpu-x86.32.S                                  | 4 ++--
 4 files changed, 10 insertions(+), 8 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index e46233add2..f680d3a504 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -1,4 +1,4 @@
- ! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators hashtables kernel
 math fry namespaces make sequences words byte-arrays
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index 3fea26c1af..cbc5d04c0b 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -12,12 +12,12 @@ IN: compiler.cfg.intrinsics.slots
 : value-tag ( info -- n ) class>> class-tag ; inline
 
 : (emit-slot) ( infos -- dst )
-    [ 2inputs ] [ first value-tag ] bi*
+    [ 2inputs ^^offset>slot ] [ first value-tag ] bi*
     ^^slot ;
 
 : (emit-slot-imm) ( infos -- dst )
     ds-drop
-    [ ds-pop ^^offset>slot ]
+    [ ds-pop ]
     [ [ second literal>> ] [ first value-tag ] bi ] bi*
     ^^slot-imm ;
 
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 1c597ac98a..0e4107eaee 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -74,7 +74,7 @@ M: float-regs store-return-reg
     [ [ align-sub ] [ call ] bi* ]
     [ [ align-add ] [ drop ] bi* ] 2bi ; inline
 
-M: x86.64 rel-literal-x86 rc-absolute-cell rel-literal ;
+M: x86.32 rel-literal-x86 rc-absolute-cell rel-literal ;
 
 M: x86.32 %prologue ( n -- )
     dup PUSH
@@ -281,10 +281,12 @@ os windows? [
 FUNCTION: bool check_sse2 ( ) ;
 
 : sse2? ( -- ? )
-    [ optimized-recompile-hook ] recompile-hook
-    [ [ check_sse2 ] compile-call ] with-variable ;
+    check_sse2 ;
 
 "-no-sse2" cli-args member? [
+    [ optimized-recompile-hook ] recompile-hook
+    [ { check_sse2 } compile ] with-variable
+
     "Checking if your CPU supports SSE2..." print flush
     sse2? [
         " - yes" print
diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S
index 1613579244..9e73bd6777 100644
--- a/vm/cpu-x86.32.S
+++ b/vm/cpu-x86.32.S
@@ -40,9 +40,9 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
 	ret                                /* return _with new stack_ */
 
 /* cpu.x86.32 calls this */
-DEF(bool,check_sse2,())
+DEF(bool,check_sse2,()):
 	push %ebx
-	mov 1,%eax
+	mov $1,%eax
 	cpuid
 	shr $26,%edx
 	and $1,%edx

From 7fc44aa44489e4cf31bda67c93c67de1eacd24e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 31 Oct 2008 21:07:57 -0500
Subject: [PATCH 080/318] Add failing tests

---
 core/classes/predicate/predicate-tests.factor | 14 ++++++++++++++
 1 file changed, 14 insertions(+)
 create mode 100644 core/classes/predicate/predicate-tests.factor

diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor
new file mode 100644
index 0000000000..9f3b3e2141
--- /dev/null
+++ b/core/classes/predicate/predicate-tests.factor
@@ -0,0 +1,14 @@
+USING: math tools.test ;
+IN: classes.predicate
+
+PREDICATE: negative < integer 0 < ;
+PREDICATE: positive < integer 0 > ;
+
+GENERIC: abs ( n -- n )
+M: integer abs ;
+M: negative abs -1 * ;
+M: positive abs ;
+
+[ 10 ] [ -10 abs ] unit-test
+[ 10 ] [ 10 abs ] unit-test
+[ 0 ] [ 0 abs ] unit-test

From 8a494a0da41516a6855ee79dc7541f8f8f87490e Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Sat, 1 Nov 2008 15:24:05 -0500
Subject: [PATCH 081/318] fix the way postgresql creates functions

---
 basis/db/postgresql/postgresql.factor | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor
index 2b4cadf489..57a16fc8ef 100644
--- a/basis/db/postgresql/postgresql.factor
+++ b/basis/db/postgresql/postgresql.factor
@@ -140,7 +140,7 @@ M: postgresql-db bind# ( spec object -- )
 
 : create-function-sql ( class -- statement )
     [
-        [ remove-id ] dip
+        [ dup remove-id ] dip
         "create function add_" 0% dup 0%
         "(" 0%
         over [ "," 0% ]
@@ -157,7 +157,9 @@ M: postgresql-db bind# ( spec object -- )
         ") values(" 0%
         swap [ ", " 0% ] [ drop bind-name% ] interleave
         "); " 0%
-        "select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
+        "select currval(''" 0% 0% "_" 0%
+        find-primary-key first column-name>> 0%
+        "_seq'');' language sql;" 0%
     ] query-make ;
 
 M: postgresql-db create-sql-statement ( class -- seq )

From c417f829bdf1869d035b2e0e66e5019cff8c2a45 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Sat, 1 Nov 2008 15:48:35 -0500
Subject: [PATCH 082/318] fix potential garbled output

---
 extra/cap/cap.factor | 11 +++++------
 1 file changed, 5 insertions(+), 6 deletions(-)

diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor
index 5f3ee7b960..ea5462acf2 100644
--- a/extra/cap/cap.factor
+++ b/extra/cap/cap.factor
@@ -1,6 +1,8 @@
+! Copyright (C) 2008 Doug Coleman, Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays byte-arrays kernel math namespaces
 opengl.gl sequences math.vectors ui graphics.bitmap graphics.viewer
-models opengl.framebuffers ui.gadgets.worlds ui.gadgets fry ;
+models opengl.framebuffers ui.gadgets.worlds ui.gadgets fry alien.syntax ;
 IN: cap
 
 : screenshot-array ( world -- byte-array )
@@ -9,7 +11,7 @@ IN: cap
 : gl-screenshot ( gadget -- byte-array )
     [
         GL_BACK glReadBuffer
-        GL_PACK_ALIGNMENT 1 glPixelStorei
+        GL_PACK_ALIGNMENT 4 glPixelStorei
         0 0
     ] dip
     [ dim>> first2 GL_BGR GL_UNSIGNED_BYTE ]
@@ -25,7 +27,4 @@ IN: cap
     [ screenshot ] dip save-bitmap ;
 
 : screenshot. ( window -- )
-    [ screenshot <graphics-gadget> ] [ title>> ] bi open-window ;
-
-
-
+    [ screenshot <graphics-gadget> ] [ title>> ] bi open-window ; 

From 1f16c5cb9e50ee809b0f6260dff72e9e8f1a9b7b Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Sat, 1 Nov 2008 18:56:02 -0500
Subject: [PATCH 083/318] Fix some deploy descriptors

---
 extra/hello-ui/deploy.factor | 14 +++++++-------
 extra/maze/deploy.factor     | 16 ++++++++--------
 2 files changed, 15 insertions(+), 15 deletions(-)

diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor
index 31f1181be2..b21fd77967 100755
--- a/extra/hello-ui/deploy.factor
+++ b/extra/hello-ui/deploy.factor
@@ -1,15 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-word-defs? f }
-    { deploy-random? f }
-    { deploy-name "Hello world" }
     { deploy-threads? t }
-    { deploy-compiler? t }
     { deploy-math? t }
+    { deploy-name "Hello world" }
     { deploy-c-types? f }
-    { deploy-io 1 }
-    { deploy-reflection 1 }
+    { deploy-word-props? f }
+    { deploy-io 2 }
     { deploy-ui? t }
     { "stop-after-last-window?" t }
-    { deploy-word-props? f }
+    { deploy-random? f }
+    { deploy-word-defs? f }
+    { deploy-compiler? t }
+    { deploy-reflection 1 }
 }
diff --git a/extra/maze/deploy.factor b/extra/maze/deploy.factor
index 0ba6f9abec..c00d32f676 100755
--- a/extra/maze/deploy.factor
+++ b/extra/maze/deploy.factor
@@ -1,15 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-reflection 1 }
-    { deploy-math? t }
-    { deploy-ui? t }
-    { deploy-name "Maze" }
-    { deploy-compiler? t }
     { deploy-threads? t }
-    { deploy-word-defs? f }
+    { deploy-math? t }
+    { deploy-name "Maze" }
     { deploy-c-types? f }
-    { deploy-io 1 }
+    { deploy-word-props? f }
+    { deploy-io 2 }
+    { deploy-ui? t }
     { "stop-after-last-window?" t }
     { deploy-random? t }
-    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { deploy-compiler? t }
+    { deploy-reflection 1 }
 }

From 1cd28740726bbad8eb31cabc22c64a1b2988919d Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Sat, 1 Nov 2008 18:56:12 -0500
Subject: [PATCH 084/318] Uncomment a test

---
 basis/tools/deploy/deploy-tests.factor | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor
index 71e83ea29c..226cf654b1 100644
--- a/basis/tools/deploy/deploy-tests.factor
+++ b/basis/tools/deploy/deploy-tests.factor
@@ -36,9 +36,9 @@ urls math.parser ;
 
 [ t ] [ 1200000 small-enough? ] unit-test
 
-! [ ] [ "tetris" shake-and-bake ] unit-test
-! 
-! [ t ] [ 1500000 small-enough? ] unit-test
+[ ] [ "tetris" shake-and-bake ] unit-test
+
+[ t ] [ 1500000 small-enough? ] unit-test
 
 [ ] [ "bunny" shake-and-bake ] unit-test
 

From 9c5bd1e96d9abf314af7d654dd85e89d144f9aa4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Sat, 1 Nov 2008 19:39:49 -0500
Subject: [PATCH 085/318] remove debug from regexp

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

diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor
index f5a235fa7f..346d77e918 100644
--- a/basis/regexp/traversal/traversal.factor
+++ b/basis/regexp/traversal/traversal.factor
@@ -102,7 +102,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
     [ [ first2 1+ 2array ] map ] change-capture-counters
     ! dup current-state>> .
     dup [ current-state>> ] [ traversal-flags>> ] bi
-    at [ dup . flag-action ] with each ;
+    at [ flag-action ] with each ;
 
 : increment-state ( dfa-traverser state -- dfa-traverser )
     [

From 8df1aba71d781dc25552780244e33e2e1c24063d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 Nov 2008 01:49:57 -0600
Subject: [PATCH 086/318] Coalescing

---
 basis/compiler/cfg/debugger/debugger.factor   |  3 +-
 .../linear-scan/allocation/allocation.factor  | 26 ++++++++--
 .../cfg/linear-scan/linear-scan-tests.factor  | 52 +++++++++++++++++++
 .../live-intervals/live-intervals.factor      | 16 +++++-
 4 files changed, 91 insertions(+), 6 deletions(-)

diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 47935c193c..7b1b9100c4 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -5,7 +5,7 @@ classes.tuple accessors prettyprint prettyprint.config
 compiler.tree.builder compiler.tree.optimizer
 compiler.cfg.builder compiler.cfg.linearization
 compiler.cfg.stack-frame compiler.cfg.linear-scan
-compiler.cfg.optimizer ;
+compiler.cfg.two-operand compiler.cfg.optimizer ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -22,6 +22,7 @@ SYMBOL: allocate-registers?
     test-cfg [
         optimize-cfg
         build-mr
+        convert-two-operand
         allocate-registers? get
         [ linear-scan build-stack-frame ] when
     ] map ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 9402e4d841..7944415cbc 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -56,6 +56,20 @@ SYMBOL: progress
     [ [ start>> ] keep ] { } map>assoc
     unhandled-intervals get heap-push-all ;
 
+! Coalescing
+: active-interval ( vreg -- live-interval )
+    dup active-intervals-for [ vreg>> = ] with find nip ;
+
+: coalesce? ( live-interval -- ? )
+    [ start>> ] [ copy-from>> ] bi
+    dup [ active-interval end>> = ] [ 2drop f ] if ;
+
+: coalesce ( live-interval -- )
+    dup copy-from>> active-interval
+    [ [ add-active ] [ delete-active ] bi* ]
+    [ reg>> >>reg drop ]
+    2bi ;
+
 ! Splitting
 : find-use ( live-interval n quot -- i elt )
     [ uses>> ] 2dip curry find ; inline
@@ -67,7 +81,7 @@ SYMBOL: progress
 : split-after ( live-interval i -- after )
     [ clone dup uses>> ] dip
     [ tail >>uses ] [ swap nth >>start ] 2bi
-    f >>reg ;
+    f >>reg f >>copy-from ;
 
 : split-interval ( live-interval n -- before after )
     [ drop ] [ [ > ] find-use drop ] 2bi
@@ -128,8 +142,14 @@ SYMBOL: spill-counts
     pop >>reg add-active ;
 
 : assign-register ( new -- )
-    dup vreg>> free-registers-for
-    [ assign-blocked-register ] [ assign-free-register ] if-empty ;
+    dup coalesce? [
+        coalesce
+    ] [
+        dup vreg>> free-registers-for
+        [ assign-blocked-register ]
+        [ assign-free-register ]
+        if-empty
+    ] if ;
 
 ! Main loop
 : reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 1eea66f523..aa899208c0 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -303,3 +303,55 @@ USING: math.private compiler.cfg.debugger ;
     allocate-registers
     first split-before>> [ start>> ] [ end>> ] bi
 ] unit-test
+
+! Coalescing interacted badly with splitting
+[ ] [
+    {
+        T{ live-interval
+            { vreg V int-regs 70 }
+            { start 14 }
+            { end 17 }
+            { uses V{ 14 15 16 17 } }
+            { copy-from V int-regs 67 }
+        }
+        T{ live-interval
+            { vreg V int-regs 67 }
+            { start 13 }
+            { end 14 }
+            { uses V{ 13 14 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 30 }
+            { start 4 }
+            { end 18 }
+            { uses V{ 4 12 16 17 18 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 27 }
+            { start 3 }
+            { end 13 }
+            { uses V{ 3 7 13 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 59 }
+            { start 10 }
+            { end 18 }
+            { uses V{ 10 11 12 18 } }
+            { copy-from V int-regs 56 }
+        }
+        T{ live-interval
+            { vreg V int-regs 60 }
+            { start 12 }
+            { end 17 }
+            { uses V{ 12 17 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 56 }
+            { start 9 }
+            { end 10 }
+            { uses V{ 9 10 } }
+        }
+    }
+    { { int-regs { 0 1 2 3 } } }
+    allocate-registers
+] 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 5ac733114b..73fe904485 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -8,7 +8,8 @@ IN: compiler.cfg.linear-scan.live-intervals
 TUPLE: live-interval
 vreg
 reg spill-to reload-from split-before split-after
-start end uses ;
+start end uses
+copy-from ;
 
 : add-use ( n live-interval -- )
     dup live-interval? [ "No def" throw ] unless
@@ -37,12 +38,23 @@ SYMBOL: live-intervals
         [ [ <live-interval> ] keep ] dip set-at
     ] if ;
 
-: compute-live-intervals* ( insn n -- )
+GENERIC# compute-live-intervals* 1 ( insn n -- )
+
+M: insn compute-live-intervals*
     live-intervals get
     [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
     [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
     3bi ;
 
+: record-copy ( insn -- )
+    [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
+
+M: ##copy compute-live-intervals*
+    [ call-next-method ] [ drop record-copy ] 2bi ;
+
+M: ##copy-float compute-live-intervals*
+    [ call-next-method ] [ drop record-copy ] 2bi ;
+
 : compute-live-intervals ( instructions -- live-intervals )
     H{ } clone [
         live-intervals set

From 3834eaeb055a669ee79bde809628b762498114f7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 Nov 2008 01:50:48 -0600
Subject: [PATCH 087/318] Don't generate GC checks if the allocation
 instruction is optimized out

---
 basis/compiler/cfg/cfg.factor                      |  3 +--
 basis/compiler/cfg/intrinsics/allot/allot.factor   |  6 +-----
 basis/compiler/cfg/intrinsics/fixnum/fixnum.factor |  2 +-
 basis/compiler/cfg/intrinsics/float/float.factor   |  6 ++----
 .../cfg/linearization/linearization.factor         | 14 ++++++++++++--
 basis/compiler/cfg/utilities/utilities.factor      |  2 --
 6 files changed, 17 insertions(+), 16 deletions(-)

diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 9e9c26b0f8..9d5712ebcd 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -11,8 +11,7 @@ TUPLE: basic-block < identity-tuple
 id
 number
 instructions
-successors
-gc ;
+successors ;
 
 : <basic-block> ( -- basic-block )
     basic-block new
diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor
index a42542cb70..f0796c59f0 100644
--- a/basis/compiler/cfg/intrinsics/allot/allot.factor
+++ b/basis/compiler/cfg/intrinsics/allot/allot.factor
@@ -13,8 +13,7 @@ IN: compiler.cfg.intrinsics.allot
 : emit-simple-allot ( node -- )
     [ in-d>> length ] [ node-output-infos first class>> ] bi
     [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
-    [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi
-    need-gc ;
+    [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
 
 : tuple-slot-regs ( layout -- vregs )
     [ size>> ds-load ] [ ^^load-literal ] bi prefix ;
@@ -26,7 +25,6 @@ IN: compiler.cfg.intrinsics.allot
         ds-drop
         [ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
         [ tuple ##set-slots ] [ ds-push drop ] 2bi
-        need-gc
     ] [ drop emit-primitive ] if ;
 
 : store-length ( len reg -- )
@@ -47,7 +45,6 @@ IN: compiler.cfg.intrinsics.allot
                 len reg store-length
                 elt reg len store-initial-element
                 reg ds-push
-                need-gc
             ]
         ] [ node emit-primitive ] if
     ] ;
@@ -66,7 +63,6 @@ IN: compiler.cfg.intrinsics.allot
                 len reg store-length
                 elt reg len bytes>cells store-initial-element
                 reg ds-push
-                need-gc
             ]
         ] [ node emit-primitive ] if
     ] ;
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index e47b12009d..12a3ef8597 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -60,4 +60,4 @@ IN: compiler.cfg.intrinsics.fixnum
     ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>bignum ( -- )
-    ds-pop ^^untag-fixnum ^^integer>bignum ds-push need-gc ;
+    ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor
index 0d0a9c45c6..84a0bc9ca0 100644
--- a/basis/compiler/cfg/intrinsics/float/float.factor
+++ b/basis/compiler/cfg/intrinsics/float/float.factor
@@ -6,8 +6,7 @@ IN: compiler.cfg.intrinsics.float
 
 : emit-float-op ( insn -- )
     [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
-    ds-push
-    need-gc ; inline
+    ds-push ; inline
 
 : emit-float-comparison ( cc -- )
     [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
@@ -17,5 +16,4 @@ IN: compiler.cfg.intrinsics.float
     ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
 
 : emit-fixnum>float ( -- )
-    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push
-    need-gc ;
+    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 591c386c1c..8670b66c67 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math accessors sequences namespaces make
-combinators
+combinators classes
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.instructions ;
@@ -51,9 +51,19 @@ M: ##compare-imm-branch linearize-insn
 M: ##compare-float-branch linearize-insn
     binary-conditional _compare-float-branch emit-branch ;
 
+: gc? ( bb -- ? )
+    instructions>> [
+        class {
+            ##allot
+            ##integer>bignum
+            ##box-float
+            ##box-alien
+        } memq?
+    ] contains? ;
+
 : linearize-basic-block ( bb -- )
     [ number>> _label ]
-    [ gc>> [ _gc ] when ]
+    [ gc? [ _gc ] when ]
     [ linearize-insns ]
     tri ;
 
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index 4afe7a590a..96fcb3a174 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -23,5 +23,3 @@ IN: compiler.cfg.utilities
 
 : emit-primitive ( node -- )
     word>> ##call begin-basic-block ;
-
-: need-gc ( -- ) basic-block get t >>gc drop ;

From 866f798c0056bdd9f893309478a6c1808652d608 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 Nov 2008 02:12:12 -0600
Subject: [PATCH 088/318] Clean up hexdump

---
 extra/hexdump/hexdump.factor | 34 +++++++++++++++++-----------------
 1 file changed, 17 insertions(+), 17 deletions(-)

diff --git a/extra/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor
index 5262755821..b965fb41bb 100644
--- a/extra/hexdump/hexdump.factor
+++ b/extra/hexdump/hexdump.factor
@@ -1,36 +1,36 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays io io.streams.string kernel math math.parser
-namespaces prettyprint sequences splitting grouping strings
-ascii ;
+namespaces sequences splitting grouping strings ascii ;
 IN: hexdump
 
 <PRIVATE
 
 : write-header ( len -- )
     "Length: " write
-    [ unparse write ", " write ]
+    [ number>string write ", " write ]
     [ >hex write "h" write nl ] bi ;
 
 : write-offset ( lineno -- )
     16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
 
-: write-hex-digit ( digit -- )
-    >hex 2 CHAR: 0 pad-left write ;
+: >hex-digit ( digit -- str )
+    >hex 2 CHAR: 0 pad-left " " append ;
 
-: write-hex-line ( str n -- )
-    write-offset
-    dup [ write-hex-digit bl ] each
-    16 over length - 3 * CHAR: \s <string> write
-    [ dup printable? [ drop CHAR: . ] unless write1 ] each
-    nl ;
+: >hex-digits ( bytes -- str )
+    [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ;
+
+: >ascii ( bytes -- str )
+    [ [ printable? ] keep CHAR: . ? ] map ;
+
+: write-hex-line ( str lineno -- )
+    write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
 
 PRIVATE>
 
-: hexdump ( seq -- str )
-    [
-        [ length write-header ]
-        [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi
-    ] with-string-writer ;
+: hexdump. ( seq -- )
+    [ length write-header ]
+    [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
 
-: hexdump. ( seq -- ) hexdump write ;
+: hexdump ( seq -- str )
+    [ hexdump. ] with-string-writer ;

From 673fda2281d5265fb128191a8cf443ec547081ea Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 Nov 2008 03:10:27 -0600
Subject: [PATCH 089/318] Fix bogus error message

---
 core/compiler/units/units.factor | 4 ++--
 core/parser/parser-tests.factor  | 6 ++++++
 2 files changed, 8 insertions(+), 2 deletions(-)

diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index cb361ec9e6..9a4dba7bfa 100644
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -18,13 +18,13 @@ TUPLE: redefine-error def ;
     2dup key? [ over redefine-error ] when conjoin ;
 
 : (remember-definition) ( definition loc assoc -- )
-    >r over set-where r> add-once ;
+    [ over set-where ] dip add-once ;
 
 : remember-definition ( definition loc -- )
     new-definitions get first (remember-definition) ;
 
 : remember-class ( class loc -- )
-    over new-definitions get first key? [ dup redefine-error ] when
+    [ dup new-definitions get first key? [ dup redefine-error ] when ] dip
     new-definitions get second (remember-definition) ;
 
 : forward-reference? ( word -- ? )
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index c4fb977ebb..c4fa0890f9 100644
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -490,3 +490,9 @@ must-fail-with
 ] [
     error>> staging-violation?
 ] must-fail-with
+
+! Bogus error message
+DEFER: blah
+
+[ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ]
+[ error>> error>> def>> \ blah eq? ] must-fail-with

From d11a779fdd3c23fc01805e35cf8e36e93a66dd6d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 Nov 2008 03:58:32 -0600
Subject: [PATCH 090/318] RicE

---
 basis/compiler/cfg/def-use/def-use.factor              | 10 ++++++++++
 .../cfg/linear-scan/assignment/assignment.factor       |  6 +++++-
 .../linear-scan/live-intervals/live-intervals.factor   |  4 +++-
 3 files changed, 18 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 8df048d956..2cbd7e54cb 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -32,3 +32,13 @@ M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
 M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: insn uses-vregs drop f ;
+
+UNION: vreg-insn
+##flushable
+##write-barrier
+##dispatch
+##effect
+##conditional-branch
+##compare-imm-branch
+_conditional-branch
+_compare-imm-branch ;
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 2d8ad8c214..da45b45aaa 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -59,13 +59,17 @@ SYMBOL: unhandled-intervals
         ] [ 2drop ] if
     ] if ;
 
-: (assign-registers) ( insn -- )
+GENERIC: (assign-registers) ( insn -- )
+
+M: vreg-insn (assign-registers)
     dup
     [ defs-vregs ] [ uses-vregs ] bi append
     active-intervals get swap '[ vreg>> _ member? ] filter
     [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
     >>regs drop ;
 
+M: insn (assign-registers) drop ;
+
 : init-assignment ( live-intervals -- )
     V{ } clone active-intervals set
     <min-heap> unhandled-intervals set
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 73fe904485..1055a3524a 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -40,7 +40,9 @@ SYMBOL: live-intervals
 
 GENERIC# compute-live-intervals* 1 ( insn n -- )
 
-M: insn compute-live-intervals*
+M: insn compute-live-intervals* 2drop ;
+
+M: vreg-insn compute-live-intervals*
     live-intervals get
     [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
     [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]

From 445e3533375acfd27ee62994b9cab2032d0e5a44 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 Nov 2008 23:09:31 -0600
Subject: [PATCH 091/318] Optimize away useless jumps

---
 basis/compiler/cfg/builder/builder.factor     |  2 +-
 basis/compiler/cfg/cfg.factor                 | 16 +++---
 .../cfg/instructions/instructions.factor      | 10 ++++
 .../cfg/linearization/linearization.factor    | 11 ++--
 basis/compiler/cfg/optimizer/optimizer.factor |  7 ++-
 .../cfg/predecessors/predecessors.factor      | 10 ++++
 .../cfg/useless-blocks/useless-blocks.factor  | 55 +++++++++++++++++++
 basis/compiler/cfg/utilities/utilities.factor |  2 +-
 8 files changed, 99 insertions(+), 14 deletions(-)
 create mode 100644 basis/compiler/cfg/predecessors/predecessors.factor
 create mode 100644 basis/compiler/cfg/useless-blocks/useless-blocks.factor

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index f680d3a504..17ef0dce2f 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -86,7 +86,7 @@ GENERIC: emit-node ( node -- next )
 : emit-call ( word -- next )
     {
         { [ dup loops get key? ] [ loops get at local-recursive-call ] }
-        { [ tail-call? not ] [ ##call begin-basic-block iterate-next ] }
+        { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
         { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
         [ ##epilogue ##jump stop-iterating ]
     } cond ;
diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 9d5712ebcd..054b4f7ed0 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -1,24 +1,26 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays accessors namespaces assocs sequences sets fry ;
+USING: kernel arrays vectors accessors namespaces ;
 IN: compiler.cfg
 
-TUPLE: cfg entry word label ;
-
-C: <cfg> cfg
-
 TUPLE: basic-block < identity-tuple
 id
 number
-instructions
-successors ;
+{ instructions vector }
+{ successors vector }
+{ predecessors vector } ;
 
 : <basic-block> ( -- basic-block )
     basic-block new
         V{ } clone >>instructions
         V{ } clone >>successors
+        V{ } clone >>predecessors
         \ basic-block counter >>id ;
 
+TUPLE: cfg { entry basic-block } word label ;
+
+C: <cfg> cfg
+
 TUPLE: mr { instructions array } word label spill-counts ;
 
 : <mr> ( instructions word label -- mr )
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index f70345d1e8..d7d6563819 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -168,6 +168,16 @@ SYMBOL: cc>
 SYMBOL: cc>=
 SYMBOL: cc/=
 
+: negate-cc ( cc -- cc' )
+    H{
+        { cc< cc>= }
+        { cc<= cc> }
+        { cc> cc<= }
+        { cc>= cc< }
+        { cc= cc/= }
+        { cc/= cc= }
+    } at ;
+
 : evaluate-cc ( result cc -- ? )
     H{
         { cc<  { +lt+           } }
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 8670b66c67..d8f5d35ed4 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -18,7 +18,7 @@ M: insn linearize-insn , drop ;
 : useless-branch? ( basic-block successor -- ? )
     #! If our successor immediately follows us in RPO, then we
     #! don't need to branch.
-    [ number>> 1+ ] [ number>> ] bi* = ; inline
+    [ number>> ] bi@ 1- = ; inline
 
 : branch-to-return? ( successor -- ? )
     #! A branch to a block containing just a return is cloned.
@@ -36,11 +36,14 @@ M: insn linearize-insn , drop ;
 M: ##branch linearize-insn
     drop dup successors>> first emit-branch ;
 
-: conditional ( basic-block -- basic-block successor1 label2 )
-    dup successors>> first2 swap number>> ; inline
+: (binary-conditional)
+    [ dup successors>> first2 ]
+    [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
 
 : binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
-    [ conditional ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
+    [ (binary-conditional) ]
+    [ drop dup successors>> first useless-branch? ] 2bi
+    [ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
 
 M: ##compare-branch linearize-insn
     binary-conditional _compare-branch emit-branch ;
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 05084e32a8..7887faeb61 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -2,6 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences compiler.cfg.rpo
 compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.useless-blocks
 compiler.cfg.height
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
@@ -10,9 +12,12 @@ compiler.cfg.write-barrier ;
 IN: compiler.cfg.optimizer
 
 : trivial? ( insns -- ? )
-    dup length 1 = [ first ##call? ] [ drop f ] if ;
+    dup length 2 = [ first ##call? ] [ drop f ] if ;
 
 : optimize-cfg ( cfg -- cfg' )
+    compute-predecessors
+    delete-useless-blocks
+    delete-useless-conditionals
     [
         dup trivial? [
             normalize-height
diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor
new file mode 100644
index 0000000000..01a2a771bc
--- /dev/null
+++ b/basis/compiler/cfg/predecessors/predecessors.factor
@@ -0,0 +1,10 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences compiler.cfg.rpo ;
+IN: compiler.cfg.predecessors
+
+: (compute-predecessors) ( bb -- )
+    dup successors>> [ predecessors>> push ] with each ;
+
+: compute-predecessors ( cfg -- cfg' )
+    dup [ (compute-predecessors) ] each-basic-block ;
diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor
new file mode 100644
index 0000000000..f543aa4036
--- /dev/null
+++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor
@@ -0,0 +1,55 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences combinators classes vectors
+compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
+IN: compiler.cfg.useless-blocks
+
+: update-predecessor-for-delete ( bb -- )
+    dup predecessors>> first [
+        [
+            2dup eq? [ drop successors>> first ] [ nip ] if
+        ] with map
+    ] change-successors drop ;
+
+: update-successor-for-delete ( bb -- )
+    [ predecessors>> first ]
+    [ successors>> first predecessors>> ]
+    bi set-first ;
+
+: delete-basic-block ( bb -- )
+    [ update-predecessor-for-delete ]
+    [ update-successor-for-delete ]
+    bi ;
+
+: delete-basic-block? ( bb -- ? )
+    {
+        { [ dup instructions>> length 1 = not ] [ f ] }
+        { [ dup predecessors>> length 1 = not ] [ f ] }
+        { [ dup successors>> length 1 = not ] [ f ] }
+        { [ dup instructions>> first ##branch? not ] [ f ] }
+        [ t ]
+    } cond nip ;
+
+: delete-useless-blocks ( cfg -- cfg' )
+    dup [
+        dup delete-basic-block? [ delete-basic-block ] [ drop ] if
+    ] each-basic-block ;
+
+: delete-conditional? ( bb -- ? )
+    dup instructions>> [ drop f ] [
+        peek class {
+            ##compare-branch
+            ##compare-imm-branch
+            ##compare-float-branch
+        } memq? [ successors>> first2 eq? ] [ drop f ] if
+    ] if-empty ;
+
+: delete-conditional ( bb -- )
+    dup successors>> first 1vector >>successors
+    [ but-last f \ ##branch boa suffix ] change-instructions
+    drop ;
+
+: delete-useless-conditionals ( cfg -- cfg' )
+    dup [
+        dup delete-conditional? [ delete-conditional ] [ drop ] if
+    ] each-basic-block ;
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index 96fcb3a174..b00fd0ed3d 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -22,4 +22,4 @@ IN: compiler.cfg.utilities
     basic-block off ;
 
 : emit-primitive ( node -- )
-    word>> ##call begin-basic-block ;
+    word>> ##call ##branch begin-basic-block ;

From 449c1191ccd03e2c9c497c13ba9f2c3b0b4c85c5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 2 Nov 2008 23:25:42 -0600
Subject: [PATCH 092/318] Add another debug var

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

diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index 0a21749d84..a3c425b285 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -3,12 +3,13 @@
 USING: accessors kernel namespaces arrays sequences io debugger
 words fry continuations vocabs assocs dlists definitions math
 threads graphs generic combinators deques search-deques
-stack-checker stack-checker.state stack-checker.inlining
-compiler.errors compiler.units compiler.tree.builder
-compiler.tree.optimizer compiler.cfg.builder
-compiler.cfg.optimizer compiler.cfg.linearization
-compiler.cfg.two-operand compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.codegen ;
+prettyprint io stack-checker stack-checker.state
+stack-checker.inlining compiler.errors compiler.units
+compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.optimizer
+compiler.cfg.linearization compiler.cfg.two-operand
+compiler.cfg.linear-scan compiler.cfg.stack-frame
+compiler.codegen ;
 IN: compiler
 
 SYMBOL: compile-queue
@@ -43,7 +44,10 @@ SYMBOL: +failed+
     [ "compiled-effect" set-word-prop ]
     2bi ;
 
+SYMBOL: trace-compilation?
+
 : start ( word -- )
+    trace-compilation? get [ dup . flush ] when
     H{ } clone dependencies set
     H{ } clone generic-dependencies set
     f swap compiler-error ;

From abb02f1784cf37ff5033339985b2b3a31a92e970 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 00:03:00 -0600
Subject: [PATCH 093/318] Flesh out shift instructions

---
 .../cpu/x86/assembler/assembler-tests.factor  |  5 +++++
 basis/cpu/x86/assembler/assembler.factor      | 21 ++++++++++++-------
 2 files changed, 19 insertions(+), 7 deletions(-)

diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor
index 915847a453..49b0961819 100644
--- a/basis/cpu/x86/assembler/assembler-tests.factor
+++ b/basis/cpu/x86/assembler/assembler-tests.factor
@@ -57,3 +57,8 @@ IN: cpu.x86.assembler.tests
 
 [ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
 [ [ R12 RSP [+] RAX MOV ] { } make ] must-fail
+
+[ { 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
diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor
index 51b899fe31..e1c4f95166 100644
--- a/basis/cpu/x86/assembler/assembler.factor
+++ b/basis/cpu/x86/assembler/assembler.factor
@@ -391,13 +391,20 @@ M: operand CMP OCT: 070 2-operand ;
 : CDQ ( -- ) HEX: 99 , ;
 : CQO ( -- ) HEX: 48 , CDQ ;
 
-: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
-: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
-: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
-: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
-: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
-: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
-: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
+: (SHIFT) ( dst src op -- )
+    over CL eq? [
+        nip t HEX: d3 3array 1-operand
+    ] [
+        swapd t HEX: c0 3array immediate-1
+    ] if ; inline
+
+: ROL ( dst n -- ) BIN: 000 (SHIFT) ;
+: ROR ( dst n -- ) BIN: 001 (SHIFT) ;
+: RCL ( dst n -- ) BIN: 010 (SHIFT) ;
+: RCR ( dst n -- ) BIN: 011 (SHIFT) ;
+: SHL ( dst n -- ) BIN: 100 (SHIFT) ;
+: SHR ( dst n -- ) BIN: 101 (SHIFT) ;
+: SAR ( dst n -- ) BIN: 111 (SHIFT) ;
 
 GENERIC: IMUL2 ( dst src -- )
 M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;

From 0d83873174b43e3e47c7f058879b0cdb2baaeb38 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 00:03:15 -0600
Subject: [PATCH 094/318] Fix regression

---
 basis/compiler/tree/cleanup/cleanup-tests.factor | 8 +++++++-
 basis/compiler/tree/cleanup/cleanup.factor       | 2 +-
 2 files changed, 8 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor
index b3ba62b73b..b77a27800f 100644
--- a/basis/compiler/tree/cleanup/cleanup-tests.factor
+++ b/basis/compiler/tree/cleanup/cleanup-tests.factor
@@ -5,7 +5,7 @@ strings sbufs sequences.private slots.private combinators
 definitions system layouts vectors math.partial-dispatch
 math.order math.functions accessors hashtables classes assocs
 io.encodings.utf8 io.encodings.ascii io.encodings fry slots
-sorting.private
+sorting.private combinators.short-circuit
 compiler.tree
 compiler.tree.combinators
 compiler.tree.cleanup
@@ -13,6 +13,7 @@ compiler.tree.builder
 compiler.tree.recursive
 compiler.tree.normalization
 compiler.tree.propagation
+compiler.tree.propagation.info
 compiler.tree.checker
 compiler.tree.debugger ;
 
@@ -494,3 +495,8 @@ cell-bits 32 = [
 [ t ] [
     [ hashtable new ] \ new inlined?
 ] unit-test
+
+[ t ] [
+    [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
+    [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
+] unit-test
diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index caf2a36925..4ca058b2e3 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -78,7 +78,7 @@ GENERIC: cleanup* ( node -- node/nodes )
     } cond ;
 
 : remove-overflow-check ( #call -- #call )
-    [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
+    [ no-overflow-variant ] change-word cleanup* ;
 
 M: #call cleanup*
     {

From 1aefde994fe0acfcde8ed67530fe7f8ffc84d1db Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 00:03:22 -0600
Subject: [PATCH 095/318] Cleanup

---
 .../modular-arithmetic/modular-arithmetic.factor    | 13 ++-----------
 1 file changed, 2 insertions(+), 11 deletions(-)

diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
index d65b1def16..de2600f691 100644
--- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
+++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
@@ -53,17 +53,8 @@ M: node maybe-modularize* 2drop ;
 GENERIC: compute-modularized-values* ( node -- )
 
 M: #call compute-modularized-values*
-    dup word>> {
-        { [ \ >fixnum eq? ] [ in-d>> first maybe-modularize ] }
-        ! { [
-        !     {
-        !         mod-integer-fixnum
-        !         mod-integer-integer
-        !         mod-fixnum-integer
-        !     } memq?
-        ! ] [ ] }
-        [ drop ]
-    } cond ;
+    dup word>> \ >fixnum eq?
+    [ in-d>> first maybe-modularize ] [ drop ] if ;
 
 M: node compute-modularized-values* drop ;
 

From dd20b39cd680cb7054c4a9092e1a549e60a6d8d8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 00:03:39 -0600
Subject: [PATCH 096/318] fixnum-shift-fast subprimitive

---
 basis/cpu/x86/bootstrap.factor | 15 +++++++++++++++
 1 file changed, 15 insertions(+)

diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 7fc32da9a4..c1471da915 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -302,6 +302,21 @@ big-endian off
     ds-reg [] arg0 MOV                         ! save
 ] f f f \ fixnum-bitnot define-sub-primitive
 
+[
+    ECX ds-reg [] MOV                          ! load shift count
+    ECX tag-bits get SHR                       ! untag shift count
+    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    arg0 ds-reg [] MOV                         ! load value
+    arg1 arg0 MOV                              ! make a copy
+    arg1 CL SHL                                ! compute positive shift value in arg1
+    ECX NEG                                    ! compute negative shift value in arg0
+    arg0 CL SHR
+    arg0 tag-mask get bitnot AND
+    ECX 0 CMP                                  ! if shift count was negative, move arg0 to arg1
+    arg1 arg0 CMOVLE
+    ds-reg [] arg1 MOV                         ! push to stack
+] f f f \ fixnum-shift-fast define-sub-primitive
+
 [
     arg0 ds-reg [] MOV                         ! load local number
     fixnum>slot@                               ! turn local number into offset

From 44a2499c1794da6c618c1da7976a60732dac4c7f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 01:18:35 -0600
Subject: [PATCH 097/318] fixnum-shift-fast and fixnum-mod subprimitives

---
 basis/cpu/x86/32/bootstrap.factor |  3 +++
 basis/cpu/x86/64/bootstrap.factor |  3 +++
 basis/cpu/x86/bootstrap.factor    | 22 ++++++++++++++++------
 core/bootstrap/primitives.factor  |  4 ++--
 vm/math.c                         | 12 ------------
 vm/math.h                         |  2 --
 vm/primitives.c                   |  2 --
 7 files changed, 24 insertions(+), 24 deletions(-)

diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor
index 81779ac9f4..37f9b3ada0 100644
--- a/basis/cpu/x86/32/bootstrap.factor
+++ b/basis/cpu/x86/32/bootstrap.factor
@@ -6,6 +6,9 @@ IN: bootstrap.x86
 
 4 \ cell set
 
+: shift-arg ( -- reg ) ECX ;
+: div-arg ( -- reg ) EAX ;
+: mod-arg ( -- reg ) EDX ;
 : arg0 ( -- reg ) EAX ;
 : arg1 ( -- reg ) EDX ;
 : temp-reg ( -- reg ) EBX ;
diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor
index 0092843bca..c1f5156178 100644
--- a/basis/cpu/x86/64/bootstrap.factor
+++ b/basis/cpu/x86/64/bootstrap.factor
@@ -6,6 +6,9 @@ IN: bootstrap.x86
 
 8 \ cell set
 
+: shift-arg ( -- reg ) RCX ;
+: div-arg ( -- reg ) RAX ;
+: mod-arg ( -- reg ) RDX ;
 : arg0 ( -- reg ) RDI ;
 : arg1 ( -- reg ) RSI ;
 : temp-reg ( -- reg ) RBX ;
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index c1471da915..c7c4d0de52 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -303,20 +303,30 @@ big-endian off
 ] f f f \ fixnum-bitnot define-sub-primitive
 
 [
-    ECX ds-reg [] MOV                          ! load shift count
-    ECX tag-bits get SHR                       ! untag shift count
+    shift-arg ds-reg [] MOV                    ! load shift count
+    shift-arg tag-bits get SAR                 ! untag shift count
     ds-reg bootstrap-cell SUB                  ! adjust stack pointer
     arg0 ds-reg [] MOV                         ! load value
     arg1 arg0 MOV                              ! make a copy
     arg1 CL SHL                                ! compute positive shift value in arg1
-    ECX NEG                                    ! compute negative shift value in arg0
-    arg0 CL SHR
+    shift-arg NEG                              ! compute negative shift value in arg0
+    arg0 CL SAR
     arg0 tag-mask get bitnot AND
-    ECX 0 CMP                                  ! if shift count was negative, move arg0 to arg1
-    arg1 arg0 CMOVLE
+    shift-arg 0 CMP                            ! if shift count was negative, move arg0 to arg1
+    arg1 arg0 CMOVGE
     ds-reg [] arg1 MOV                         ! push to stack
 ] f f f \ fixnum-shift-fast define-sub-primitive
 
+[
+    temp-reg ds-reg [] MOV                     ! load second parameter
+    ds-reg bootstrap-cell SUB                  ! adjust stack pointer
+    div-arg ds-reg [] MOV                      ! load first parameter
+    mod-arg div-arg MOV                        ! make a copy
+    mod-arg bootstrap-cell-bits 1- SAR         ! sign-extend
+    temp-reg IDIV                              ! divide
+    ds-reg [] mod-arg MOV                      ! push to stack
+] f f f \ fixnum-mod define-sub-primitive
+
 [
     arg0 ds-reg [] MOV                         ! load local number
     fixnum>slot@                               ! turn local number into offset
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index f55942603d..c3b13318ee 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -346,6 +346,8 @@ tuple
     { "fixnum-bitor" "math.private" }
     { "fixnum-bitxor" "math.private" }
     { "fixnum-bitnot" "math.private" }
+    { "fixnum-mod" "math.private" }
+    { "fixnum-shift-fast" "math.private" }
     { "fixnum<" "math.private" }
     { "fixnum<=" "math.private" }
     { "fixnum>" "math.private" }
@@ -399,10 +401,8 @@ tuple
     { "fixnum-" "math.private" }
     { "fixnum*" "math.private" }
     { "fixnum/i" "math.private" }
-    { "fixnum-mod" "math.private" }
     { "fixnum/mod" "math.private" }
     { "fixnum-shift" "math.private" }
-    { "fixnum-shift-fast" "math.private" }
     { "bignum=" "math.private" }
     { "bignum+" "math.private" }
     { "bignum-" "math.private" }
diff --git a/vm/math.c b/vm/math.c
index c1e13951dc..c7c5dba5a4 100644
--- a/vm/math.c
+++ b/vm/math.c
@@ -85,12 +85,6 @@ DEFINE_PRIMITIVE(fixnum_divmod)
 	dpush(tag_fixnum(x % y));
 }
 
-DEFINE_PRIMITIVE(fixnum_mod)
-{
-	POP_FIXNUMS(x,y)
-	dpush(tag_fixnum(x % y));
-}
-
 /*
  * Note the hairy overflow check.
  * If we're shifting right by n bits, we won't overflow as long as none of the
@@ -127,12 +121,6 @@ DEFINE_PRIMITIVE(fixnum_shift)
 		fixnum_to_bignum(x),y)));
 }
 
-DEFINE_PRIMITIVE(fixnum_shift_fast)
-{
-	POP_FIXNUMS(x,y)
-	dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y)));
-}
-
 /* Bignums */
 DEFINE_PRIMITIVE(fixnum_to_bignum)
 {
diff --git a/vm/math.h b/vm/math.h
index 6f81ece8a8..07d7fa9199 100644
--- a/vm/math.h
+++ b/vm/math.h
@@ -14,9 +14,7 @@ DECLARE_PRIMITIVE(fixnum_subtract);
 DECLARE_PRIMITIVE(fixnum_multiply);
 DECLARE_PRIMITIVE(fixnum_divint);
 DECLARE_PRIMITIVE(fixnum_divmod);
-DECLARE_PRIMITIVE(fixnum_mod);
 DECLARE_PRIMITIVE(fixnum_shift);
-DECLARE_PRIMITIVE(fixnum_shift_fast);
 
 CELL bignum_zero;
 CELL bignum_pos_one;
diff --git a/vm/primitives.c b/vm/primitives.c
index 94151f6c40..84cad12326 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -19,10 +19,8 @@ void *primitives[] = {
 	primitive_fixnum_subtract,
 	primitive_fixnum_multiply,
 	primitive_fixnum_divint,
-	primitive_fixnum_mod,
 	primitive_fixnum_divmod,
 	primitive_fixnum_shift,
-	primitive_fixnum_shift_fast,
 	primitive_bignum_eq,
 	primitive_bignum_add,
 	primitive_bignum_subtract,

From f253e7494231c667eb6c1e3dcada9cd481b55702 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 01:18:54 -0600
Subject: [PATCH 098/318] Inline subprimitives in optimizing compiler

---
 basis/compiler/cfg/stack-frame/stack-frame.factor | 2 +-
 basis/compiler/codegen/codegen.factor             | 4 +++-
 2 files changed, 4 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index aa8506a01f..8d79a85b8f 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -22,7 +22,7 @@ M: ##stack-frame compute-stack-frame*
     stack-frame>> stack-frame [ max-stack-frame ] change ;
 
 M: ##call compute-stack-frame*
-    drop frame-required? on ;
+    word>> sub-primitive>> [ frame-required? on ] unless ;
 
 M: _gc compute-stack-frame*
     drop frame-required? on ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 18e923bbc2..53329f4d50 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -82,7 +82,9 @@ M: ##inc-d generate-insn n>> %inc-d ;
 
 M: ##inc-r generate-insn n>> %inc-r ;
 
-M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
+M: ##call generate-insn
+    word>> dup sub-primitive>>
+    [ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
 
 M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
 

From 7f3282bb399a265cb3e720afb91330f14226adc5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 01:19:06 -0600
Subject: [PATCH 099/318] Better error reporting

---
 basis/math/partial-dispatch/partial-dispatch.factor | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor
index 61678eb088..fd0e910b37 100644
--- a/basis/math/partial-dispatch/partial-dispatch.factor
+++ b/basis/math/partial-dispatch/partial-dispatch.factor
@@ -14,9 +14,11 @@ GENERIC: integer-op-input-classes ( word -- classes )
 M: math-partial integer-op-input-classes
     "derived-from" word-prop rest ;
 
+ERROR: bad-integer-op word ;
+
 M: word integer-op-input-classes
-    "input-classes" word-prop
-    [ "Bug: integer-op-input-classes" throw ] unless* ;
+    dup "input-classes" word-prop
+    [ ] [ bad-integer-op ] ?if ;
 
 : generic-variant ( op -- generic-op/f )
     dup "derived-from" word-prop [ first ] [ ] ?if ;

From 3230e0010fa83dace05574d8f696464002789bd9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 01:19:20 -0600
Subject: [PATCH 100/318] -trace-compilation command line switch

---
 basis/compiler/compiler.factor | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index a3c425b285..b01a835b4a 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -44,10 +44,8 @@ SYMBOL: +failed+
     [ "compiled-effect" set-word-prop ]
     2bi ;
 
-SYMBOL: trace-compilation?
-
 : start ( word -- )
-    trace-compilation? get [ dup . flush ] when
+    "trace-compilation" get [ dup . flush ] when
     H{ } clone dependencies set
     H{ } clone generic-dependencies set
     f swap compiler-error ;

From 08b277e892827200d908b974ea7c273c8212321f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 01:52:55 -0600
Subject: [PATCH 101/318] Fix alias anlaysis bug: result of ##box-alien and
 ##box-float did not get an AC, so calling hi-tag would not compile

---
 .../cfg/alias-analysis/alias-analysis-tests.factor     |  8 ++++++++
 .../compiler/cfg/alias-analysis/alias-analysis.factor  | 10 ++++++++++
 2 files changed, 18 insertions(+)

diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
index 2f0649ed40..c7094c8c36 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
@@ -3,6 +3,14 @@ compiler.cfg.alias-analysis cpu.architecture tools.test
 kernel ;
 IN: compiler.cfg.alias-analysis.tests
 
+[ ] [
+    {
+        T{ ##peek f V int-regs 2 D 1 f }
+        T{ ##box-alien f V int-regs 1 V int-regs 2 }
+        T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
+    } alias-analysis drop
+] unit-test
+
 [ ] [
     {
         T{ ##load-indirect f V int-regs 1 "hello" }
diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index e68d304047..98569d868c 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -229,6 +229,16 @@ M: ##allot analyze-aliases*
     #! object.
     dup dst>> set-new-ac ;
 
+M: ##box-float analyze-aliases*
+    #! A freshly allocated object is distinct from any other
+    #! object.
+    dup dst>> set-new-ac ;
+
+M: ##box-alien analyze-aliases*
+    #! A freshly allocated object is distinct from any other
+    #! object.
+    dup dst>> set-new-ac ;
+
 M: ##read analyze-aliases*
     dup dst>> set-heap-ac
     dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri

From 0250d7c1d291f0a7b6a959e3aa02e277525eb542 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 01:53:27 -0600
Subject: [PATCH 102/318] Forgot a drop in unit test

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

diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index aa899208c0..af2e81b767 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -353,5 +353,5 @@ USING: math.private compiler.cfg.debugger ;
         }
     }
     { { int-regs { 0 1 2 3 } } }
-    allocate-registers
+    allocate-registers drop
 ] unit-test

From 2445a83cb90a1c7b10977f2ca8646f30dba521dd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 03:06:11 -0600
Subject: [PATCH 103/318] Clean up recursive-state usage

---
 basis/stack-checker/alien/alien.factor             | 10 +++++-----
 basis/stack-checker/backend/backend.factor         |  7 +++++--
 basis/stack-checker/branches/branches.factor       |  2 +-
 basis/stack-checker/known-words/known-words.factor |  4 ++--
 basis/stack-checker/stack-checker.factor           |  2 +-
 basis/stack-checker/state/state.factor             |  4 ++--
 6 files changed, 16 insertions(+), 13 deletions(-)

diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor
index f81b7fdaa3..a38e9ea784 100644
--- a/basis/stack-checker/alien/alien.factor
+++ b/basis/stack-checker/alien/alien.factor
@@ -36,7 +36,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
     pop-literal nip >>library
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup param-prep-quot recursive-state get infer-quot
+    dup param-prep-quot infer-quot-here
     ! Set ABI
     dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
     ! Magic #: consume exactly the number of inputs
@@ -44,7 +44,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
     ! Add node to IR
     dup #alien-invoke,
     ! Quotation which coerces return value to required type
-    return-prep-quot recursive-state get infer-quot ;
+    return-prep-quot infer-quot-here ;
 
 : infer-alien-indirect ( -- )
     alien-indirect-params new
@@ -53,13 +53,13 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
     pop-parameters >>parameters
     pop-literal nip >>return
     ! Quotation which coerces parameters to required types
-    dup param-prep-quot [ dip ] curry recursive-state get infer-quot
+    dup param-prep-quot [ dip ] curry infer-quot-here
     ! Magic #: consume the function pointer, too
     dup 1 alien-stack
     ! Add node to IR
     dup #alien-indirect,
     ! Quotation which coerces return value to required type
-    return-prep-quot recursive-state get infer-quot ;
+    return-prep-quot infer-quot-here ;
 
 ! Callbacks are registered in a global hashtable. If you clear
 ! this hashtable, they will all be blown away by code GC, beware
@@ -71,7 +71,7 @@ SYMBOL: callbacks
 
 : callback-bottom ( params -- )
     xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
-    recursive-state get infer-quot ;
+    infer-quot-here ;
 
 : infer-alien-callback ( -- )
     alien-callback-params new
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index aa280b96b6..f8dec5f823 100644
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -60,17 +60,20 @@ M: object apply-object push-literal ;
 : terminate ( -- )
     terminated? on meta-d get clone meta-r get clone #terminate, ;
 
+: infer-quot-here ( quot -- )
+    [ apply-object terminated? get not ] all? drop ;
+
 : infer-quot ( quot rstate -- )
     recursive-state get [
         recursive-state set
-        [ apply-object terminated? get not ] all? drop
+        infer-quot-here
     ] dip recursive-state set ;
 
 : infer-quot-recursive ( quot word label -- )
     2array recursive-state get swap prefix infer-quot ;
 
 : time-bomb ( error -- )
-    '[ _ throw ] recursive-state get infer-quot ;
+    '[ _ throw ] infer-quot-here ;
 
 : bad-call ( -- )
     "call must be given a callable" time-bomb ;
diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor
index 6b73661471..d1417d035c 100644
--- a/basis/stack-checker/branches/branches.factor
+++ b/basis/stack-checker/branches/branches.factor
@@ -100,7 +100,7 @@ SYMBOL: quotations
     dup [ known [ curried? ] [ composed? ] bi or ] contains? [
         output-d
         [ rot [ drop call ] [ nip call ] if ]
-        recursive-state get infer-quot
+        infer-quot-here
     ] [
         [ #drop, ] [ [ literal ] map (infer-if) ] bi
     ] if ;
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 1332415c49..2c0bae5328 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -68,14 +68,14 @@ M: literal infer-call*
 
 M: curried infer-call*
     swap push-d
-    [ uncurry ] recursive-state get infer-quot
+    [ uncurry ] infer-quot-here
     [ quot>> known pop-d [ set-known ] keep ]
     [ obj>> known pop-d [ set-known ] keep ] bi
     push-d infer-call ;
 
 M: composed infer-call*
     swap push-d
-    [ uncompose ] recursive-state get infer-quot
+    [ uncompose ] infer-quot-here
     [ quot2>> known pop-d [ set-known ] keep ]
     [ quot1>> known pop-d [ set-known ] keep ] bi
     push-d push-d
diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor
index bc3b65518c..c990a51cc1 100644
--- a/basis/stack-checker/stack-checker.factor
+++ b/basis/stack-checker/stack-checker.factor
@@ -10,7 +10,7 @@ IN: stack-checker
 GENERIC: infer ( quot -- effect )
 
 M: callable infer ( quot -- effect )
-    [ recursive-state get infer-quot ] with-infer drop ;
+    [ infer-quot-here ] with-infer drop ;
 
 : infer. ( quot -- )
     #! Safe to call from inference transforms.
diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
index d3d32b5014..11dc6f9ef8 100644
--- a/basis/stack-checker/state/state.factor
+++ b/basis/stack-checker/state/state.factor
@@ -75,8 +75,8 @@ SYMBOL: meta-r
     recursive-state get at ;
 
 : local-recursive-state ( -- assoc )
-    recursive-state get dup keys
-    [ dup word? [ inline? ] when not ] find drop
+    recursive-state get dup
+    [ first dup word? [ inline? ] when not ] find drop
     [ head-slice ] when* ;
 
 : inline-recursive-label ( word -- label/f )

From cdb5c30bd38d69fae754fa7c7c4dceb22f767850 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 03:51:28 -0600
Subject: [PATCH 104/318] Only build a generic word once, even if a compilation
 unit defines several methods on it, by adding generics to a set and building
 them at the end. 25% improvement on bootstrap time

---
 basis/bootstrap/image/image.factor  |  5 ++++-
 core/bootstrap/primitives.factor    |  1 +
 core/classes/mixin/mixin.factor     |  2 +-
 core/compiler/units/units.factor    |  7 +++++++
 core/definitions/definitions.factor | 21 +++++++++++++++------
 core/generic/generic.factor         | 13 +++++++++----
 6 files changed, 37 insertions(+), 12 deletions(-)

diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index db8e8c8ec0..643899102e 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -8,7 +8,8 @@ grouping growable classes classes.builtin classes.tuple
 classes.tuple.private words.private io.binary io.files vocabs
 vocabs.loader source-files definitions debugger
 quotations.private sequences.private combinators
-io.encodings.binary math.order math.private accessors slots.private ;
+io.encodings.binary math.order math.private accessors
+slots.private compiler.units ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
@@ -458,6 +459,8 @@ M: quotation '
     800000 <vector> image set
     20000 <hashtable> objects set
     emit-header t, 0, 1, -1,
+    "Building generic words..." print flush
+    call-remake-generics-hook
     "Serializing words..." print flush
     emit-words
     "Serializing JIT data..." print flush
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index c3b13318ee..bbc86c2e3c 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -36,6 +36,7 @@ H{ } clone dictionary set
 H{ } clone new-classes set
 H{ } clone changed-definitions set
 H{ } clone changed-generics set
+H{ } clone remake-generics set
 H{ } clone forgotten-definitions set
 H{ } clone root-cache set
 H{ } clone source-files set
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index d569103d97..65726cf6e8 100644
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -42,7 +42,7 @@ TUPLE: check-mixin-class mixin ;
 : update-classes/new ( mixin -- )
     class-usages
     [ [ update-class ] each ]
-    [ implementors [ make-generic ] each ] bi ;
+    [ implementors [ remake-generic ] each ] bi ;
 
 : add-mixin-instance ( class mixin -- )
     #! Note: we call update-classes on the new member, not the
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 9a4dba7bfa..973d9b5c00 100644
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -72,6 +72,7 @@ GENERIC: definitions-changed ( assoc obj -- )
 
 SYMBOL: outdated-tuples
 SYMBOL: update-tuples-hook
+SYMBOL: remake-generics-hook
 
 : dependency>= ( how1 how2 -- ? )
     [
@@ -127,6 +128,9 @@ SYMBOL: update-tuples-hook
 : call-recompile-hook ( -- )
     to-recompile recompile-hook get call ;
 
+: call-remake-generics-hook ( -- )
+    remake-generics-hook get call ;
+
 : call-update-tuples-hook ( -- )
     update-tuples-hook get call ;
 
@@ -136,6 +140,7 @@ SYMBOL: update-tuples-hook
     [ delete-compiled-xref ] each ;
 
 : finish-compilation-unit ( -- )
+    call-remake-generics-hook
     call-recompile-hook
     call-update-tuples-hook
     unxref-forgotten-definitions
@@ -145,6 +150,7 @@ SYMBOL: update-tuples-hook
     [
         H{ } clone changed-definitions set
         H{ } clone changed-generics set
+        H{ } clone remake-generics set
         H{ } clone outdated-tuples set
         H{ } clone new-classes set
         [ finish-compilation-unit ] [ ] cleanup
@@ -154,6 +160,7 @@ SYMBOL: update-tuples-hook
     [
         H{ } clone changed-definitions set
         H{ } clone changed-generics set
+        H{ } clone remake-generics set
         H{ } clone forgotten-definitions set
         H{ } clone outdated-tuples set
         H{ } clone new-classes set
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index 2b8646fda4..726116909f 100644
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -9,23 +9,32 @@ SYMBOL: inlined-dependency
 SYMBOL: flushed-dependency
 SYMBOL: called-dependency
 
+<PRIVATE
+
+: set-in-unit ( value key assoc -- )
+    [ set-at ] [ no-compilation-unit ] if* ;
+
+PRIVATE>
+
 SYMBOL: changed-definitions
 
 : changed-definition ( defspec -- )
-    inlined-dependency swap changed-definitions get
-    [ set-at ] [ no-compilation-unit ] if* ;
+    inlined-dependency swap changed-definitions get set-in-unit ;
 
 SYMBOL: changed-generics
 
 : changed-generic ( class generic -- )
-    changed-generics get
-    [ set-at ] [ no-compilation-unit ] if* ;
+    changed-generics get set-in-unit ;
+
+SYMBOL: remake-generics
+
+: remake-generic ( generic -- )
+    dup remake-generics get set-in-unit ;
 
 SYMBOL: new-classes
 
 : new-class ( word -- )
-    dup new-classes get
-    [ set-at ] [ no-compilation-unit ] if* ;
+    dup new-classes get set-in-unit ;
 
 : new-class? ( word -- ? )
     new-classes get key? ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 095a8d5dcc..cb5f9f3791 100644
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -3,7 +3,7 @@
 USING: accessors words kernel sequences namespaces make assocs
 hashtables definitions kernel.private classes classes.private
 classes.algebra quotations arrays vocabs effects combinators
-sets ;
+sets compiler.units ;
 IN: generic
 
 ! Method combination protocol
@@ -21,6 +21,11 @@ M: generic definition drop f ;
     [ dup "combination" word-prop perform-combination ]
     bi ;
 
+[
+    remake-generics get keys
+    [ generic? ] filter [ make-generic ] each
+] remake-generics-hook set-global
+
 : method ( class generic -- method/f )
     "methods" word-prop at ;
 
@@ -62,7 +67,7 @@ TUPLE: check-method class generic ;
 : with-methods ( class generic quot -- )
     [ drop changed-generic ]
     [ [ "methods" word-prop ] dip call ]
-    [ drop make-generic drop ]
+    [ drop remake-generic drop ]
     3tri ; inline
 
 : method-word-name ( class word -- string )
@@ -165,7 +170,7 @@ M: method-body smart-usage
 
 M: sequence update-methods ( class seq -- )
     implementors [
-        [ changed-generic ] [ make-generic drop ] 2bi
+        [ changed-generic ] [ remake-generic drop ] 2bi
     ] with each ;
 
 : define-generic ( word combination -- )
@@ -174,7 +179,7 @@ M: sequence update-methods ( class seq -- )
         over "methods" word-prop values forget-all
         over H{ } clone "methods" set-word-prop
         dupd define-default-method
-    ] if make-generic ;
+    ] if remake-generic ;
 
 M: generic subwords
     [

From 59f4f25b9151c88cb68723cce22a9de9bdad8d97 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 06:20:51 -0600
Subject: [PATCH 105/318] Loop alignment: appears to be a small win for
 reverse-complement

---
 basis/compiler/cfg/builder/builder.factor           | 1 +
 basis/compiler/cfg/instructions/instructions.factor | 2 ++
 basis/compiler/codegen/codegen.factor               | 2 ++
 basis/cpu/architecture/architecture.factor          | 2 ++
 basis/cpu/x86/architecture/architecture.factor      | 9 ++++++---
 basis/cpu/x86/assembler/assembler.factor            | 4 ++++
 6 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 17ef0dce2f..a59ceff5b9 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -100,6 +100,7 @@ GENERIC: emit-node ( node -- next )
     basic-block get swap loops get set-at ;
 
 : compile-loop ( node -- next )
+    ##loop-entry
     begin-basic-block
     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
     iterate-next ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index d7d6563819..5ea74e97ec 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -160,6 +160,8 @@ INSN: ##epilogue ;
 
 INSN: ##branch ;
 
+INSN: ##loop-entry ;
+
 ! Condition codes
 SYMBOL: cc<
 SYMBOL: cc<=
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 53329f4d50..7dca752cf7 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -205,6 +205,8 @@ M: ##write-barrier generate-insn
 
 M: _gc generate-insn drop %gc ;
 
+M: ##loop-entry generate-insn drop %loop-entry ;
+
 ! ##alien-invoke
 GENERIC: reg-size ( register-class -- n )
 
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index f7cce8e70a..618be9a11f 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -130,6 +130,8 @@ HOOK: %spill-float cpu ( src n -- )
 HOOK: %reload-integer cpu ( dst n -- )
 HOOK: %reload-float cpu ( dst n -- )
 
+HOOK: %loop-entry cpu ( -- )
+
 ! FFI stuff
 
 ! Is this integer small enough to appear in value template
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 615550587c..74b8818d16 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -51,8 +51,8 @@ M: x86 %call ( label -- ) CALL ;
 M: x86 %jump-label ( label -- ) JMP ;
 M: x86 %return ( -- ) 0 RET ;
 
-: code-alignment ( -- n )
-    building get length dup cell align swap - ;
+: code-alignment ( align -- n )
+    [ building get [ integer? ] count dup ] dip align swap - ;
 
 : align-code ( n -- )
     0 <repetition> % ;
@@ -66,7 +66,7 @@ M:: x86 %dispatch ( src temp -- )
     src temp ADD
     src HEX: 7f [+] JMP
     ! Fix up the displacement above
-    code-alignment dup bootstrap-cell 8 = 15 9 ? +
+    cell code-alignment dup bootstrap-cell 8 = 15 9 ? +
     building get dup pop* push
     align-code ;
 
@@ -466,6 +466,9 @@ M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
 M: x86 %spill-float spill-float@ swap MOVSD ;
 M: x86 %reload-float spill-float@ MOVSD ;
 
+M: x86 %loop-entry
+    16 code-alignment [ NOP ] times ;
+
 M: int-regs %save-param-reg drop >r stack@ r> MOV ;
 M: int-regs %load-param-reg drop swap stack@ MOV ;
 
diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor
index e1c4f95166..5c6fff2348 100644
--- a/basis/cpu/x86/assembler/assembler.factor
+++ b/basis/cpu/x86/assembler/assembler.factor
@@ -446,6 +446,10 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
 
 : CPUID ( -- ) HEX: a2 extended-opcode, ;
 
+! Misc
+
+: NOP ( -- ) HEX: 90 , ;
+
 ! x87 Floating Point Unit
 
 : FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;

From b649c01de6810875cc23843b47f31c155cbb75b3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 06:34:56 -0600
Subject: [PATCH 106/318] Fix name clash with templates.factor

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

diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor
index 2f413b642a..c1e23c3e1e 100644
--- a/basis/compiler/tests/simple.factor
+++ b/basis/compiler/tests/simple.factor
@@ -54,11 +54,11 @@ IN: compiler.tests
 
 ! Labels
 
-: recursive ( ? -- ) [ f recursive ] when ; inline
+: recursive-test ( ? -- ) [ f recursive-test ] when ; inline
 
-[ ] [ t [ recursive ] compile-call ] unit-test
+[ ] [ t [ recursive-test ] compile-call ] unit-test
 
-[ ] [ t recursive ] unit-test
+[ ] [ t recursive-test ] unit-test
 
 ! Make sure error reporting works
 

From e6f6cd5d93cc8e7723e117c2cffe86a7edbe3645 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 06:40:14 -0600
Subject: [PATCH 107/318] Fix USING: -- you can now make ppc images, they just
 don't work yet

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

diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index a0a13c989e..99bcfae92a 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
-system cpu.ppc.assembler compiler.generator.fixup compiler.units
+system cpu.ppc.assembler compiler.codegen.fixup compiler.units
 compiler.constants math math.private layouts words words.private
 vocabs slots.private ;
 IN: bootstrap.ppc

From 75e9708488706820ddaad1252076d9897d989374 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 06:50:59 -0600
Subject: [PATCH 108/318] Oops

---
 basis/cpu/ppc/assembler/assembler.factor       | 2 +-
 basis/cpu/ppc/assembler/backend/backend.factor | 5 +++--
 2 files changed, 4 insertions(+), 3 deletions(-)

diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor
index d7e71f6058..f94cc00abc 100644
--- a/basis/cpu/ppc/assembler/assembler.factor
+++ b/basis/cpu/ppc/assembler/assembler.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.generator.fixup kernel namespaces words
+USING: compiler.codegen.fixup kernel namespaces words
 io.binary math math.order cpu.ppc.assembler.backend ;
 IN: cpu.ppc.assembler
 
diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor
index 1b442662d5..881b094ca2 100644
--- a/basis/cpu/ppc/assembler/backend/backend.factor
+++ b/basis/cpu/ppc/assembler/backend/backend.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.generator.fixup kernel namespaces make sequences
-words math math.bitwise io.binary parser lexer ;
+USING: compiler.codegen.fixup cpu.architecture
+compiler.constants kernel namespaces make sequences words math
+math.bitwise io.binary parser lexer ;
 IN: cpu.ppc.assembler.backend
 
 : insn ( operand opcode -- ) { 26 0 } bitfield , ;

From 82e9eedd3985bcb59fe89551b5817c059463420e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 07:15:09 -0600
Subject: [PATCH 109/318] Forgot about float= intrinsic

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

diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 338eaab955..3fd54d2e07 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -76,6 +76,7 @@ IN: compiler.cfg.intrinsics
         math.private:float<=
         math.private:float>
         math.private:float>=
+        math.private:float=
         alien.accessors:alien-float
         alien.accessors:set-alien-float
         alien.accessors:alien-double
@@ -108,7 +109,7 @@ IN: compiler.cfg.intrinsics
         { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
         { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
         { \ math.private:float> [ drop cc> emit-float-comparison ] }
-        { \ math.private:float= [ drop cc> emit-float-comparison ] }
+        { \ math.private:float= [ drop cc= emit-float-comparison ] }
         { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
         { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
         { \ slots.private:slot [ emit-slot ] }

From 00fc4eb1799c96f256fa321bdf8c74e06b33fd70 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 07:27:14 -0600
Subject: [PATCH 110/318] Fix Windows bootstrap: check_sse2 was not DLLEXPORT

---
 vm/cpu-x86.32.S | 2 +-
 vm/cpu-x86.32.h | 1 +
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S
index 9e73bd6777..3e7e5c20e1 100644
--- a/vm/cpu-x86.32.S
+++ b/vm/cpu-x86.32.S
@@ -40,7 +40,7 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
 	ret                                /* return _with new stack_ */
 
 /* cpu.x86.32 calls this */
-DEF(bool,check_sse2,()):
+DEF(bool,check_sse2,(void)):
 	push %ebx
 	mov $1,%eax
 	cpuid
diff --git a/vm/cpu-x86.32.h b/vm/cpu-x86.32.h
index a81c9987c4..1d516c4703 100644
--- a/vm/cpu-x86.32.h
+++ b/vm/cpu-x86.32.h
@@ -5,3 +5,4 @@ register CELL rs asm("edi");
 
 #define F_FASTCALL __attribute__ ((regparm (2)))
 
+DLLEXPORT bool check_sse2(void);

From 4d25f1fff671a24afae079a3eb8ec423b478bfca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 08:06:59 -0600
Subject: [PATCH 111/318] Add some missing meta-data

---
 extra/webkit-demo/authors.txt | 1 +
 extra/webkit-demo/summary.txt | 1 +
 extra/webkit-demo/tags.txt    | 1 +
 3 files changed, 3 insertions(+)
 create mode 100644 extra/webkit-demo/authors.txt
 create mode 100644 extra/webkit-demo/summary.txt
 create mode 100644 extra/webkit-demo/tags.txt

diff --git a/extra/webkit-demo/authors.txt b/extra/webkit-demo/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/extra/webkit-demo/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/extra/webkit-demo/summary.txt b/extra/webkit-demo/summary.txt
new file mode 100644
index 0000000000..26728dd433
--- /dev/null
+++ b/extra/webkit-demo/summary.txt
@@ -0,0 +1 @@
+A simple example showing usage of the Cocoa WebKit framework from Factor
diff --git a/extra/webkit-demo/tags.txt b/extra/webkit-demo/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/webkit-demo/tags.txt
@@ -0,0 +1 @@
+unportable

From dc85ed3d564ef1533fa88e743b82331e4a14e3e8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 08:08:28 -0600
Subject: [PATCH 112/318] Fix help lint: links to obsolete article

---
 basis/compiler/compiler-docs.factor | 3 +--
 core/words/words-docs.factor        | 2 --
 2 files changed, 1 insertion(+), 4 deletions(-)

diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor
index 542c833178..6cb860d33f 100644
--- a/basis/compiler/compiler-docs.factor
+++ b/basis/compiler/compiler-docs.factor
@@ -27,8 +27,7 @@ ARTICLE: "compiler" "Optimizing compiler"
 "The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
 { $subsection "compiler-usage" }
 { $subsection "compiler-errors" }
-{ $subsection "hints" }
-{ $subsection "generator" } ;
+{ $subsection "hints" } ;
 
 ABOUT: "compiler"
 
diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor
index 324f8e755f..aaf14617b3 100644
--- a/core/words/words-docs.factor
+++ b/core/words/words-docs.factor
@@ -126,8 +126,6 @@ $nl
 
     { { $snippet "\"specializer\"" } { $link "hints" } }
     
-    { { { $snippet "\"intrinsics\"" } ", " { $snippet "\"if-intrinsics\"" } } { $link "generator" } }
-
     { { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" }
 }
 "Properties which are defined for classes only:"

From 92e2ee3509da904cc7e8be6328277e1f7f82f879 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Mon, 3 Nov 2008 16:20:36 -0500
Subject: [PATCH 113/318] Clean up Projece Euler solutions

---
 extra/project-euler/042/042.factor       |  4 ++--
 extra/project-euler/043/043.factor       | 11 +++++------
 extra/project-euler/044/044.factor       |  4 ++--
 extra/project-euler/076/076.factor       |  4 ++--
 extra/project-euler/079/079.factor       |  6 +++---
 extra/project-euler/092/092.factor       |  2 +-
 extra/project-euler/common/common.factor |  2 +-
 7 files changed, 16 insertions(+), 17 deletions(-)

diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor
index 8ae95d6db7..009570d92c 100644
--- a/extra/project-euler/042/042.factor
+++ b/extra/project-euler/042/042.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: ascii io.files kernel math math.functions namespaces make
-    project-euler.common sequences splitting io.encodings.ascii ;
+USING: ascii io.encodings.ascii io.files kernel make math math.functions
+    namespaces project-euler.common sequences splitting ;
 IN: project-euler.042
 
 ! http://projecteuler.net/index.php?section=problems&id=42
diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index 84ed7a830f..9eb78e5153 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -1,8 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit hashtables kernel math
-    math.combinatorics math.parser math.ranges project-euler.common sequences
-    sorting sets ;
+USING: combinators.short-circuit kernel math math.combinatorics math.parser
+    math.ranges project-euler.common sequences sets sorting ;
 IN: project-euler.043
 
 ! http://projecteuler.net/index.php?section=problems&id=43
@@ -74,13 +73,13 @@ PRIVATE>
     1000 over <range> [ number>digits 3 0 pad-left ] map [ all-unique? ] filter ;
 
 : overlap? ( seq -- ? )
-    dup first 2 tail* swap second 2 head = ;
+    [ first 2 tail* ] [ second 2 head ] bi = ;
 
 : clean ( seq -- seq )
     [ unclip 1 head prefix concat ] map [ all-unique? ] filter ;
 
 : add-missing-digit ( seq -- seq )
-    dup natural-sort 10 swap diff first prefix ;
+    dup natural-sort 10 swap diff prepend ;
 
 : interesting-pandigitals ( -- seq )
     17 candidates { 13 11 7 5 3 2 } [
@@ -93,6 +92,6 @@ PRIVATE>
     interesting-pandigitals [ 10 digits>integer ] sigma ;
 
 ! [ euler043a ] 100 ave-time
-! 19 ms run / 1 ms GC ave time - 100 trials
+! 12 ms ave run time - 2.32 SD (100 trials)
 
 MAIN: euler043a
diff --git a/extra/project-euler/044/044.factor b/extra/project-euler/044/044.factor
index eaa6bf96ef..0af3a3167e 100644
--- a/extra/project-euler/044/044.factor
+++ b/extra/project-euler/044/044.factor
@@ -31,7 +31,7 @@ IN: project-euler.044
     dup 3 * 1- * 2 / ;
 
 : sum-and-diff? ( m n -- ? )
-    2dup + -rot - [ pentagonal? ] bi@ and ;
+    [ + ] [ - ] 2bi [ pentagonal? ] bi@ and ;
 
 PRIVATE>
 
@@ -40,7 +40,7 @@ PRIVATE>
     [ first2 sum-and-diff? ] filter [ first2 - abs ] map infimum ;
 
 ! [ euler044 ] 10 ave-time
-! 8924 ms run / 2872 ms GC ave time - 10 trials
+! 5727 ms ave run time - 1102.38 SD (10 trials)
 
 ! TODO: this solution is ugly and not very efficient...find a better algorithm
 
diff --git a/extra/project-euler/076/076.factor b/extra/project-euler/076/076.factor
index 3530f2163a..528cb656bb 100644
--- a/extra/project-euler/076/076.factor
+++ b/extra/project-euler/076/076.factor
@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Eric Mertens.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators kernel locals math math.order math.ranges
+USING: arrays assocs kernel locals.backend math math.order math.ranges
     sequences ;
 IN: project-euler.076
 
@@ -55,6 +55,6 @@ PRIVATE>
     100 (euler076) ;
 
 ! [ euler076 ] 100 ave-time
-! 704 ms run time - 100 trials
+! 560 ms ave run time - 17.74 SD (100 trials)
 
 MAIN: euler076
diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor
index 99c70ba038..29b76c7ba4 100644
--- a/extra/project-euler/079/079.factor
+++ b/extra/project-euler/079/079.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs hashtables io.files kernel math math.parser
-namespaces make io.encodings.ascii sequences sets ;
+USING: assocs io.encodings.ascii io.files kernel make math math.parser
+    sequences sets ;
 IN: project-euler.079
 
 ! http://projecteuler.net/index.php?section=problems&id=79
@@ -58,7 +58,7 @@ PRIVATE>
     source-079 >edges topological-sort 10 digits>integer ;
 
 ! [ euler079 ] 100 ave-time
-! 2 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 1.41 SD (100 trials)
 
 ! TODO: prune and diff are relatively slow; topological sort could be
 ! cleaned up and generalized much better, but it works for this problem
diff --git a/extra/project-euler/092/092.factor b/extra/project-euler/092/092.factor
index 7e44a509ab..ea131d6e1b 100644
--- a/extra/project-euler/092/092.factor
+++ b/extra/project-euler/092/092.factor
@@ -32,7 +32,7 @@ IN: project-euler.092
     0 swap [ dup zero? not ] [ 10 /mod sq -rot [ + ] dip ] [ ] while drop ;
 
 : chain-ending ( n -- m )
-    dup 1 = over 89 = or [ next-link chain-ending ] unless ;
+    dup [ 1 = ] [ 89 = ] bi or [ next-link chain-ending ] unless ;
 
 : lower-endings ( -- seq )
     567 [1,b] [ chain-ending ] map ;
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index c609d82747..d87aecb6a8 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel make math math.functions math.matrices math.miller-rabin
     math.order math.parser math.primes.factors math.ranges sequences
-    sequences.lib sorting unicode.case ;
+    sequences.lib sorting strings unicode.case ;
 IN: project-euler.common
 
 ! A collection of words used by more than one Project Euler solution

From 9152b6d5f0b1c47b9ffbc448eaa3315456f389b1 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Mon, 3 Nov 2008 18:25:50 -0500
Subject: [PATCH 114/318] Cleanup of Project Euler problem 92

---
 extra/project-euler/092/092.factor | 11 +++++------
 1 file changed, 5 insertions(+), 6 deletions(-)

diff --git a/extra/project-euler/092/092.factor b/extra/project-euler/092/092.factor
index ea131d6e1b..c778fd9525 100644
--- a/extra/project-euler/092/092.factor
+++ b/extra/project-euler/092/092.factor
@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences ;
+USING: kernel math math.ranges project-euler.common sequences ;
 IN: project-euler.092
 
 ! http://projecteuler.net/index.php?section=problems&id=92
@@ -29,7 +29,7 @@ IN: project-euler.092
 <PRIVATE
 
 : next-link ( n -- m )
-    0 swap [ dup zero? not ] [ 10 /mod sq -rot [ + ] dip ] [ ] while drop ;
+    number>digits [ sq ] sigma ;
 
 : chain-ending ( n -- m )
     dup [ 1 = ] [ 89 = ] bi or [ next-link chain-ending ] unless ;
@@ -40,15 +40,14 @@ IN: project-euler.092
 : fast-chain-ending ( seq n -- m )
     dup 567 > [ next-link ] when 1- swap nth ;
 
-: count ( seq quot -- n )
-    0 -rot [ rot >r call [ r> 1+ ] [ r> ] if ] curry each ; inline
-
 PRIVATE>
 
 : euler092 ( -- answer )
     lower-endings 9999999 [1,b] [ fast-chain-ending 89 = ] with count ;
 
 ! [ euler092 ] 10 ave-time
-! 11169 ms run / 0 ms GC ave time - 10 trials
+! 33257 ms ave run time - 624.27 SD (10 trials)
+
+! TODO: this solution is not very efficient, much better optimizations exist
 
 MAIN: euler092

From 9be67e7df7e27c5ea3189429d02b0bc0aea078bb Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Mon, 3 Nov 2008 19:02:57 -0500
Subject: [PATCH 115/318] Add meta data to Project Euler problem 186

---
 extra/project-euler/186/186.factor | 43 ++++++++++++++++++++++++++++--
 1 file changed, 41 insertions(+), 2 deletions(-)

diff --git a/extra/project-euler/186/186.factor b/extra/project-euler/186/186.factor
index 7504e09a81..b86f3675a1 100644
--- a/extra/project-euler/186/186.factor
+++ b/extra/project-euler/186/186.factor
@@ -1,7 +1,43 @@
-USING: circular disjoint-sets kernel math math.ranges
-sequences ;
+! Copyright (c) 2008 Eric Mertens.
+! See http://factorcode.org/license.txt for BSD license.
+USING: circular disjoint-sets kernel math math.ranges sequences ;
 IN: project-euler.186
 
+! http://projecteuler.net/index.php?section=problems&id=186
+
+! DESCRIPTION
+! -----------
+
+! Here are the records from a busy telephone system with one million users:
+
+!     RecNr  Caller  Called
+!     1      200007  100053
+!     2      600183  500439
+!     3      600863  701497
+!     ...    ...     ...
+
+! The telephone number of the caller and the called number in record n are
+! Caller(n) = S2n-1 and Called(n) = S2n where S1,2,3,... come from the "Lagged
+! Fibonacci Generator":
+
+! For 1 <= k <= 55, Sk = [100003 - 200003k + 300007k^3] (modulo 1000000)
+! For 56 <= k, Sk = [Sk-24 + Sk-55] (modulo 1000000)
+
+! If Caller(n) = Called(n) then the user is assumed to have misdialled and the
+! call fails; otherwise the call is successful.
+
+! From the start of the records, we say that any pair of users X and Y are
+! friends if X calls Y or vice-versa. Similarly, X is a friend of a friend of Z
+! if X is a friend of Y and Y is a friend of Z; and so on for longer chains.
+
+! The Prime Minister's phone number is 524287. After how many successful calls,
+! not counting misdials, will 99% of the users (including the PM) be a friend,
+! or a friend of a friend etc., of the Prime Minister?
+
+
+! SOLUTION
+! --------
+
 : (generator) ( k -- n )
     dup sq 300007 * 200003 - * 100003 + 1000000 rem ;
 
@@ -35,4 +71,7 @@ IN: project-euler.186
 : euler186 ( -- n )
     <generator> 0 1000000 <relation> (p186) ;
 
+! [ euler186 ] 10 ave-time
+! 18572 ms ave run time - 796.87 SD (10 trials)
+
 MAIN: euler186

From 9d063158098696097b0622d4c5f776a2567e9d73 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Mon, 3 Nov 2008 20:14:37 -0500
Subject: [PATCH 116/318] Clean up of common Project Euler code

---
 extra/project-euler/common/common.factor | 18 ++++++++++--------
 extra/project-euler/project-euler.factor | 12 ++++++------
 2 files changed, 16 insertions(+), 14 deletions(-)

diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index d87aecb6a8..d3263bbc1e 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -15,7 +15,7 @@ IN: project-euler.common
 ! log10 - #25, #134
 ! max-path - #18, #67
 ! nth-triangle - #12, #42
-! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56
+! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
 ! palindrome? - #4, #36, #55
 ! pandigital? - #32, #38
 ! pentagonal? - #44, #45
@@ -25,8 +25,8 @@ IN: project-euler.common
 ! [uad]-transform - #39, #75
 
 
-: nth-pair ( n seq -- nth next )
-    2dup [ 1+ ] dip [ nth ] 2bi@ ;
+: nth-pair ( seq n -- nth next )
+    tail-slice first2 ;
 
 : perfect-square? ( n -- ? )
     dup sqrt mod zero? ;
@@ -34,7 +34,7 @@ IN: project-euler.common
 <PRIVATE
 
 : max-children ( seq -- seq )
-    [ dup length 1- [ over nth-pair max , ] each ] { } make nip ;
+    [ dup length 1- [ nth-pair max , ] with each ] { } make ;
 
 ! Propagate one row into the upper one
 : propagate ( bottom top -- newtop )
@@ -84,8 +84,9 @@ PRIVATE>
 
 ! Not strictly needed, but it is nice to be able to dump the triangle after the
 ! propagation
-: propagate-all ( triangle -- newtriangle )
-    reverse [ first dup ] keep rest [ propagate dup ] map nip reverse swap suffix ;
+: propagate-all ( triangle -- new-triangle )
+    reverse [ first dup ] [ rest ] bi
+    [ propagate dup ] map nip reverse swap suffix ;
 
 : sum-divisors ( n -- sum )
     dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
@@ -108,8 +109,9 @@ PRIVATE>
 
 ! Optimized brute-force, is often faster than prime factorization
 : tau* ( m -- n )
-    factor-2s [ 1+ ] dip [ perfect-square? -1 0 ? ] keep
-    dup sqrt >fixnum [1,b] [
+    factor-2s dup [ 1+ ]
+    [ perfect-square? -1 0 ? ]
+    [ dup sqrt >fixnum [1,b] ] tri* [
         dupd mod zero? [ [ 2 + ] dip ] when
     ] each drop * ;
 
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index 9dfaad0e7b..5192e23a27 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -14,12 +14,12 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time
     project-euler.037 project-euler.038 project-euler.039 project-euler.040
     project-euler.041 project-euler.042 project-euler.043 project-euler.044
     project-euler.045 project-euler.046 project-euler.047 project-euler.048
-    project-euler.052 project-euler.053 project-euler.056 project-euler.059
-    project-euler.067 project-euler.075 project-euler.079 project-euler.092
-    project-euler.097 project-euler.100 project-euler.116 project-euler.117
-    project-euler.134 project-euler.148 project-euler.150 project-euler.151
-    project-euler.164 project-euler.169 project-euler.173 project-euler.175
-    project-euler.186 project-euler.190 ;
+    project-euler.052 project-euler.053 project-euler.055 project-euler.056
+    project-euler.059 project-euler.067 project-euler.075 project-euler.076
+    project-euler.079 project-euler.092 project-euler.097 project-euler.100
+    project-euler.116 project-euler.117 project-euler.134 project-euler.148
+    project-euler.150 project-euler.151 project-euler.164 project-euler.169
+    project-euler.173 project-euler.175 project-euler.186 project-euler.190 ;
 IN: project-euler
 
 <PRIVATE

From 06b99c31eec7254cc5793483e3170bc0a6f9cf30 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 20:59:48 -0600
Subject: [PATCH 117/318] Fix regression. If a parsing word called the
 compiler, it might compile a caller of a generic before the generic gets
 built, which would throw an error since the inferred effect of the generic
 might have less inputs than the combination's dispatch#

---
 basis/compiler/tests/peg-regression.factor    | 26 +++++++++++++++++++
 .../tree/propagation/inlining/inlining.factor |  9 +++++++
 2 files changed, 35 insertions(+)
 create mode 100644 basis/compiler/tests/peg-regression.factor

diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor
new file mode 100644
index 0000000000..a0262fdc81
--- /dev/null
+++ b/basis/compiler/tests/peg-regression.factor
@@ -0,0 +1,26 @@
+! Calling the compiler at parse time and having it compile
+! generic words defined in the current compilation unit would
+! fail. This is a regression from the 'remake-generic'
+! optimization, which would batch generic word updates at the
+! end of a compilation unit.
+
+USING: kernel accessors peg.ebnf ;
+IN: compiler.tests
+
+TUPLE: pipeline-expr background ;
+
+GENERIC: blah ( a -- b )
+
+M: pipeline-expr blah ;
+
+: ast>pipeline-expr ( -- obj )
+    pipeline-expr new blah ;
+
+EBNF: expr
+pipeline = "hello" => [[ ast>pipeline-expr ]]
+;EBNF
+
+USE: tools.test
+
+[ t ] [ \ expr compiled>> ] unit-test
+[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 197d1820bf..130b94cf6b 100644
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -164,7 +164,16 @@ SYMBOL: history
     first object swap eliminate-dispatch ;
 
 : do-inlining ( #call word -- ? )
+    #! If the generic was defined in an outer compilation unit,
+    #! then it doesn't have a definition yet; the definition
+    #! is built at the end of the compilation unit. We do not
+    #! attempt inlining at this stage since the stack discipline
+    #! is not finalized yet, so dispatch# might return an out
+    #! of bounds value. This case comes up if a parsing word
+    #! calls the compiler at parse time (doing so is
+    #! discouraged, but it should still work.)
     {
+        { [ dup deferred? ] [ 2drop f ] }
         { [ dup custom-inlining? ] [ inline-custom ] }
         { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }

From 3e75e0f8b5d309059a521e8bcb6404c8710afe52 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 21:00:27 -0600
Subject: [PATCH 118/318] Update word naming conventions

---
 basis/help/handbook/handbook.factor | 9 ++++++---
 1 file changed, 6 insertions(+), 3 deletions(-)

diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor
index c1505705da..6aa19d43d5 100644
--- a/basis/help/handbook/handbook.factor
+++ b/basis/help/handbook/handbook.factor
@@ -4,7 +4,8 @@ prettyprint.backend kernel.private io generic math system
 strings sbufs vectors byte-arrays quotations
 io.streams.byte-array classes.builtin parser lexer
 classes.predicate classes.union classes.intersection
-classes.singleton classes.tuple tools.vocabs.browser ;
+classes.singleton classes.tuple tools.vocabs.browser math.parser
+accessors ;
 IN: help.handbook
 
 ARTICLE: "conventions" "Conventions"
@@ -26,12 +27,14 @@ $nl
     { { $snippet { $emphasis "foo" } "?" } "outputs a boolean" { { $link empty? } } }
     { { $snippet "?" { $emphasis "foo" } } { "conditionally performs " { $snippet { $emphasis "foo" } } } { { $links ?nth } } }
     { { $snippet "<" { $emphasis "foo" } ">" } { "creates a new " { $snippet "foo" } } { { $link <array> } } }
+    { { $snippet ">" { $emphasis "foo" } } { "converts the top of the stack into a " { $snippet "foo" } } { { $link >array } } }
+    { { $snippet { $emphasis "foo" } ">" { $emphasis "bar" } } { "converts a " { $snippet "foo" } " into a " { $snippet "bar" } } { { $link number>string } } }
     { { $snippet "new-" { $emphasis "foo" } } { "creates a new " { $snippet "foo" } ", taking some kind of parameter from the stack which determines the type of the object to be created" } { { $link new-sequence } ", " { $link new-lexer } ", " { $link new } } }
     { { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } }
     { { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } }
     { { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } }
-    { { $snippet { $emphasis "foo" } "-" { $emphasis "bar" } } { "(tuple accessors) outputs the value of the " { $snippet "bar" } " slot of the " { $snippet "foo" } " at the top of the stack" } { } }
-    { { $snippet "set-" { $emphasis "foo" } "-" { $emphasis "bar" } } { "(tuple mutators) sets the value of the " { $snippet "bar" } " slot of the " { $snippet "foo" } " at the top of the stack" } { } }
+    { { $snippet { $emphasis "foo" } ">>" } { "gets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link >>name } } }
+    { { $snippet ">>" { $emphasis "foo" } } { "sets the " { $snippet "foo" } " slot of the tuple at the top of the stack; see " { $link "accessors" } } { { $link name>> } } }
     { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-input-stream with-output-stream } }
     { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } }
 }

From b4d3473d5eb2a01e1707be0c2af757224a302927 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 21:01:50 -0600
Subject: [PATCH 119/318] Tuple parsing didn't handle line breaks properly; if
 scan returns f, must throw unexpected-eof

---
 core/classes/tuple/parser/parser-tests.factor | 33 +++++++++++++++++++
 core/classes/tuple/parser/parser.factor       | 11 +++++--
 2 files changed, 41 insertions(+), 3 deletions(-)

diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index 6b9a953ab9..22b5784269 100644
--- a/core/classes/tuple/parser/parser-tests.factor
+++ b/core/classes/tuple/parser/parser-tests.factor
@@ -109,3 +109,36 @@ TUPLE: parsing-corner-case x ;
         "}"
     } "\n" join eval
 ] unit-test
+
+[ T{ parsing-corner-case f 3 } ] [
+    {
+        "USE: classes.tuple.parser.tests"
+        "T{ parsing-corner-case"
+        "    { x 3 }"
+        "}"
+    } "\n" join eval
+] unit-test
+
+[ T{ parsing-corner-case f 3 } ] [
+    {
+        "USE: classes.tuple.parser.tests"
+        "T{ parsing-corner-case {"
+        "    x 3 }"
+        "}"
+    } "\n" join eval
+] unit-test
+
+
+[
+    {
+        "USE: classes.tuple.parser.tests T{ parsing-corner-case"
+        "    { x 3 }"
+    } "\n" join eval
+] [ error>> unexpected-eof? ] must-fail-with
+
+[
+    {
+        "USE: classes.tuple.parser.tests T{ parsing-corner-case {"
+        "    x 3 }"
+    } "\n" join eval
+] [ error>> unexpected-eof? ] must-fail-with
diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor
index 7888635641..659195edbf 100644
--- a/core/classes/tuple/parser/parser.factor
+++ b/core/classes/tuple/parser/parser.factor
@@ -60,14 +60,19 @@ ERROR: invalid-slot-name name ;
     dup check-duplicate-slots
     3dup check-slot-shadowing ;
 
-: parse-slot-value ( -- )
-    scan scan-object 2array , scan "}" assert= ;
-
 ERROR: bad-literal-tuple ;
 
+: parse-slot-value ( -- )
+    scan scan-object 2array , scan {
+        { f [ unexpected-eof ] }
+        { "}" [ ] }
+        [ bad-literal-tuple ]
+    } case ;
+
 : (parse-slot-values) ( -- )
     parse-slot-value
     scan {
+        { f [ unexpected-eof ] }
         { "{" [ (parse-slot-values) ] }
         { "}" [ ] }
         [ bad-literal-tuple ]

From efcb916e35df0890d8ef67870d807134d3abc147 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 3 Nov 2008 21:02:34 -0600
Subject: [PATCH 120/318] Handle a jump to a jump by cloning the block, in the
 same way we optimize jumps to returns

---
 basis/compiler/cfg/linearization/linearization.factor | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index d8f5d35ed4..d397c9d448 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -20,16 +20,17 @@ M: insn linearize-insn , drop ;
     #! don't need to branch.
     [ number>> ] bi@ 1- = ; inline
 
-: branch-to-return? ( successor -- ? )
-    #! A branch to a block containing just a return is cloned.
+: branch-to-branch? ( successor -- ? )
+    #! A branch to a block containing just a jump return is cloned.
     instructions>> dup length 2 = [
-        [ first ##epilogue? ] [ second ##return? ] bi and
+        [ first ##epilogue? ]
+        [ second [ ##return? ] [ ##jump? ] bi or ] bi and
     ] [ drop f ] if ;
 
 : emit-branch ( basic-block successor -- )
     {
         { [ 2dup useless-branch? ] [ 2drop ] }
-        { [ dup branch-to-return? ] [ nip linearize-insns ] }
+        { [ dup branch-to-branch? ] [ nip linearize-insns ] }
         [ nip number>> _branch ]
     } cond ;
 

From e923ec16d37af003931b80c8632a176f38b0acea Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Mon, 3 Nov 2008 22:56:32 -0500
Subject: [PATCH 121/318] Rewrite of collect-benchmarks in ave-time vocab

---
 extra/project-euler/ave-time/ave-time.factor | 17 +++++++++--------
 1 file changed, 9 insertions(+), 8 deletions(-)

diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor
index df96d5e211..2a516513a5 100644
--- a/extra/project-euler/ave-time/ave-time.factor
+++ b/extra/project-euler/ave-time/ave-time.factor
@@ -1,20 +1,21 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: continuations io kernel math math.functions math.parser math.statistics
-    namespaces make tools.time ;
+USING: continuations fry io kernel make math math.functions math.parser
+    math.statistics memory tools.time ;
 IN: project-euler.ave-time
 
 : collect-benchmarks ( quot n -- seq )
-  [
-    >r >r datastack r> [ benchmark , ] curry tuck
-    [ with-datastack drop ] 2curry r> swap times call
-  ] { } make ;
+    [
+        [ datastack ]
+        [ '[ _ gc benchmark , ] tuck '[ _ _ with-datastack drop ] ]
+        [ 1- ] tri* swap times call
+    ] { } make ;
 
 : nth-place ( x n -- y )
     10 swap ^ [ * round ] keep / ;
 
 : ave-time ( quot n -- )
-    [ collect-benchmarks ] keep
-    swap [ std 2 nth-place ] [ mean round ] bi [
+    [ collect-benchmarks ] keep swap
+    [ std 2 nth-place ] [ mean round ] bi [
         # " ms ave run time - " % # " SD (" % # " trials)" %
     ] "" make print flush ; inline

From e763b5a3353085237f02917516746a196aef6457 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Tue, 4 Nov 2008 01:04:03 -0500
Subject: [PATCH 122/318] Add unit tests for Project Euler

---
 extra/project-euler/001/001-tests.factor |  6 ++++++
 extra/project-euler/002/002-tests.factor |  5 +++++
 extra/project-euler/002/002.factor       | 11 ++++++-----
 extra/project-euler/003/003-tests.factor |  4 ++++
 extra/project-euler/003/003.factor       |  6 +++---
 extra/project-euler/004/004-tests.factor |  4 ++++
 extra/project-euler/004/004.factor       |  2 +-
 extra/project-euler/005/005-tests.factor |  4 ++++
 extra/project-euler/005/005.factor       |  2 +-
 extra/project-euler/006/006-tests.factor |  4 ++++
 extra/project-euler/007/007-tests.factor |  4 ++++
 extra/project-euler/007/007.factor       |  2 +-
 extra/project-euler/076/076.factor       |  3 +--
 13 files changed, 44 insertions(+), 13 deletions(-)
 create mode 100644 extra/project-euler/001/001-tests.factor
 create mode 100644 extra/project-euler/002/002-tests.factor
 create mode 100644 extra/project-euler/003/003-tests.factor
 create mode 100644 extra/project-euler/004/004-tests.factor
 create mode 100644 extra/project-euler/005/005-tests.factor
 create mode 100644 extra/project-euler/006/006-tests.factor
 create mode 100644 extra/project-euler/007/007-tests.factor

diff --git a/extra/project-euler/001/001-tests.factor b/extra/project-euler/001/001-tests.factor
new file mode 100644
index 0000000000..8d2461a510
--- /dev/null
+++ b/extra/project-euler/001/001-tests.factor
@@ -0,0 +1,6 @@
+USING: project-euler.001 tools.test ;
+IN: project-euler.001.tests
+
+[ 233168 ] [ euler001 ] unit-test
+[ 233168 ] [ euler001a ] unit-test
+[ 233168 ] [ euler001b ] unit-test
diff --git a/extra/project-euler/002/002-tests.factor b/extra/project-euler/002/002-tests.factor
new file mode 100644
index 0000000000..bb02518580
--- /dev/null
+++ b/extra/project-euler/002/002-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.002 tools.test ;
+IN: project-euler.002.tests
+
+[ 4613732 ] [ euler002 ] unit-test
+[ 4613732 ] [ euler002a ] unit-test
diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor
index 7bd77a2f68..fae535cba9 100644
--- a/extra/project-euler/002/002.factor
+++ b/extra/project-euler/002/002.factor
@@ -13,7 +13,8 @@ IN: project-euler.002
 
 !     1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...
 
-! Find the sum of all the even-valued terms in the sequence which do not exceed one million.
+! Find the sum of all the even-valued terms in the sequence which do not exceed
+! four million.
 
 
 ! SOLUTION
@@ -30,10 +31,10 @@ PRIVATE>
     V{ 0 } clone 1 rot (fib-upto) ;
 
 : euler002 ( -- answer )
-    1000000 fib-upto [ even? ] filter sum ;
+    4000000 fib-upto [ even? ] filter sum ;
 
 ! [ euler002 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.22 SD (100 trials)
 
 
 ! ALTERNATE SOLUTIONS
@@ -44,9 +45,9 @@ PRIVATE>
     but-last-slice { 0 1 } prepend ;
 
 : euler002a ( -- answer )
-    1000000 fib-upto* [ even? ] filter sum ;
+    4000000 fib-upto* [ even? ] filter sum ;
 
 ! [ euler002a ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.2 SD (100 trials)
 
 MAIN: euler002a
diff --git a/extra/project-euler/003/003-tests.factor b/extra/project-euler/003/003-tests.factor
new file mode 100644
index 0000000000..ab136a8c20
--- /dev/null
+++ b/extra/project-euler/003/003-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.003 tools.test ;
+IN: project-euler.003.tests
+
+[ 6857 ] [ euler003 ] unit-test
diff --git a/extra/project-euler/003/003.factor b/extra/project-euler/003/003.factor
index afc4069aee..09374bcee3 100644
--- a/extra/project-euler/003/003.factor
+++ b/extra/project-euler/003/003.factor
@@ -10,16 +10,16 @@ IN: project-euler.003
 
 ! The prime factors of 13195 are 5, 7, 13 and 29.
 
-! What is the largest prime factor of the number 317584931803?
+! What is the largest prime factor of the number 600851475143 ?
 
 
 ! SOLUTION
 ! --------
 
 : euler003 ( -- answer )
-    317584931803 factors supremum ;
+    600851475143 factors supremum ;
 
 ! [ euler003 ] 100 ave-time
-! 1 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.49 SD (100 trials)
 
 MAIN: euler003
diff --git a/extra/project-euler/004/004-tests.factor b/extra/project-euler/004/004-tests.factor
new file mode 100644
index 0000000000..6640e7e411
--- /dev/null
+++ b/extra/project-euler/004/004-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.004 tools.test ;
+IN: project-euler.004.tests
+
+[ 906609 ] [ euler004 ] unit-test
diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor
index 1f268f1500..eb5f97b2de 100644
--- a/extra/project-euler/004/004.factor
+++ b/extra/project-euler/004/004.factor
@@ -32,6 +32,6 @@ PRIVATE>
     source-004 dup cartesian-product [ product ] map prune max-palindrome ;
 
 ! [ euler004 ] 100 ave-time
-! 1608 ms run / 102 ms GC ave time - 100 trials
+! 1164 ms ave run time - 39.35 SD (100 trials)
 
 MAIN: euler004
diff --git a/extra/project-euler/005/005-tests.factor b/extra/project-euler/005/005-tests.factor
new file mode 100644
index 0000000000..1d17b2e432
--- /dev/null
+++ b/extra/project-euler/005/005-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.005 tools.test ;
+IN: project-euler.005.tests
+
+[ 232792560 ] [ euler005 ] unit-test
diff --git a/extra/project-euler/005/005.factor b/extra/project-euler/005/005.factor
index 0d8f11f243..8b446f2376 100644
--- a/extra/project-euler/005/005.factor
+++ b/extra/project-euler/005/005.factor
@@ -21,6 +21,6 @@ IN: project-euler.005
     20 1 [ 1+ lcm ] reduce ;
 
 ! [ euler005 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.14 SD (100 trials)
 
 MAIN: euler005
diff --git a/extra/project-euler/006/006-tests.factor b/extra/project-euler/006/006-tests.factor
new file mode 100644
index 0000000000..56fbbd3421
--- /dev/null
+++ b/extra/project-euler/006/006-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.006 tools.test ;
+IN: project-euler.006.tests
+
+[ 25164150 ] [ euler006 ] unit-test
diff --git a/extra/project-euler/007/007-tests.factor b/extra/project-euler/007/007-tests.factor
new file mode 100644
index 0000000000..ab2bf1547c
--- /dev/null
+++ b/extra/project-euler/007/007-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.007 tools.test ;
+IN: project-euler.007.tests
+
+[ 104743 ] [ euler007 ] unit-test
diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor
index 04686a8328..f2b659fe94 100644
--- a/extra/project-euler/007/007.factor
+++ b/extra/project-euler/007/007.factor
@@ -24,6 +24,6 @@ IN: project-euler.007
     10001 nth-prime ;
 
 ! [ euler007 ] 100 ave-time
-! 10 ms run / 0 ms GC ave time - 100 trials
+! 5 ms ave run time - 1.13 SD (100 trials)
 
 MAIN: euler007
diff --git a/extra/project-euler/076/076.factor b/extra/project-euler/076/076.factor
index 528cb656bb..e332d9ef3e 100644
--- a/extra/project-euler/076/076.factor
+++ b/extra/project-euler/076/076.factor
@@ -1,7 +1,6 @@
 ! Copyright (c) 2008 Eric Mertens.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel locals.backend math math.order math.ranges
-    sequences ;
+USING: arrays assocs kernel locals math math.order math.ranges sequences ;
 IN: project-euler.076
 
 ! http://projecteuler.net/index.php?section=problems&id=76

From 72b34c7b476b3c7d15f91edd6b055b069aab11af Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Tue, 4 Nov 2008 00:04:18 -0600
Subject: [PATCH 123/318] Fix visibility of check_sse2 symbol; DDLEXPORT
 doesn't work in gas source

---
 vm/cpu-x86.32.S | 5 +++++
 vm/cpu-x86.32.h | 2 --
 2 files changed, 5 insertions(+), 2 deletions(-)
 mode change 100644 => 100755 vm/cpu-x86.32.S
 mode change 100644 => 100755 vm/cpu-x86.32.h

diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S
old mode 100644
new mode 100755
index 3e7e5c20e1..d903f8013d
--- a/vm/cpu-x86.32.S
+++ b/vm/cpu-x86.32.S
@@ -51,3 +51,8 @@ DEF(bool,check_sse2,(void)):
 	ret
 
 #include "cpu-x86.S"
+
+#ifdef WINDOWS
+	.section .drectve
+	.ascii " -export:check_sse2"
+#endif
diff --git a/vm/cpu-x86.32.h b/vm/cpu-x86.32.h
old mode 100644
new mode 100755
index 1d516c4703..21f07cf2b4
--- a/vm/cpu-x86.32.h
+++ b/vm/cpu-x86.32.h
@@ -4,5 +4,3 @@ register CELL ds asm("esi");
 register CELL rs asm("edi");
 
 #define F_FASTCALL __attribute__ ((regparm (2)))
-
-DLLEXPORT bool check_sse2(void);

From 1af3b8ed656afedc1b31b2fbd62627f69295eb9c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 4 Nov 2008 00:32:56 -0600
Subject: [PATCH 124/318] If a register is spilled and the reload location is
 also a copy, we chicken out and don't coalesce. This is suboptimal but it's
 not clear to me how to implement it cleanly, and SSA graph coloring will
 solve this problem eventually anyway

---
 .../linear-scan/allocation/allocation.factor  |   6 +-
 .../cfg/linear-scan/linear-scan-tests.factor  | 848 ++++++++++++++++++
 2 files changed, 851 insertions(+), 3 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 7944415cbc..d75d5649cb 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -58,11 +58,11 @@ SYMBOL: progress
 
 ! Coalescing
 : active-interval ( vreg -- live-interval )
-    dup active-intervals-for [ vreg>> = ] with find nip ;
+    dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
 
 : coalesce? ( live-interval -- ? )
-    [ start>> ] [ copy-from>> ] bi
-    dup [ active-interval end>> = ] [ 2drop f ] if ;
+    [ start>> ] [ copy-from>> active-interval ] bi
+    dup [ end>> = ] [ 2drop f ] if ;
 
 : coalesce ( live-interval -- )
     dup copy-from>> active-interval
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index af2e81b767..948302c74b 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -355,3 +355,851 @@ USING: math.private compiler.cfg.debugger ;
     { { int-regs { 0 1 2 3 } } }
     allocate-registers drop
 ] unit-test
+
+[ ] [
+    {
+        T{ live-interval
+            { vreg V int-regs 3687168 }
+            { start 106 }
+            { end 112 }
+            { uses V{ 106 112 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687169 }
+            { start 107 }
+            { end 113 }
+            { uses V{ 107 113 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687727 }
+            { start 190 }
+            { end 198 }
+            { uses V{ 190 195 198 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686445 }
+            { start 43 }
+            { end 44 }
+            { uses V{ 43 44 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686195 }
+            { start 5 }
+            { end 11 }
+            { uses V{ 5 11 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686449 }
+            { start 44 }
+            { end 56 }
+            { uses V{ 44 45 45 46 56 } }
+            { copy-from V int-regs 3686445 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686198 }
+            { start 8 }
+            { end 10 }
+            { uses V{ 8 9 10 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686454 }
+            { start 46 }
+            { end 49 }
+            { uses V{ 46 47 47 49 } }
+            { copy-from V int-regs 3686449 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686196 }
+            { start 6 }
+            { end 12 }
+            { uses V{ 6 12 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686197 }
+            { start 7 }
+            { end 14 }
+            { uses V{ 7 13 14 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686455 }
+            { start 48 }
+            { end 51 }
+            { uses V{ 48 51 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686463 }
+            { start 52 }
+            { end 53 }
+            { uses V{ 52 53 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686460 }
+            { start 49 }
+            { end 52 }
+            { uses V{ 49 50 50 52 } }
+            { copy-from V int-regs 3686454 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686461 }
+            { start 51 }
+            { end 71 }
+            { uses V{ 51 52 64 68 71 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686464 }
+            { start 53 }
+            { end 54 }
+            { uses V{ 53 54 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686465 }
+            { start 54 }
+            { end 76 }
+            { uses V{ 54 55 55 76 } }
+            { copy-from V int-regs 3686464 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686470 }
+            { start 58 }
+            { end 60 }
+            { uses V{ 58 59 59 60 } }
+            { copy-from V int-regs 3686469 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686469 }
+            { start 56 }
+            { end 58 }
+            { uses V{ 56 57 57 58 } }
+            { copy-from V int-regs 3686449 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686473 }
+            { start 60 }
+            { end 62 }
+            { uses V{ 60 61 61 62 } }
+            { copy-from V int-regs 3686470 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686479 }
+            { start 62 }
+            { end 64 }
+            { uses V{ 62 63 63 64 } }
+            { copy-from V int-regs 3686473 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686735 }
+            { start 78 }
+            { end 96 }
+            { uses V{ 78 79 79 96 } }
+            { copy-from V int-regs 3686372 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686482 }
+            { start 64 }
+            { end 65 }
+            { uses V{ 64 65 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686483 }
+            { start 65 }
+            { end 66 }
+            { uses V{ 65 66 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687510 }
+            { start 168 }
+            { end 171 }
+            { uses V{ 168 171 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687511 }
+            { start 169 }
+            { end 176 }
+            { uses V{ 169 176 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686484 }
+            { start 66 }
+            { end 75 }
+            { uses V{ 66 67 67 75 } }
+            { copy-from V int-regs 3686483 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687509 }
+            { start 162 }
+            { end 163 }
+            { uses V{ 162 163 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686491 }
+            { start 68 }
+            { end 69 }
+            { uses V{ 68 69 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687512 }
+            { start 170 }
+            { end 178 }
+            { uses V{ 170 177 178 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687515 }
+            { start 172 }
+            { end 173 }
+            { uses V{ 172 173 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686492 }
+            { start 69 }
+            { end 74 }
+            { uses V{ 69 70 70 74 } }
+            { copy-from V int-regs 3686491 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687778 }
+            { start 202 }
+            { end 208 }
+            { uses V{ 202 208 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686499 }
+            { start 71 }
+            { end 72 }
+            { uses V{ 71 72 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687520 }
+            { start 174 }
+            { end 175 }
+            { uses V{ 174 175 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687779 }
+            { start 203 }
+            { end 209 }
+            { uses V{ 203 209 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687782 }
+            { start 206 }
+            { end 207 }
+            { uses V{ 206 207 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686503 }
+            { start 74 }
+            { end 75 }
+            { uses V{ 74 75 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686500 }
+            { start 72 }
+            { end 74 }
+            { uses V{ 72 73 73 74 } }
+            { copy-from V int-regs 3686499 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687780 }
+            { start 204 }
+            { end 210 }
+            { uses V{ 204 210 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686506 }
+            { start 75 }
+            { end 76 }
+            { uses V{ 75 76 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687530 }
+            { start 185 }
+            { end 192 }
+            { uses V{ 185 192 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687528 }
+            { start 183 }
+            { end 198 }
+            { uses V{ 183 198 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687529 }
+            { start 184 }
+            { end 197 }
+            { uses V{ 184 197 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687781 }
+            { start 205 }
+            { end 211 }
+            { uses V{ 205 211 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687535 }
+            { start 187 }
+            { end 194 }
+            { uses V{ 187 194 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686252 }
+            { start 9 }
+            { end 17 }
+            { uses V{ 9 15 17 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686509 }
+            { start 76 }
+            { end 90 }
+            { uses V{ 76 87 90 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687532 }
+            { start 186 }
+            { end 196 }
+            { uses V{ 186 196 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687538 }
+            { start 188 }
+            { end 193 }
+            { uses V{ 188 193 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687827 }
+            { start 217 }
+            { end 219 }
+            { uses V{ 217 219 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687825 }
+            { start 215 }
+            { end 218 }
+            { uses V{ 215 216 218 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687831 }
+            { start 218 }
+            { end 219 }
+            { uses V{ 218 219 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686296 }
+            { start 16 }
+            { end 18 }
+            { uses V{ 16 18 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686302 }
+            { start 29 }
+            { end 31 }
+            { uses V{ 29 31 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687838 }
+            { start 231 }
+            { end 232 }
+            { uses V{ 231 232 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686300 }
+            { start 26 }
+            { end 27 }
+            { uses V{ 26 27 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686301 }
+            { start 27 }
+            { end 30 }
+            { uses V{ 27 28 28 30 } }
+            { copy-from V int-regs 3686300 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686306 }
+            { start 37 }
+            { end 93 }
+            { uses V{ 37 82 93 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686307 }
+            { start 38 }
+            { end 88 }
+            { uses V{ 38 85 88 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687837 }
+            { start 222 }
+            { end 223 }
+            { uses V{ 222 223 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686305 }
+            { start 36 }
+            { end 81 }
+            { uses V{ 36 42 77 81 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686310 }
+            { start 39 }
+            { end 95 }
+            { uses V{ 39 84 95 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687836 }
+            { start 227 }
+            { end 228 }
+            { uses V{ 227 228 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687839 }
+            { start 239 }
+            { end 246 }
+            { uses V{ 239 245 246 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687841 }
+            { start 240 }
+            { end 241 }
+            { uses V{ 240 241 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687845 }
+            { start 241 }
+            { end 243 }
+            { uses V{ 241 243 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686315 }
+            { start 40 }
+            { end 94 }
+            { uses V{ 40 83 94 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687846 }
+            { start 242 }
+            { end 245 }
+            { uses V{ 242 245 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687849 }
+            { start 243 }
+            { end 245 }
+            { uses V{ 243 244 244 245 } }
+            { copy-from V int-regs 3687845 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687850 }
+            { start 245 }
+            { end 245 }
+            { uses V{ 245 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687851 }
+            { start 246 }
+            { end 246 }
+            { uses V{ 246 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687852 }
+            { start 246 }
+            { end 246 }
+            { uses V{ 246 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687853 }
+            { start 247 }
+            { end 248 }
+            { uses V{ 247 248 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687854 }
+            { start 249 }
+            { end 250 }
+            { uses V{ 249 250 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687855 }
+            { start 258 }
+            { end 259 }
+            { uses V{ 258 259 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687080 }
+            { start 280 }
+            { end 285 }
+            { uses V{ 280 285 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687081 }
+            { start 281 }
+            { end 286 }
+            { uses V{ 281 286 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687082 }
+            { start 282 }
+            { end 287 }
+            { uses V{ 282 287 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687083 }
+            { start 283 }
+            { end 288 }
+            { uses V{ 283 288 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687085 }
+            { start 284 }
+            { end 299 }
+            { uses V{ 284 285 286 287 288 296 299 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687086 }
+            { start 284 }
+            { end 284 }
+            { uses V{ 284 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687087 }
+            { start 289 }
+            { end 293 }
+            { uses V{ 289 293 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687088 }
+            { start 290 }
+            { end 294 }
+            { uses V{ 290 294 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687089 }
+            { start 291 }
+            { end 297 }
+            { uses V{ 291 297 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687090 }
+            { start 292 }
+            { end 298 }
+            { uses V{ 292 298 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687363 }
+            { start 118 }
+            { end 119 }
+            { uses V{ 118 119 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686599 }
+            { start 77 }
+            { end 89 }
+            { uses V{ 77 86 89 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687370 }
+            { start 131 }
+            { end 132 }
+            { uses V{ 131 132 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687371 }
+            { start 138 }
+            { end 143 }
+            { uses V{ 138 143 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687368 }
+            { start 127 }
+            { end 128 }
+            { uses V{ 127 128 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687369 }
+            { start 122 }
+            { end 123 }
+            { uses V{ 122 123 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687373 }
+            { start 139 }
+            { end 140 }
+            { uses V{ 139 140 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686352 }
+            { start 41 }
+            { end 91 }
+            { uses V{ 41 43 79 91 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687377 }
+            { start 140 }
+            { end 141 }
+            { uses V{ 140 141 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687382 }
+            { start 143 }
+            { end 143 }
+            { uses V{ 143 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687383 }
+            { start 144 }
+            { end 161 }
+            { uses V{ 144 159 161 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687380 }
+            { start 141 }
+            { end 143 }
+            { uses V{ 141 142 142 143 } }
+            { copy-from V int-regs 3687377 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687381 }
+            { start 143 }
+            { end 160 }
+            { uses V{ 143 160 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687384 }
+            { start 145 }
+            { end 158 }
+            { uses V{ 145 158 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687385 }
+            { start 146 }
+            { end 157 }
+            { uses V{ 146 157 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687640 }
+            { start 189 }
+            { end 191 }
+            { uses V{ 189 191 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687388 }
+            { start 147 }
+            { end 152 }
+            { uses V{ 147 152 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687393 }
+            { start 148 }
+            { end 153 }
+            { uses V{ 148 153 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687398 }
+            { start 149 }
+            { end 154 }
+            { uses V{ 149 154 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686372 }
+            { start 42 }
+            { end 92 }
+            { uses V{ 42 45 78 80 92 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687140 }
+            { start 293 }
+            { end 295 }
+            { uses V{ 293 294 294 295 } }
+            { copy-from V int-regs 3687087 }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687403 }
+            { start 150 }
+            { end 155 }
+            { uses V{ 150 155 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687150 }
+            { start 304 }
+            { end 306 }
+            { uses V{ 304 306 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687151 }
+            { start 305 }
+            { end 307 }
+            { uses V{ 305 307 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687408 }
+            { start 151 }
+            { end 156 }
+            { uses V{ 151 156 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687153 }
+            { start 312 }
+            { end 313 }
+            { uses V{ 312 313 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686902 }
+            { start 267 }
+            { end 272 }
+            { uses V{ 267 272 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686903 }
+            { start 268 }
+            { end 273 }
+            { uses V{ 268 273 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686900 }
+            { start 265 }
+            { end 270 }
+            { uses V{ 265 270 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686901 }
+            { start 266 }
+            { end 271 }
+            { uses V{ 266 271 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687162 }
+            { start 100 }
+            { end 119 }
+            { uses V{ 100 114 117 119 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687163 }
+            { start 101 }
+            { end 118 }
+            { uses V{ 101 115 116 118 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3686904 }
+            { start 269 }
+            { end 274 }
+            { uses V{ 269 274 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687166 }
+            { start 104 }
+            { end 110 }
+            { uses V{ 104 110 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687167 }
+            { start 105 }
+            { end 111 }
+            { uses V{ 105 111 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687164 }
+            { start 102 }
+            { end 108 }
+            { uses V{ 102 108 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 3687165 }
+            { start 103 }
+            { end 109 }
+            { uses V{ 103 109 } }
+        }
+    }
+    { { int-regs { 0 1 2 3 4 } } }
+    allocate-registers drop
+] unit-test
+
+! A reduction of the above
+[ ] [
+    {
+        T{ live-interval
+            { vreg V int-regs 6449 }
+            { start 44 }
+            { end 56 }
+            { uses V{ 44 45 46 56 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 6454 }
+            { start 46 }
+            { end 49 }
+            { uses V{ 46 47 49 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 6455 }
+            { start 48 }
+            { end 51 }
+            { uses V{ 48 51 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 6460 }
+            { start 49 }
+            { end 52 }
+            { uses V{ 49 50 52 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 6461 }
+            { start 51 }
+            { end 71 }
+            { uses V{ 51 52 64 68 71 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 6464 }
+            { start 53 }
+            { end 54 }
+            { uses V{ 53 54 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 6470 }
+            { start 58 }
+            { end 60 }
+            { uses V{ 58 59 60 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 6469 }
+            { start 56 }
+            { end 58 }
+            { uses V{ 56 57 58 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 6473 }
+            { start 60 }
+            { end 62 }
+            { uses V{ 60 61 62 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 6479 }
+            { start 62 }
+            { end 64 }
+            { uses V{ 62 63 64 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 6735 }
+            { start 78 }
+            { end 96 }
+            { uses V{ 78 79 96 } }
+            { copy-from V int-regs 6372 }
+        }
+        T{ live-interval
+            { vreg V int-regs 6483 }
+            { start 65 }
+            { end 66 }
+            { uses V{ 65 66 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 7845 }
+            { start 91 }
+            { end 93 }
+            { uses V{ 91 93 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 6372 }
+            { start 42 }
+            { end 92 }
+            { uses V{ 42 45 78 80 92 } }
+        }
+    }
+    { { int-regs { 0 1 2 3 } } }
+    allocate-registers drop
+] unit-test

From 4a37bcb7572b83bc4838a2d86d64592e214c8a42 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 4 Nov 2008 00:36:16 -0600
Subject: [PATCH 125/318] Strip out remake-generics-hook, since otherwise it
 slurps in a lot of meta-programming machinery, increasing deployed image size
 by about 200kb for hello-world

---
 basis/tools/deploy/shaker/shaker.factor | 1 +
 1 file changed, 1 insertion(+)

diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index d9348bedd5..a7332ea9ea 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -256,6 +256,7 @@ IN: tools.deploy.shaker
                 compiled-generic-crossref
                 recompile-hook
                 update-tuples-hook
+                remake-generics-hook
                 definition-observers
                 definitions:crossref
                 interactive-vocabs

From 46830bb38d3f81c770b710786b5f23687cc1efed Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 4 Nov 2008 00:46:06 -0600
Subject: [PATCH 126/318] Fix another name clash in tests; putting all compiler
 tests in compiler.tests vocab is probably not good

---
 basis/compiler/tests/redefine2.factor | 14 +++++++-------
 1 file changed, 7 insertions(+), 7 deletions(-)

diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor
index c20a6d6233..d6e90187fe 100644
--- a/basis/compiler/tests/redefine2.factor
+++ b/basis/compiler/tests/redefine2.factor
@@ -3,16 +3,16 @@ USING: compiler compiler.units tools.test math parser kernel
 sequences sequences.private classes.mixin generic definitions
 arrays words assocs eval ;
 
-DEFER: blah
+DEFER: redefine2-test
 
-[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: blah ; M: blah nth 2drop 3 ; INSTANCE: blah sequence" eval ] unit-test
+[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
 
-[ t ] [ blah new sequence? ] unit-test
+[ t ] [ redefine2-test new sequence? ] unit-test
 
-[ 3 ] [ 0 blah new nth-unsafe ] unit-test
+[ 3 ] [ 0 redefine2-test new nth-unsafe ] unit-test
 
-[ ] [ [ blah sequence remove-mixin-instance ] with-compilation-unit ] unit-test
+[ ] [ [ redefine2-test sequence remove-mixin-instance ] with-compilation-unit ] unit-test
 
-[ f ] [ blah new sequence? ] unit-test
+[ f ] [ redefine2-test new sequence? ] unit-test
 
-[ 0 blah new nth-unsafe ] must-fail
+[ 0 redefine2-test new nth-unsafe ] must-fail

From 88d5dac02ff3b93f76b1190601cc76526885c033 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 4 Nov 2008 00:54:57 -0600
Subject: [PATCH 127/318] Remove obsolete code from unfinished

---
 unfinished/cpu/x86/syntax/syntax.factor |  16 -
 unfinished/cpu/x86/syntax/tags.txt      |   1 -
 unfinished/cpu/x86/x86.factor           | 470 ------------------------
 3 files changed, 487 deletions(-)
 delete mode 100644 unfinished/cpu/x86/syntax/syntax.factor
 delete mode 100644 unfinished/cpu/x86/syntax/tags.txt
 delete mode 100755 unfinished/cpu/x86/x86.factor

diff --git a/unfinished/cpu/x86/syntax/syntax.factor b/unfinished/cpu/x86/syntax/syntax.factor
deleted file mode 100644
index 061cf0defe..0000000000
--- a/unfinished/cpu/x86/syntax/syntax.factor
+++ /dev/null
@@ -1,16 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences lexer parser fry ;
-IN: cpu.x86.syntax
-
-: define-register ( name num size -- )
-    [ "cpu.x86" create dup define-symbol ]
-    [ dupd "register" set-word-prop ]
-    [ "register-size" set-word-prop ]
-    tri* ;
-
-: define-registers ( names size -- )
-    [ dup length ] dip '[ _ define-register ] 2each ;
-
-: REGISTERS: ( -- )
-    scan-word ";" parse-tokens swap define-registers ; parsing
diff --git a/unfinished/cpu/x86/syntax/tags.txt b/unfinished/cpu/x86/syntax/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/unfinished/cpu/x86/syntax/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/unfinished/cpu/x86/x86.factor b/unfinished/cpu/x86/x86.factor
deleted file mode 100755
index 97003cae66..0000000000
--- a/unfinished/cpu/x86/x86.factor
+++ /dev/null
@@ -1,470 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays compiler.constants compiler.backend
-compiler.codegen.fixup io.binary kernel combinators
-kernel.private math namespaces make sequences words system
-layouts math.order accessors cpu.x86.syntax ;
-IN: cpu.x86
-
-! A postfix assembler for x86 and AMD64.
-
-! In 32-bit mode, { 1234 } is absolute indirect addressing.
-! In 64-bit mode, { 1234 } is RIP-relative.
-! Beware!
-
-! Register operands -- eg, ECX
-REGISTERS: 8 AL CL DL BL ;
-
-REGISTERS: 16 AX CX DX BX SP BP SI DI ;
-
-REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
-
-REGISTERS: 64
-RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
-
-REGISTERS: 128
-XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
-XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 ;
-
-TUPLE: byte value ;
-
-C: <byte> byte
-
-<PRIVATE
-
-#! Extended AMD64 registers (R8-R15) return true.
-GENERIC: extended? ( op -- ? )
-
-M: object extended? drop f ;
-
-PREDICATE: register < word
-    "register" word-prop ;
-
-PREDICATE: register-8 < register
-    "register-size" word-prop 8 = ;
-
-PREDICATE: register-16 < register
-    "register-size" word-prop 16 = ;
-
-PREDICATE: register-32 < register
-    "register-size" word-prop 32 = ;
-
-PREDICATE: register-64 < register
-    "register-size" word-prop 64 = ;
-
-PREDICATE: register-128 < register
-    "register-size" word-prop 128 = ;
-
-M: register extended? "register" word-prop 7 > ;
-
-! Addressing modes
-TUPLE: indirect base index scale displacement ;
-
-M: indirect extended? base>> extended? ;
-
-: canonicalize-EBP ( indirect -- indirect )
-    #! { EBP } ==> { EBP 0 }
-    dup base>> { EBP RBP R13 } member? [
-        dup displacement>> [ 0 >>displacement ] unless
-    ] when ;
-
-: canonicalize-ESP ( indirect -- indirect )
-    #! { ESP } ==> { ESP ESP }
-    dup base>> { ESP RSP R12 } member? [ ESP >>index ] when ;
-
-: canonicalize ( indirect -- indirect )
-    #! Modify the indirect to work around certain addressing mode
-    #! quirks.
-    canonicalize-EBP canonicalize-ESP ;
-
-: <indirect> ( base index scale displacement -- indirect )
-    indirect boa canonicalize ;
-
-: reg-code ( reg -- n ) "register" word-prop 7 bitand ;
-
-: indirect-base* ( op -- n ) base>> EBP or reg-code ;
-
-: indirect-index* ( op -- n ) index>> ESP or reg-code ;
-
-: indirect-scale* ( op -- n ) scale>> 0 or ;
-
-GENERIC: sib-present? ( op -- ? )
-
-M: indirect sib-present?
-    [ base>> { ESP RSP } member? ] [ index>> ] [ scale>> ] tri or or ;
-
-M: register sib-present? drop f ;
-
-GENERIC: r/m ( operand -- n )
-
-M: indirect r/m
-    dup sib-present?
-    [ drop ESP reg-code ] [ indirect-base* ] if ;
-
-M: register r/m reg-code ;
-
-! Immediate operands
-UNION: immediate byte integer ;
-
-GENERIC: fits-in-byte? ( value -- ? )
-
-M: byte fits-in-byte? drop t ;
-
-M: integer fits-in-byte? -128 127 between? ;
-
-GENERIC: modifier ( op -- n )
-
-M: indirect modifier
-    dup base>> [
-        displacement>> {
-            { [ dup not ] [ BIN: 00 ] }
-            { [ dup fits-in-byte? ] [ BIN: 01 ] }
-            { [ dup immediate? ] [ BIN: 10 ] }
-        } cond nip
-    ] [
-        drop BIN: 00
-    ] if ;
-
-M: register modifier drop BIN: 11 ;
-
-GENERIC# n, 1 ( value n -- )
-
-M: integer n, >le % ;
-M: byte n, >r value>> r> n, ;
-: 1, ( n -- ) 1 n, ; inline
-: 4, ( n -- ) 4 n, ; inline
-: 2, ( n -- ) 2 n, ; inline
-: cell, ( n -- ) bootstrap-cell n, ; inline
-
-: mod-r/m, ( reg# indirect -- )
-    [ 3 shift ] [ [ modifier 6 shift ] [ r/m ] bi ] bi* bitor bitor , ;
-
-: sib, ( indirect -- )
-    dup sib-present? [
-        [ indirect-base* ]
-        [ indirect-index* 3 shift ]
-        [ indirect-scale* 6 shift ] tri bitor bitor ,
-    ] [
-        drop
-    ] if ;
-
-GENERIC: displacement, ( op -- )
-
-M: indirect displacement,
-    dup displacement>> dup [
-        swap base>>
-        [ dup fits-in-byte? [ , ] [ 4, ] if ] [ 4, ] if
-    ] [
-        2drop
-    ] if ;
-
-M: register displacement, drop ;
-
-: addressing ( reg# indirect -- )
-    [ mod-r/m, ] [ sib, ] [ displacement, ] tri ;
-
-! Utilities
-UNION: operand register indirect ;
-
-GENERIC: operand-64? ( operand -- ? )
-
-M: indirect operand-64?
-    [ base>> ] [ index>> ] bi [ operand-64? ] either? ;
-
-M: register-64 operand-64? drop t ;
-
-M: object operand-64? drop f ;
-
-: rex.w? ( rex.w reg r/m -- ? )
-    {
-        { [ dup register-128? ] [ drop operand-64? ] }
-        { [ dup not ] [ drop operand-64? ] }
-        [ nip operand-64? ]
-    } cond and ;
-
-: rex.r ( m op -- n )
-    extended? [ BIN: 00000100 bitor ] when ;
-
-: rex.b ( m op -- n )
-    [ extended? [ BIN: 00000001 bitor ] when ] keep
-    dup indirect? [
-        index>> extended? [ BIN: 00000010 bitor ] when
-    ] [
-        drop
-    ] if ;
-
-: rex-prefix ( reg r/m rex.w -- )
-    #! Compile an AMD64 REX prefix.
-    2over rex.w? BIN: 01001000 BIN: 01000000 ?
-    swap rex.r swap rex.b
-    dup BIN: 01000000 = [ drop ] [ , ] if ;
-
-: 16-prefix ( reg r/m -- )
-    [ register-16? ] either? [ HEX: 66 , ] when ;
-
-: prefix ( reg r/m rex.w -- ) 2over 16-prefix rex-prefix ;
-
-: prefix-1 ( reg rex.w -- ) f swap prefix ;
-
-: short-operand ( reg rex.w n -- )
-    #! Some instructions encode their single operand as part of
-    #! the opcode.
-    >r dupd prefix-1 reg-code r> + , ;
-
-: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
-
-: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
-
-: extended-opcode, ( opcode -- ) extended-opcode opcode, ;
-
-: opcode-or ( opcode mask -- opcode' )
-    swap dup array?
-    [ unclip-last rot bitor suffix ] [ bitor ] if ;
-
-: 1-operand ( op 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 >r >r over r> prefix-1 r> 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-1 ( imm dst reg,rex.w,opcode -- )
-    immediate-operand-size-bit 1-operand 1, ;
-
-: immediate-4 ( imm dst reg,rex.w,opcode -- )
-    immediate-operand-size-bit 1-operand 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-1/4 ( imm dst 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? [
-        immediate-fits-in-size-bit immediate-1
-    ] [
-        immediate-4
-    ] if ;
-
-: (2-operand) ( dst src op -- )
-    >r 2dup t rex-prefix r> opcode,
-    reg-code swap addressing ;
-
-: direction-bit ( dst src op -- dst' src' op' )
-    pick register? [ BIN: 10 opcode-or swapd ] when ;
-
-: operand-size-bit ( dst src op -- dst' src' op' )
-    over 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.
-    2over 16-prefix
-    direction-bit
-    operand-size-bit
-    (2-operand) ;
-
-PRIVATE>
-
-: [] ( reg/displacement -- indirect )
-    dup integer? [ >r f f f r> ] [ f f f ] if <indirect> ;
-
-: [+] ( reg displacement -- indirect )
-    dup integer?
-    [ dup zero? [ drop f ] when >r f f r> ]
-    [ f f ] if
-    <indirect> ;
-
-! Moving stuff
-GENERIC: PUSH ( op -- )
-M: register PUSH f HEX: 50 short-operand ;
-M: immediate PUSH HEX: 68 , 4, ;
-M: operand PUSH { BIN: 110 f HEX: ff } 1-operand ;
-
-GENERIC: POP ( op -- )
-M: register POP f HEX: 58 short-operand ;
-M: operand POP { BIN: 000 f HEX: 8f } 1-operand ;
-
-! MOV where the src is immediate.
-GENERIC: (MOV-I) ( src dst -- )
-M: register (MOV-I) t HEX: b8 short-operand cell, ;
-M: operand (MOV-I)
-    { BIN: 000 t HEX: c6 }
-    pick byte? [ immediate-1 ] [ immediate-4 ] if ;
-
-GENERIC: MOV ( dst src -- )
-M: immediate MOV swap (MOV-I) ;
-M: word MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
-M: operand MOV HEX: 88 2-operand ;
-
-: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
-
-! Control flow
-GENERIC: JMP ( op -- )
-: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
-M: word JMP (JMP) rel-word ;
-M: label JMP (JMP) label-fixup ;
-M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
-
-GENERIC: CALL ( op -- )
-: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
-M: word CALL (CALL) rel-word ;
-M: label CALL (CALL) label-fixup ;
-M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
-
-GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
-M: word JUMPcc (JUMPcc) rel-word ;
-M: label JUMPcc (JUMPcc) label-fixup ;
-
-: JO  ( dst -- ) HEX: 80 JUMPcc ;
-: JNO ( dst -- ) HEX: 81 JUMPcc ;
-: JB  ( dst -- ) HEX: 82 JUMPcc ;
-: JAE ( dst -- ) HEX: 83 JUMPcc ;
-: JE  ( dst -- ) HEX: 84 JUMPcc ; ! aka JZ
-: JNE ( dst -- ) HEX: 85 JUMPcc ;
-: JBE ( dst -- ) HEX: 86 JUMPcc ;
-: JA  ( dst -- ) HEX: 87 JUMPcc ;
-: JS  ( dst -- ) HEX: 88 JUMPcc ;
-: JNS ( dst -- ) HEX: 89 JUMPcc ;
-: JP  ( dst -- ) HEX: 8a JUMPcc ;
-: JNP ( dst -- ) HEX: 8b JUMPcc ;
-: JL  ( dst -- ) HEX: 8c JUMPcc ;
-: JGE ( dst -- ) HEX: 8d JUMPcc ;
-: JLE ( dst -- ) HEX: 8e JUMPcc ;
-: JG  ( dst -- ) HEX: 8f JUMPcc ;
-
-: LEAVE ( -- ) HEX: c9 , ;
-: NOP ( -- ) HEX: 90 , ;
-
-: RET ( n -- )
-    dup zero? [ drop HEX: c3 , ] [ HEX: C2 , 2, ] if ;
-
-! Arithmetic
-
-GENERIC: ADD ( dst src -- )
-M: immediate ADD swap { 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: operand OR OCT: 010 2-operand ;
-
-GENERIC: ADC ( dst src -- )
-M: immediate ADC swap { 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: operand SBB OCT: 030 2-operand ;
-
-GENERIC: AND ( dst src -- )
-M: immediate AND swap { 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: operand SUB OCT: 050 2-operand ;
-
-GENERIC: XOR ( dst src -- )
-M: immediate XOR swap { 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: operand CMP OCT: 070 2-operand ;
-
-: NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
-: NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
-: MUL  ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
-: IMUL ( src -- ) { BIN: 101 t HEX: f7 } 1-operand ;
-: DIV  ( dst -- ) { BIN: 110 t HEX: f7 } 1-operand ;
-: IDIV ( src -- ) { BIN: 111 t HEX: f7 } 1-operand ;
-
-: CDQ ( -- ) HEX: 99 , ;
-: CQO ( -- ) HEX: 48 , CDQ ;
-
-: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
-: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
-: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
-: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
-: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
-: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
-: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
-
-GENERIC: IMUL2 ( dst src -- )
-M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
-M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
-
-: MOVSX ( dst src -- )
-    dup register-32? OCT: 143 OCT: 276 extended-opcode ?
-    over register-16? [ BIN: 1 opcode-or ] when
-    swapd
-    (2-operand) ;
-
-! Conditional move
-: MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
-
-: CMOVO  ( dst src -- ) HEX: 40 MOVcc ;
-: CMOVNO ( dst src -- ) HEX: 41 MOVcc ;
-: CMOVB  ( dst src -- ) HEX: 42 MOVcc ;
-: CMOVAE ( dst src -- ) HEX: 43 MOVcc ;
-: CMOVE  ( dst src -- ) HEX: 44 MOVcc ; ! aka CMOVZ
-: CMOVNE ( dst src -- ) HEX: 45 MOVcc ;
-: CMOVBE ( dst src -- ) HEX: 46 MOVcc ;
-: CMOVA  ( dst src -- ) HEX: 47 MOVcc ;
-: CMOVS  ( dst src -- ) HEX: 48 MOVcc ;
-: CMOVNS ( dst src -- ) HEX: 49 MOVcc ;
-: CMOVP  ( dst src -- ) HEX: 4a MOVcc ;
-: CMOVNP ( dst src -- ) HEX: 4b MOVcc ;
-: CMOVL  ( dst src -- ) HEX: 4c MOVcc ;
-: CMOVGE ( dst src -- ) HEX: 4d MOVcc ;
-: CMOVLE ( dst src -- ) HEX: 4e MOVcc ;
-: CMOVG  ( dst src -- ) HEX: 4f MOVcc ;
-
-! CPU Identification
-
-: CPUID ( -- ) HEX: a2 extended-opcode, ;
-
-! x87 Floating Point Unit
-
-: FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;
-: FSTPL ( operand -- ) { BIN: 011 f HEX: dd } 1-operand ;
-
-: FLDS ( operand -- ) { BIN: 000 f HEX: d9 } 1-operand ;
-: FLDL ( operand -- ) { BIN: 000 f HEX: dd } 1-operand ;
-
-! SSE multimedia instructions
-
-<PRIVATE
-
-: direction-bit-sse ( dst src op1 -- dst' src' op1' )
-    pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
-
-: 2-operand-sse ( dst src op1 op2 -- )
-    , direction-bit-sse extended-opcode (2-operand) ;
-
-: 2-operand-int/sse ( dst src op1 op2 -- )
-    , swapd extended-opcode (2-operand) ;
-
-PRIVATE>
-
-: MOVSS   ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ;
-: MOVSD   ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ;
-: ADDSD   ( dest src -- ) HEX: 58 HEX: f2 2-operand-sse ;
-: MULSD   ( dest src -- ) HEX: 59 HEX: f2 2-operand-sse ;
-: SUBSD   ( dest src -- ) HEX: 5c HEX: f2 2-operand-sse ;
-: DIVSD   ( dest src -- ) HEX: 5e HEX: f2 2-operand-sse ;
-: SQRTSD  ( dest src -- ) HEX: 51 HEX: f2 2-operand-sse ;
-: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-sse ;
-: COMISD  ( dest src -- ) HEX: 2f HEX: 66 2-operand-sse ;
-
-: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ;
-: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-sse ;
-
-: CVTSI2SD  ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ;
-: CVTSD2SI  ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ;
-: CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ;

From 7134fad54cfe4365ac0ff9e23246cc712a524874 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 4 Nov 2008 02:17:22 -0600
Subject: [PATCH 128/318] Add more unit tests highlighting the problem:
 predicate -vs- union comparison is broken

---
 core/classes/predicate/predicate-tests.factor | 9 ++++++++-
 1 file changed, 8 insertions(+), 1 deletion(-)

diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor
index 9f3b3e2141..3de073f774 100644
--- a/core/classes/predicate/predicate-tests.factor
+++ b/core/classes/predicate/predicate-tests.factor
@@ -1,9 +1,16 @@
-USING: math tools.test ;
+USING: math tools.test classes.algebra ;
 IN: classes.predicate
 
 PREDICATE: negative < integer 0 < ;
 PREDICATE: positive < integer 0 > ;
 
+[ t ] [ negative integer class< ] unit-test
+[ t ] [ positive integer class< ] unit-test
+[ f ] [ integer negative class< ] unit-test
+[ f ] [ integer positive class< ] unit-test
+[ f ] [ negative negative class< ] unit-test
+[ f ] [ positive negative class< ] unit-test
+
 GENERIC: abs ( n -- n )
 M: integer abs ;
 M: negative abs -1 * ;

From 9b492b55e0b4f5b944974f71c6bbdc8c2f668cfb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 4 Nov 2008 02:17:37 -0600
Subject: [PATCH 129/318] Fix minor leak: class-caches were not reset if a
 class was forgotten

---
 core/classes/classes-tests.factor | 13 ++++++++++++-
 core/classes/classes.factor       |  3 ++-
 2 files changed, 14 insertions(+), 2 deletions(-)

diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index 1dee6a095c..dd12674cc4 100644
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -3,7 +3,8 @@ kernel math namespaces parser prettyprint sequences strings
 tools.test vectors words quotations classes
 classes.private classes.union classes.mixin classes.predicate
 classes.algebra vectors definitions source-files
-compiler.units kernel.private sorting vocabs ;
+compiler.units kernel.private sorting vocabs memory eval
+accessors ;
 IN: classes.tests
 
 [ t ] [ 3 object instance? ] unit-test
@@ -27,3 +28,13 @@ M: method-forget-class method-forget-test ;
     implementors-map get keys
     [ natural-sort ] bi@ =
 ] unit-test
+
+! Minor leak
+[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval ] unit-test
+[ ] [ f \ word set-global ] unit-test
+[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval ] unit-test
+[ ] [ "IN: classes.tests FORGET: forget-me" eval ] unit-test
+[ 0 ] [
+    [ word? ] instances
+    [ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count
+] unit-test
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index dcb69c9149..70fb869c5c 100644
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -176,7 +176,8 @@ GENERIC: class-forgotten ( use class -- )
         [ implementors-map- ]
         [ update-map- ]
         [ reset-class ]
-    } cleave ;
+    } cleave
+    reset-caches ;
 
 M: class class-forgotten
     nip forget-class ;

From cc94894441c876a406212d6c5ad05d4d01637f1a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 4 Nov 2008 03:38:44 -0600
Subject: [PATCH 130/318] Fix notorious classes-intersect? bug, or at least one
 manifestation thereof. Turns out that we may temporarily end up with
 forgotten classes in the compiled-generic-crossref table. This is not a
 problem, since subsequently the words that reference forgotten classes will
 presumably be redefined and recompiled, but it does mean that
 (compiled-generic-usage) does need to handle this case

---
 core/classes/classes-tests.factor | 51 ++++++++++++++++++++++++++++---
 core/compiler/units/units.factor  |  9 +++---
 2 files changed, 51 insertions(+), 9 deletions(-)

diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index dd12674cc4..c7900da316 100644
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -1,10 +1,9 @@
 USING: alien arrays definitions generic assocs hashtables io
-kernel math namespaces parser prettyprint sequences strings
-tools.test vectors words quotations classes
+io.streams.string kernel math namespaces parser prettyprint
+sequences strings tools.test vectors words quotations classes
 classes.private classes.union classes.mixin classes.predicate
-classes.algebra vectors definitions source-files
-compiler.units kernel.private sorting vocabs memory eval
-accessors ;
+classes.algebra vectors definitions source-files compiler.units
+kernel.private sorting vocabs memory eval accessors ;
 IN: classes.tests
 
 [ t ] [ 3 object instance? ] unit-test
@@ -38,3 +37,45 @@ M: method-forget-class method-forget-test ;
     [ word? ] instances
     [ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count
 ] unit-test
+
+! Long-standing problem
+USE: multiline
+
+! So the user has some code...
+[ ] [
+    <" IN: classes.test.a
+    GENERIC: g ( a -- b )
+    TUPLE: x ;
+    M: x g ;
+    TUPLE: z < x ;"> <string-reader>
+    "class-intersect-no-method-a" parse-stream drop
+] unit-test
+
+! Note that q inlines M: x g ;
+[ ] [
+    <" IN: classes.test.b
+    USE: classes.test.a
+    USE: kernel
+    : q ( -- b ) z new g ;"> <string-reader>
+    "class-intersect-no-method-b" parse-stream drop
+] unit-test
+
+! Now, the user removes the z class and adds a method,
+[ ] [
+    <" IN: classes.test.a
+    GENERIC: g ( a -- b )
+    TUPLE: x ;
+    M: x g ;
+    TUPLE: j ;
+    M: j g ;"> <string-reader>
+    "class-intersect-no-method-a" parse-stream drop
+] unit-test
+
+! And changes the definition of q
+[ ] [
+    <" IN: classes.test.b
+    USE: classes.test.a
+    USE: kernel
+    : q ( -- b ) j new g ;"> <string-reader>
+    "class-intersect-no-method-b" parse-stream drop
+] unit-test
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 973d9b5c00..1b6b934dae 100644
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -109,10 +109,11 @@ SYMBOL: remake-generics-hook
     compiled-generic-crossref get at ;
 
 : (compiled-generic-usages) ( generic class -- assoc )
-    dup class? [
-        [ compiled-generic-usage ] dip
-        [ classes-intersect? nip ] curry assoc-filter
-    ] [ 2drop f ] if ;
+    [ compiled-generic-usage ] dip
+    [
+        2dup [ class? ] both?
+        [ classes-intersect? ] [ 2drop f ] if nip
+    ] curry assoc-filter ;
 
 : compiled-generic-usages ( assoc -- assocs )
     [ (compiled-generic-usages) ] { } assoc>map ;

From fb64c1cb4560b2081da832b6528029b1465be8cf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 4 Nov 2008 04:59:54 -0600
Subject: [PATCH 131/318] Fix class<=; a predicate class derived from a union
 was not reported as being contained in the union

---
 core/classes/algebra/algebra.factor | 29 +++++++++++++++--------------
 1 file changed, 15 insertions(+), 14 deletions(-)

diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index b32bac3a18..51dad033a9 100644
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -55,7 +55,7 @@ DEFER: (class-or)
     class-or-cache get [ (class-or) ] 2cache ;
 
 : superclass<= ( first second -- ? )
-    >r superclass r> class<= ;
+    swap superclass dup [ swap class<= ] [ 2drop f ] if ;
 
 : left-anonymous-union<= ( first second -- ? )
     >r members>> r> [ class<= ] curry all? ;
@@ -103,19 +103,20 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
 
 : (class<=) ( first second -- -1/0/1 )
     2dup eq? [ 2drop t ] [
-        [ normalize-class ] bi@ {
-            { [ dup empty-intersection? ] [ 2drop t ] }
-            { [ over empty-union? ] [ 2drop t ] }
-            { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
-            { [ over anonymous-union? ] [ left-anonymous-union<= ] }
-            { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
-            { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
-            { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
-            { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
-            { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
-            { [ over superclass ] [ superclass<= ] }
-            [ 2drop f ]
-        } cond
+        2dup superclass<= [ 2drop t ] [
+            [ normalize-class ] bi@ {
+                { [ dup empty-intersection? ] [ 2drop t ] }
+                { [ over empty-union? ] [ 2drop t ] }
+                { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
+                { [ over anonymous-union? ] [ left-anonymous-union<= ] }
+                { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
+                { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
+                { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
+                { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
+                { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
+                [ 2drop f ]
+            } cond
+        ] if
     ] if ;
 
 M: anonymous-union (classes-intersect?)

From d8345b5eda090cc5abef7b94e4d4e9388a928764 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 4 Nov 2008 06:07:19 -0600
Subject: [PATCH 132/318] Update PPC non-optimizing compiler backend: there are
 three new sub-primitives to support

---
 basis/cpu/ppc/bootstrap.factor | 43 +++++++++++++++++++++++++++++++++-
 1 file changed, 42 insertions(+), 1 deletion(-)

diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index 99bcfae92a..47c31111a9 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -3,7 +3,7 @@
 USING: bootstrap.image.private kernel kernel.private namespaces
 system cpu.ppc.assembler compiler.codegen.fixup compiler.units
 compiler.constants math math.private layouts words words.private
-vocabs slots.private ;
+vocabs slots.private locals.backend ;
 IN: bootstrap.ppc
 
 4 \ cell set
@@ -305,4 +305,45 @@ big-endian on
     3 ds-reg 0 STW
 ] f f f \ fixnum-bitnot define-sub-primitive
 
+[
+    3 ds-reg 0 LWZ
+    3 3 tag-bits get SRAWI
+    ds-reg ds-reg 4 SUBI
+    4 ds-reg 0 LWZ
+    5 4 3 SLW
+    6 3 NEG
+    7 4 6 SRAW
+    7 7 0 0 31 tag-bits get - RLWINM
+    0 3 0 CMPI
+    2 BGT
+    5 7 MR
+    5 ds-reg 0 STW
+] f f f \ fixnum-shift-fast define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    ds-reg ds-reg 4 SUBI
+    4 ds-reg 0 LWZ
+    5 4 3 DIVW
+    6 5 3 MULLW
+    7 6 4 SUBF
+    7 ds-reg 0 STW
+] f f f \ fixnum-mod define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    3 3 1 SRAWI
+    4 4 LI
+    4 3 4 SUBF
+    rs-reg 3 4 LWZX
+    3 ds-reg 0 STW
+] f f f \ get-local define-sub-primitive
+
+[
+    3 ds-reg 0 LWZ
+    ds-reg ds-reg 4 SUBI
+    3 3 1 SRAWI
+    rs-reg 3 rs-reg SUBF
+] f f f \ drop-locals define-sub-primitive
+
 [ "bootstrap.ppc" forget-vocab ] with-compilation-unit

From 22f11f24c9868037e190f35b6f3eb8d9daadbce0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 4 Nov 2008 17:23:08 -0600
Subject: [PATCH 133/318] Move simple-table. to prettyprint since its generally
 useful and not specific to tools.time

---
 basis/prettyprint/prettyprint.factor | 14 ++++++++++++++
 basis/tools/time/time.factor         | 14 --------------
 2 files changed, 14 insertions(+), 14 deletions(-)

diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor
index f63ce44c71..b0293a8759 100644
--- a/basis/prettyprint/prettyprint.factor
+++ b/basis/prettyprint/prettyprint.factor
@@ -134,6 +134,20 @@ PRIVATE>
 
 : pprint-cell ( obj -- ) [ pprint ] with-cell ;
 
+: simple-table. ( values -- )
+    standard-table-style [
+        [
+            [
+                [
+                    dup string?
+                    [ [ write ] with-cell ]
+                    [ pprint-cell ]
+                    if
+                ] each
+            ] with-row
+        ] each
+    ] tabular-output ;
+
 GENERIC: see ( defspec -- )
 
 : comment. ( string -- )
diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor
index 3078f40e1a..6873d68316 100644
--- a/basis/tools/time/time.factor
+++ b/basis/tools/time/time.factor
@@ -7,20 +7,6 @@ IN: tools.time
 : benchmark ( quot -- runtime )
     millis >r call millis r> - ; inline
 
-: simple-table. ( values -- )
-    standard-table-style [
-        [
-            [
-                [
-                    dup string?
-                    [ [ write ] with-cell ]
-                    [ pprint-cell ]
-                    if
-                ] each
-            ] with-row
-        ] each
-    ] tabular-output ;
-
 : time. ( data -- )
     unclip
     "==== RUNNING TIME" print nl pprint " ms" print nl

From c8521ad826546d1ab4426e9c5ed59aaf8c12953e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 4 Nov 2008 17:23:20 -0600
Subject: [PATCH 134/318] Add tool to dump live intervals

---
 .../cfg/linear-scan/debugger/debugger.factor    | 17 +++++++++++++++--
 1 file changed, 15 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
index 89bf81d2ba..c6481b305e 100644
--- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor
+++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences sets arrays
-compiler.cfg.linear-scan.live-intervals
+USING: accessors kernel sequences sets arrays math strings fry
+prettyprint compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation ;
 IN: compiler.cfg.linear-scan.debugger
 
@@ -21,3 +21,16 @@ IN: compiler.cfg.linear-scan.debugger
 : check-linear-scan ( live-intervals machine-registers -- )
     [ [ clone ] map ] dip allocate-registers
     [ split-children ] map concat check-assigned ;
+
+: picture ( uses -- str )
+    dup peek 1 + CHAR: space <string>
+    [ '[ CHAR: * swap _ set-nth ] each ] keep ;
+
+: interval-picture ( interval -- str )
+    [ uses>> picture ]
+    [ copy-from>> unparse ]
+    [ vreg>> unparse ]
+    tri 3array ;
+
+: live-intervals. ( seq -- )
+    [ interval-picture ] map simple-table. ;

From b5b207a484afc6fbf647916720192ce7f8adf936 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 5 Nov 2008 01:11:15 -0500
Subject: [PATCH 135/318] Add test files for all Project Euler solutions

---
 extra/project-euler/008/008-tests.factor |  4 ++++
 extra/project-euler/009/009-tests.factor |  4 ++++
 extra/project-euler/010/010-tests.factor |  4 ++++
 extra/project-euler/010/010.factor       | 11 +++++++----
 extra/project-euler/011/011-tests.factor |  4 ++++
 extra/project-euler/012/012-tests.factor |  4 ++++
 extra/project-euler/012/012.factor       |  2 +-
 extra/project-euler/013/013-tests.factor |  4 ++++
 extra/project-euler/013/013.factor       |  2 +-
 extra/project-euler/014/014-tests.factor |  5 +++++
 extra/project-euler/015/015-tests.factor |  4 ++++
 extra/project-euler/015/015.factor       |  2 +-
 extra/project-euler/016/016-tests.factor |  4 ++++
 extra/project-euler/017/017-tests.factor |  4 ++++
 extra/project-euler/018/018-tests.factor |  5 +++++
 extra/project-euler/018/018.factor       |  4 ++--
 extra/project-euler/019/019-tests.factor |  5 +++++
 extra/project-euler/019/019.factor       |  4 ++--
 extra/project-euler/020/020-tests.factor |  4 ++++
 extra/project-euler/021/021-tests.factor |  4 ++++
 extra/project-euler/021/021.factor       |  2 +-
 extra/project-euler/022/022-tests.factor |  4 ++++
 extra/project-euler/022/022.factor       |  2 +-
 extra/project-euler/023/023-tests.factor |  4 ++++
 extra/project-euler/024/024-tests.factor |  4 ++++
 extra/project-euler/024/024.factor       |  2 +-
 extra/project-euler/025/025-tests.factor |  5 +++++
 extra/project-euler/025/025.factor       |  4 ++--
 extra/project-euler/026/026-tests.factor |  4 ++++
 extra/project-euler/026/026.factor       |  2 +-
 extra/project-euler/027/027-tests.factor |  4 ++++
 extra/project-euler/027/027.factor       |  2 +-
 extra/project-euler/028/028-tests.factor |  4 ++++
 extra/project-euler/029/029-tests.factor |  4 ++++
 extra/project-euler/029/029.factor       |  2 +-
 extra/project-euler/030/030-tests.factor |  4 ++++
 extra/project-euler/030/030.factor       |  2 +-
 extra/project-euler/031/031-tests.factor |  4 ++++
 extra/project-euler/032/032-tests.factor |  5 +++++
 extra/project-euler/032/032.factor       |  6 +++---
 extra/project-euler/033/033-tests.factor |  4 ++++
 extra/project-euler/033/033.factor       |  2 +-
 extra/project-euler/034/034-tests.factor |  4 ++++
 extra/project-euler/034/034.factor       |  2 +-
 extra/project-euler/035/035-tests.factor |  4 ++++
 extra/project-euler/035/035.factor       |  2 +-
 extra/project-euler/036/036-tests.factor |  4 ++++
 extra/project-euler/036/036.factor       |  2 +-
 extra/project-euler/037/037-tests.factor |  4 ++++
 extra/project-euler/037/037.factor       |  2 +-
 extra/project-euler/038/038-tests.factor |  4 ++++
 extra/project-euler/038/038.factor       |  2 +-
 extra/project-euler/039/039-tests.factor |  4 ++++
 extra/project-euler/039/039.factor       |  2 +-
 extra/project-euler/040/040-tests.factor |  4 ++++
 extra/project-euler/040/040.factor       |  2 +-
 extra/project-euler/041/041-tests.factor |  4 ++++
 extra/project-euler/041/041.factor       |  2 +-
 extra/project-euler/042/042-tests.factor |  5 +++++
 extra/project-euler/042/042.factor       |  4 ++--
 extra/project-euler/043/043-tests.factor |  5 +++++
 extra/project-euler/043/043.factor       |  4 ++--
 extra/project-euler/044/044-tests.factor |  4 ++++
 extra/project-euler/044/044.factor       |  2 +-
 extra/project-euler/045/045-tests.factor |  4 ++++
 extra/project-euler/045/045.factor       |  2 +-
 extra/project-euler/046/046-tests.factor |  4 ++++
 extra/project-euler/046/046.factor       |  2 +-
 extra/project-euler/047/047-tests.factor |  5 +++++
 extra/project-euler/047/047.factor       |  4 ++--
 extra/project-euler/048/048-tests.factor |  4 ++++
 extra/project-euler/052/052-tests.factor |  4 ++++
 extra/project-euler/052/052.factor       |  2 +-
 extra/project-euler/053/053-tests.factor |  4 ++++
 extra/project-euler/053/053.factor       |  2 +-
 extra/project-euler/055/055-tests.factor |  4 ++++
 extra/project-euler/055/055.factor       |  2 +-
 extra/project-euler/056/056-tests.factor |  4 ++++
 extra/project-euler/056/056.factor       |  2 +-
 extra/project-euler/059/059-tests.factor |  4 ++++
 extra/project-euler/059/059.factor       |  2 +-
 extra/project-euler/067/067-tests.factor |  5 +++++
 extra/project-euler/067/067.factor       |  4 ++--
 extra/project-euler/075/075-tests.factor |  4 ++++
 extra/project-euler/075/075.factor       | 12 ++++++------
 extra/project-euler/076/076-tests.factor |  4 ++++
 extra/project-euler/079/079-tests.factor |  4 ++++
 extra/project-euler/079/079.factor       |  2 +-
 extra/project-euler/092/092-tests.factor |  4 ++++
 extra/project-euler/097/097-tests.factor |  4 ++++
 extra/project-euler/097/097.factor       |  2 +-
 extra/project-euler/100/100-tests.factor |  4 ++++
 extra/project-euler/100/100.factor       |  6 +++---
 extra/project-euler/116/116-tests.factor |  4 ++++
 extra/project-euler/116/116.factor       |  2 +-
 extra/project-euler/117/117-tests.factor |  4 ++++
 extra/project-euler/117/117.factor       |  2 +-
 extra/project-euler/134/134-tests.factor |  4 ++++
 extra/project-euler/134/134.factor       |  2 +-
 extra/project-euler/148/148-tests.factor |  4 ++++
 extra/project-euler/148/148.factor       |  2 +-
 extra/project-euler/150/150-tests.factor |  4 ++++
 extra/project-euler/150/150.factor       |  2 +-
 extra/project-euler/164/164-tests.factor |  4 ++++
 extra/project-euler/164/164.factor       |  2 +-
 extra/project-euler/169/169-tests.factor |  4 ++++
 extra/project-euler/169/169.factor       |  4 ++--
 extra/project-euler/173/173-tests.factor |  4 ++++
 extra/project-euler/173/173.factor       |  2 +-
 extra/project-euler/175/175-tests.factor |  4 ++++
 extra/project-euler/175/175.factor       |  2 +-
 extra/project-euler/186/186-tests.factor |  4 ++++
 extra/project-euler/186/186.factor       |  5 ++---
 extra/project-euler/190/190-tests.factor |  4 ++++
 extra/project-euler/190/190.factor       |  2 +-
 115 files changed, 340 insertions(+), 73 deletions(-)
 create mode 100644 extra/project-euler/008/008-tests.factor
 create mode 100644 extra/project-euler/009/009-tests.factor
 create mode 100644 extra/project-euler/010/010-tests.factor
 create mode 100644 extra/project-euler/011/011-tests.factor
 create mode 100644 extra/project-euler/012/012-tests.factor
 create mode 100644 extra/project-euler/013/013-tests.factor
 create mode 100644 extra/project-euler/014/014-tests.factor
 create mode 100644 extra/project-euler/015/015-tests.factor
 create mode 100644 extra/project-euler/016/016-tests.factor
 create mode 100644 extra/project-euler/017/017-tests.factor
 create mode 100644 extra/project-euler/018/018-tests.factor
 create mode 100644 extra/project-euler/019/019-tests.factor
 create mode 100644 extra/project-euler/020/020-tests.factor
 create mode 100644 extra/project-euler/021/021-tests.factor
 create mode 100644 extra/project-euler/022/022-tests.factor
 create mode 100644 extra/project-euler/023/023-tests.factor
 create mode 100644 extra/project-euler/024/024-tests.factor
 create mode 100644 extra/project-euler/025/025-tests.factor
 create mode 100644 extra/project-euler/026/026-tests.factor
 create mode 100644 extra/project-euler/027/027-tests.factor
 create mode 100644 extra/project-euler/028/028-tests.factor
 create mode 100644 extra/project-euler/029/029-tests.factor
 create mode 100644 extra/project-euler/030/030-tests.factor
 create mode 100644 extra/project-euler/031/031-tests.factor
 create mode 100644 extra/project-euler/032/032-tests.factor
 create mode 100644 extra/project-euler/033/033-tests.factor
 create mode 100644 extra/project-euler/034/034-tests.factor
 create mode 100644 extra/project-euler/035/035-tests.factor
 create mode 100644 extra/project-euler/036/036-tests.factor
 create mode 100644 extra/project-euler/037/037-tests.factor
 create mode 100644 extra/project-euler/038/038-tests.factor
 create mode 100644 extra/project-euler/039/039-tests.factor
 create mode 100644 extra/project-euler/040/040-tests.factor
 create mode 100644 extra/project-euler/041/041-tests.factor
 create mode 100644 extra/project-euler/042/042-tests.factor
 create mode 100644 extra/project-euler/043/043-tests.factor
 create mode 100644 extra/project-euler/044/044-tests.factor
 create mode 100644 extra/project-euler/045/045-tests.factor
 create mode 100644 extra/project-euler/046/046-tests.factor
 create mode 100644 extra/project-euler/047/047-tests.factor
 create mode 100644 extra/project-euler/048/048-tests.factor
 create mode 100644 extra/project-euler/052/052-tests.factor
 create mode 100644 extra/project-euler/053/053-tests.factor
 create mode 100644 extra/project-euler/055/055-tests.factor
 create mode 100644 extra/project-euler/056/056-tests.factor
 create mode 100644 extra/project-euler/059/059-tests.factor
 create mode 100644 extra/project-euler/067/067-tests.factor
 create mode 100644 extra/project-euler/075/075-tests.factor
 create mode 100644 extra/project-euler/076/076-tests.factor
 create mode 100644 extra/project-euler/079/079-tests.factor
 create mode 100644 extra/project-euler/092/092-tests.factor
 create mode 100644 extra/project-euler/097/097-tests.factor
 create mode 100644 extra/project-euler/100/100-tests.factor
 create mode 100644 extra/project-euler/116/116-tests.factor
 create mode 100644 extra/project-euler/117/117-tests.factor
 create mode 100644 extra/project-euler/134/134-tests.factor
 create mode 100644 extra/project-euler/148/148-tests.factor
 create mode 100644 extra/project-euler/150/150-tests.factor
 create mode 100644 extra/project-euler/164/164-tests.factor
 create mode 100644 extra/project-euler/169/169-tests.factor
 create mode 100644 extra/project-euler/173/173-tests.factor
 create mode 100644 extra/project-euler/175/175-tests.factor
 create mode 100644 extra/project-euler/186/186-tests.factor
 create mode 100644 extra/project-euler/190/190-tests.factor

diff --git a/extra/project-euler/008/008-tests.factor b/extra/project-euler/008/008-tests.factor
new file mode 100644
index 0000000000..15fd9f4648
--- /dev/null
+++ b/extra/project-euler/008/008-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.008 tools.test ;
+IN: project-euler.008.tests
+
+[ 40824 ] [ euler008 ] unit-test
diff --git a/extra/project-euler/009/009-tests.factor b/extra/project-euler/009/009-tests.factor
new file mode 100644
index 0000000000..20be369818
--- /dev/null
+++ b/extra/project-euler/009/009-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.009 tools.test ;
+IN: project-euler.009.tests
+
+[ 31875000 ] [ euler009 ] unit-test
diff --git a/extra/project-euler/010/010-tests.factor b/extra/project-euler/010/010-tests.factor
new file mode 100644
index 0000000000..b110ce8824
--- /dev/null
+++ b/extra/project-euler/010/010-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.010 tools.test ;
+IN: project-euler.010.tests
+
+[ 142913828922 ] [ euler010 ] unit-test
diff --git a/extra/project-euler/010/010.factor b/extra/project-euler/010/010.factor
index 172bb9d290..c8bbe3d72e 100644
--- a/extra/project-euler/010/010.factor
+++ b/extra/project-euler/010/010.factor
@@ -10,16 +10,19 @@ IN: project-euler.010
 
 ! The sum of the primes below 10 is 2 + 3 + 5 + 7 = 17.
 
-! Find the sum of all the primes below one million.
+! Find the sum of all the primes below two million.
 
 
 ! SOLUTION
 ! --------
 
 : euler010 ( -- answer )
-    1000000 primes-upto sum ;
+    2000000 primes-upto sum ;
 
-! [ euler010 ] 100 ave-time
-! 14 ms run / 0 ms GC ave time - 100 trials
+! [ euler010 ] time
+! 266425 ms run / 10001 ms GC time
+
+! TODO: this takes well over one minute now that they changed the problem to
+! two million instead of one. the primes vocab could use some improvements
 
 MAIN: euler010
diff --git a/extra/project-euler/011/011-tests.factor b/extra/project-euler/011/011-tests.factor
new file mode 100644
index 0000000000..5c48320f56
--- /dev/null
+++ b/extra/project-euler/011/011-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.011 tools.test ;
+IN: project-euler.011.tests
+
+[ 70600674 ] [ euler011 ] unit-test
diff --git a/extra/project-euler/012/012-tests.factor b/extra/project-euler/012/012-tests.factor
new file mode 100644
index 0000000000..c2d9730f05
--- /dev/null
+++ b/extra/project-euler/012/012-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.012 tools.test ;
+IN: project-euler.012.tests
+
+[ 76576500 ] [ euler012 ] unit-test
diff --git a/extra/project-euler/012/012.factor b/extra/project-euler/012/012.factor
index 583bad8f72..b25bfc90f1 100644
--- a/extra/project-euler/012/012.factor
+++ b/extra/project-euler/012/012.factor
@@ -37,6 +37,6 @@ IN: project-euler.012
     8 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ;
 
 ! [ euler012 ] 10 ave-time
-! 5413 ms run / 1 ms GC ave time - 10 trials
+! 6573 ms ave run time - 346.27 SD (10 trials)
 
 MAIN: euler012
diff --git a/extra/project-euler/013/013-tests.factor b/extra/project-euler/013/013-tests.factor
new file mode 100644
index 0000000000..3d9f88d84e
--- /dev/null
+++ b/extra/project-euler/013/013-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.013 tools.test ;
+IN: project-euler.013.tests
+
+[ 5537376230 ] [ euler013 ] unit-test
diff --git a/extra/project-euler/013/013.factor b/extra/project-euler/013/013.factor
index 907029cfb2..857bd62cc4 100644
--- a/extra/project-euler/013/013.factor
+++ b/extra/project-euler/013/013.factor
@@ -228,6 +228,6 @@ PRIVATE>
     source-013 sum number>string 10 head string>number ;
 
 ! [ euler013 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.31 SD (100 trials)
 
 MAIN: euler013
diff --git a/extra/project-euler/014/014-tests.factor b/extra/project-euler/014/014-tests.factor
new file mode 100644
index 0000000000..b423c90323
--- /dev/null
+++ b/extra/project-euler/014/014-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.014 tools.test ;
+IN: project-euler.014.tests
+
+[ 837799 ] [ euler014 ] unit-test
+[ 837799 ] [ euler014a ] unit-test
diff --git a/extra/project-euler/015/015-tests.factor b/extra/project-euler/015/015-tests.factor
new file mode 100644
index 0000000000..9c86421889
--- /dev/null
+++ b/extra/project-euler/015/015-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.015 tools.test ;
+IN: project-euler.015.tests
+
+[ 137846528820 ] [ euler015 ] unit-test
diff --git a/extra/project-euler/015/015.factor b/extra/project-euler/015/015.factor
index 305426902b..fb720c7e7c 100644
--- a/extra/project-euler/015/015.factor
+++ b/extra/project-euler/015/015.factor
@@ -28,6 +28,6 @@ PRIVATE>
     20 grid-paths ;
 
 ! [ euler015 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.2 SD (100 trials)
 
 MAIN: euler015
diff --git a/extra/project-euler/016/016-tests.factor b/extra/project-euler/016/016-tests.factor
new file mode 100644
index 0000000000..e75a114e68
--- /dev/null
+++ b/extra/project-euler/016/016-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.016 tools.test ;
+IN: project-euler.016.tests
+
+[ 1366 ] [ euler016 ] unit-test
diff --git a/extra/project-euler/017/017-tests.factor b/extra/project-euler/017/017-tests.factor
new file mode 100644
index 0000000000..3c2b2d5487
--- /dev/null
+++ b/extra/project-euler/017/017-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.017 tools.test ;
+IN: project-euler.017.tests
+
+[ 21124 ] [ euler017 ] unit-test
diff --git a/extra/project-euler/018/018-tests.factor b/extra/project-euler/018/018-tests.factor
new file mode 100644
index 0000000000..1d4d65079e
--- /dev/null
+++ b/extra/project-euler/018/018-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.018 tools.test ;
+IN: project-euler.018.tests
+
+[ 1074 ] [ euler018 ] unit-test
+[ 1074 ] [ euler018a ] unit-test
diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor
index eb2df5e0da..21831b90d4 100644
--- a/extra/project-euler/018/018.factor
+++ b/extra/project-euler/018/018.factor
@@ -74,7 +74,7 @@ PRIVATE>
     source-018 propagate-all first first ;
 
 ! [ euler018 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.29 SD (100 trials)
 
 
 ! ALTERNATE SOLUTIONS
@@ -84,6 +84,6 @@ PRIVATE>
     source-018 max-path ;
 
 ! [ euler018a ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.39 SD (100 trials)
 
 MAIN: euler018a
diff --git a/extra/project-euler/019/019-tests.factor b/extra/project-euler/019/019-tests.factor
new file mode 100644
index 0000000000..543c01b06e
--- /dev/null
+++ b/extra/project-euler/019/019-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.019 tools.test ;
+IN: project-euler.019.tests
+
+[ 171 ] [ euler019 ] unit-test
+[ 171 ] [ euler019a ] unit-test
diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor
index 9482b337bb..62e2e066ff 100644
--- a/extra/project-euler/019/019.factor
+++ b/extra/project-euler/019/019.factor
@@ -36,7 +36,7 @@ IN: project-euler.019
     ] map concat [ zero? ] count ;
 
 ! [ euler019 ] 100 ave-time
-! 1 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.51 SD (100 trials)
 
 
 ! ALTERNATE SOLUTIONS
@@ -61,6 +61,6 @@ PRIVATE>
     end-date start-date first-days [ zero? ] count ;
 
 ! [ euler019a ] 100 ave-time
-! 131 ms run / 3 ms GC ave time - 100 trials
+! 17 ms ave run time - 2.13 SD (100 trials)
 
 MAIN: euler019
diff --git a/extra/project-euler/020/020-tests.factor b/extra/project-euler/020/020-tests.factor
new file mode 100644
index 0000000000..2d9175bb18
--- /dev/null
+++ b/extra/project-euler/020/020-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.020 tools.test ;
+IN: project-euler.020.tests
+
+[ 648 ] [ euler020 ] unit-test
diff --git a/extra/project-euler/021/021-tests.factor b/extra/project-euler/021/021-tests.factor
new file mode 100644
index 0000000000..f20ae562c2
--- /dev/null
+++ b/extra/project-euler/021/021-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.021 tools.test ;
+IN: project-euler.021.tests
+
+[ 31626 ] [ euler021 ] unit-test
diff --git a/extra/project-euler/021/021.factor b/extra/project-euler/021/021.factor
index af6bb3270b..2e2f6a6453 100644
--- a/extra/project-euler/021/021.factor
+++ b/extra/project-euler/021/021.factor
@@ -33,6 +33,6 @@ IN: project-euler.021
     10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ;
 
 ! [ euler021 ] 100 ave-time
-! 328 ms run / 10 ms GC ave time - 100 trials
+! 335 ms ave run time - 18.63 SD (100 trials)
 
 MAIN: euler021
diff --git a/extra/project-euler/022/022-tests.factor b/extra/project-euler/022/022-tests.factor
new file mode 100644
index 0000000000..bcd5c18166
--- /dev/null
+++ b/extra/project-euler/022/022-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.022 tools.test ;
+IN: project-euler.022.tests
+
+[ 871198282 ] [ euler022 ] unit-test
diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor
index a508ddea6c..a12838406a 100644
--- a/extra/project-euler/022/022.factor
+++ b/extra/project-euler/022/022.factor
@@ -40,6 +40,6 @@ PRIVATE>
     source-022 natural-sort name-scores sum ;
 
 ! [ euler022 ] 100 ave-time
-! 123 ms run / 4 ms GC ave time - 100 trials
+! 74 ms ave run time - 5.13 SD (100 trials)
 
 MAIN: euler022
diff --git a/extra/project-euler/023/023-tests.factor b/extra/project-euler/023/023-tests.factor
new file mode 100644
index 0000000000..bba4173147
--- /dev/null
+++ b/extra/project-euler/023/023-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.023 tools.test ;
+IN: project-euler.023.tests
+
+[ 4179871 ] [ euler023 ] unit-test
diff --git a/extra/project-euler/024/024-tests.factor b/extra/project-euler/024/024-tests.factor
new file mode 100644
index 0000000000..fe722e587e
--- /dev/null
+++ b/extra/project-euler/024/024-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.024 tools.test ;
+IN: project-euler.024.tests
+
+[ 2783915460 ] [ euler024 ] unit-test
diff --git a/extra/project-euler/024/024.factor b/extra/project-euler/024/024.factor
index 0cc0c39e07..c10ce418c4 100755
--- a/extra/project-euler/024/024.factor
+++ b/extra/project-euler/024/024.factor
@@ -26,6 +26,6 @@ IN: project-euler.024
     999999 10 permutation 10 digits>integer ;
 
 ! [ euler024 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.27 SD (100 trials)
 
 MAIN: euler024
diff --git a/extra/project-euler/025/025-tests.factor b/extra/project-euler/025/025-tests.factor
new file mode 100644
index 0000000000..0de6820de9
--- /dev/null
+++ b/extra/project-euler/025/025-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.025 tools.test ;
+IN: project-euler.025.tests
+
+[ 4782 ] [ euler025 ] unit-test
+[ 4782 ] [ euler025a ] unit-test
diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor
index 6d15a9f6ec..a2934c23c7 100644
--- a/extra/project-euler/025/025.factor
+++ b/extra/project-euler/025/025.factor
@@ -55,7 +55,7 @@ PRIVATE>
     1000 digit-fib ;
 
 ! [ euler025 ] 10 ave-time
-! 5237 ms run / 72 ms GC ave time - 10 trials
+! 5345 ms ave run time - 105.91 SD (10 trials)
 
 
 ! ALTERNATE SOLUTIONS
@@ -76,6 +76,6 @@ PRIVATE>
     1000 digit-fib* ;
 
 ! [ euler025a ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.17 SD (100 trials)
 
 MAIN: euler025a
diff --git a/extra/project-euler/026/026-tests.factor b/extra/project-euler/026/026-tests.factor
new file mode 100644
index 0000000000..1b9b953c26
--- /dev/null
+++ b/extra/project-euler/026/026-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.026 tools.test ;
+IN: project-euler.026.tests
+
+[ 983 ] [ euler026 ] unit-test
diff --git a/extra/project-euler/026/026.factor b/extra/project-euler/026/026.factor
index 8cbf20d0bf..cf30d0ee42 100644
--- a/extra/project-euler/026/026.factor
+++ b/extra/project-euler/026/026.factor
@@ -66,6 +66,6 @@ PRIVATE>
     source-026 max-period drop denominator ;
 
 ! [ euler026 ] 100 ave-time
-! 724 ms run / 7 ms GC ave time - 100 trials
+! 290 ms ave run time - 19.2 SD (100 trials)
 
 MAIN: euler026
diff --git a/extra/project-euler/027/027-tests.factor b/extra/project-euler/027/027-tests.factor
new file mode 100644
index 0000000000..614d8a547d
--- /dev/null
+++ b/extra/project-euler/027/027-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.027 tools.test ;
+IN: project-euler.027.tests
+
+[ -59231 ] [ euler027 ] unit-test
diff --git a/extra/project-euler/027/027.factor b/extra/project-euler/027/027.factor
index 7680112af7..5bf753074e 100644
--- a/extra/project-euler/027/027.factor
+++ b/extra/project-euler/027/027.factor
@@ -68,7 +68,7 @@ PRIVATE>
     source-027 max-consecutive drop product ;
 
 ! [ euler027 ] 100 ave-time
-! 687 ms run / 23 ms GC ave time - 100 trials
+! 111 ms ave run time - 6.07 SD (100 trials)
 
 ! TODO: generalize max-consecutive/max-product (from #26) into a new word
 
diff --git a/extra/project-euler/028/028-tests.factor b/extra/project-euler/028/028-tests.factor
new file mode 100644
index 0000000000..fea5ef1c80
--- /dev/null
+++ b/extra/project-euler/028/028-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.028 tools.test ;
+IN: project-euler.028.tests
+
+[ 669171001 ] [ euler028 ] unit-test
diff --git a/extra/project-euler/029/029-tests.factor b/extra/project-euler/029/029-tests.factor
new file mode 100644
index 0000000000..5fd064fb0b
--- /dev/null
+++ b/extra/project-euler/029/029-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.029 tools.test ;
+IN: project-euler.029.tests
+
+[ 9183 ] [ euler029 ] unit-test
diff --git a/extra/project-euler/029/029.factor b/extra/project-euler/029/029.factor
index 9cfe0aacff..2586e6182a 100644
--- a/extra/project-euler/029/029.factor
+++ b/extra/project-euler/029/029.factor
@@ -32,6 +32,6 @@ IN: project-euler.029
     2 100 [a,b] dup cartesian-product [ first2 ^ ] map prune length ;
 
 ! [ euler029 ] 100 ave-time
-! 951 ms run / 12 ms GC ave time - 100 trials
+! 704 ms ave run time - 28.07 SD (100 trials)
 
 MAIN: euler029
diff --git a/extra/project-euler/030/030-tests.factor b/extra/project-euler/030/030-tests.factor
new file mode 100644
index 0000000000..3b0d03025b
--- /dev/null
+++ b/extra/project-euler/030/030-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.030 tools.test ;
+IN: project-euler.030.tests
+
+[ 443839 ] [ euler030 ] unit-test
diff --git a/extra/project-euler/030/030.factor b/extra/project-euler/030/030.factor
index 250494c0dc..63693f96d8 100644
--- a/extra/project-euler/030/030.factor
+++ b/extra/project-euler/030/030.factor
@@ -41,6 +41,6 @@ PRIVATE>
     325537 [ dup sum-fifth-powers = ] filter sum 1- ;
 
 ! [ euler030 ] 100 ave-time
-! 2537 ms run / 125 ms GC ave time - 100 trials
+! 1700 ms ave run time - 64.84 SD (100 trials)
 
 MAIN: euler030
diff --git a/extra/project-euler/031/031-tests.factor b/extra/project-euler/031/031-tests.factor
new file mode 100644
index 0000000000..5e81717368
--- /dev/null
+++ b/extra/project-euler/031/031-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.031 tools.test ;
+IN: project-euler.031.tests
+
+[ 73682 ] [ euler031 ] unit-test
diff --git a/extra/project-euler/032/032-tests.factor b/extra/project-euler/032/032-tests.factor
new file mode 100644
index 0000000000..039c31df1b
--- /dev/null
+++ b/extra/project-euler/032/032-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.032 tools.test ;
+IN: project-euler.032.tests
+
+[ 45228 ] [ euler032 ] unit-test
+[ 45228 ] [ euler032a ] unit-test
diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor
index 02c1d44e43..07c643659c 100755
--- a/extra/project-euler/032/032.factor
+++ b/extra/project-euler/032/032.factor
@@ -49,7 +49,7 @@ PRIVATE>
     source-032 [ valid? ] filter products prune sum ;
 
 ! [ euler032 ] 10 ave-time
-! 23922 ms run / 1505 ms GC ave time - 10 trials
+! 16361 ms ave run time - 417.8 SD (10 trials)
 
 
 ! ALTERNATE SOLUTIONS
@@ -72,7 +72,7 @@ PRIVATE>
 : euler032a ( -- answer )
     source-032a [ mmp ] map [ pandigital? ] filter products prune sum ;
 
-! [ euler032a ] 100 ave-time
-! 5978 ms run / 327 ms GC ave time - 100 trials
+! [ euler032a ] 10 ave-time
+! 2624 ms ave run time - 131.91 SD (10 trials)
 
 MAIN: euler032a
diff --git a/extra/project-euler/033/033-tests.factor b/extra/project-euler/033/033-tests.factor
new file mode 100644
index 0000000000..e57d623692
--- /dev/null
+++ b/extra/project-euler/033/033-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.033 tools.test ;
+IN: project-euler.033.tests
+
+[ 100 ] [ euler033 ] unit-test
diff --git a/extra/project-euler/033/033.factor b/extra/project-euler/033/033.factor
index 8cb0dc45c3..d0c79c220a 100644
--- a/extra/project-euler/033/033.factor
+++ b/extra/project-euler/033/033.factor
@@ -50,6 +50,6 @@ PRIVATE>
     source-033 curious-fractions product denominator ;
 
 ! [ euler033 ] 100 ave-time
-! 5 ms run / 0 ms GC ave time - 100 trials
+! 7 ms ave run time - 1.31 SD (100 trials)
 
 MAIN: euler033
diff --git a/extra/project-euler/034/034-tests.factor b/extra/project-euler/034/034-tests.factor
new file mode 100644
index 0000000000..56d2bbb517
--- /dev/null
+++ b/extra/project-euler/034/034-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.034 tools.test ;
+IN: project-euler.034.tests
+
+[ 40730 ] [ euler034 ] unit-test
diff --git a/extra/project-euler/034/034.factor b/extra/project-euler/034/034.factor
index 28c4fa5dc7..11b7efa8b5 100644
--- a/extra/project-euler/034/034.factor
+++ b/extra/project-euler/034/034.factor
@@ -42,6 +42,6 @@ PRIVATE>
     3 2000000 [a,b] [ factorion? ] filter sum ;
 
 ! [ euler034 ] 10 ave-time
-! 15089 ms run / 725 ms GC ave time - 10 trials
+! 5506 ms ave run time - 144.0 SD (10 trials)
 
 MAIN: euler034
diff --git a/extra/project-euler/035/035-tests.factor b/extra/project-euler/035/035-tests.factor
new file mode 100644
index 0000000000..0ede690e17
--- /dev/null
+++ b/extra/project-euler/035/035-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.035 tools.test ;
+IN: project-euler.035.tests
+
+[ 55 ] [ euler035 ] unit-test
diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor
index 8e8b654d28..517e5211d2 100755
--- a/extra/project-euler/035/035.factor
+++ b/extra/project-euler/035/035.factor
@@ -53,7 +53,7 @@ PRIVATE>
     source-035 [ possible? ] filter [ circular? ] count ;
 
 ! [ euler035 ] 100 ave-time
-! 904 ms run / 86 ms GC ave time - 100 trials
+! 538 ms ave run time - 17.16 SD (100 trials)
 
 ! TODO: try using bit arrays or other methods outlined here:
 !     http://home.comcast.net/~babdulbaki/Circular_Primes.html
diff --git a/extra/project-euler/036/036-tests.factor b/extra/project-euler/036/036-tests.factor
new file mode 100644
index 0000000000..07c2d76915
--- /dev/null
+++ b/extra/project-euler/036/036-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.036 tools.test ;
+IN: project-euler.036.tests
+
+[ 872187 ] [ euler036 ] unit-test
diff --git a/extra/project-euler/036/036.factor b/extra/project-euler/036/036.factor
index fc9df9a8fe..02d9372a8b 100644
--- a/extra/project-euler/036/036.factor
+++ b/extra/project-euler/036/036.factor
@@ -35,6 +35,6 @@ PRIVATE>
     1 1000000 2 <range> [ both-bases? ] filter sum ;
 
 ! [ euler036 ] 100 ave-time
-! 3891 ms run / 173 ms GC ave time - 100 trials
+! 1703 ms ave run time - 96.6 SD (100 trials)
 
 MAIN: euler036
diff --git a/extra/project-euler/037/037-tests.factor b/extra/project-euler/037/037-tests.factor
new file mode 100644
index 0000000000..b661e5be08
--- /dev/null
+++ b/extra/project-euler/037/037-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.037 tools.test ;
+IN: project-euler.037.tests
+
+[ 748317 ] [ euler037 ] unit-test
diff --git a/extra/project-euler/037/037.factor b/extra/project-euler/037/037.factor
index a5bc0581e6..4562c4588f 100755
--- a/extra/project-euler/037/037.factor
+++ b/extra/project-euler/037/037.factor
@@ -47,6 +47,6 @@ PRIVATE>
     23 1000000 primes-between [ r-trunc? ] filter [ l-trunc? ] filter sum ;
 
 ! [ euler037 ] 100 ave-time
-! 768 ms run / 9 ms GC ave time - 100 trials
+! 130 ms ave run time - 6.27 SD (100 trials)
 
 MAIN: euler037
diff --git a/extra/project-euler/038/038-tests.factor b/extra/project-euler/038/038-tests.factor
new file mode 100644
index 0000000000..0bad869943
--- /dev/null
+++ b/extra/project-euler/038/038-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.038 tools.test ;
+IN: project-euler.038.tests
+
+[ 932718654 ] [ euler038 ] unit-test
diff --git a/extra/project-euler/038/038.factor b/extra/project-euler/038/038.factor
index 05bab5fc36..2df993b341 100755
--- a/extra/project-euler/038/038.factor
+++ b/extra/project-euler/038/038.factor
@@ -51,6 +51,6 @@ PRIVATE>
     9123 9876 [a,b] [ concat-product ] map [ pandigital? ] filter supremum ;
 
 ! [ euler038 ] 100 ave-time
-! 37 ms run / 1 ms GC ave time - 100 trials
+! 11 ms ave run time - 1.5 SD (100 trials)
 
 MAIN: euler038
diff --git a/extra/project-euler/039/039-tests.factor b/extra/project-euler/039/039-tests.factor
new file mode 100644
index 0000000000..742550a6cf
--- /dev/null
+++ b/extra/project-euler/039/039-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.039 tools.test ;
+IN: project-euler.039.tests
+
+[ 840 ] [ euler039 ] unit-test
diff --git a/extra/project-euler/039/039.factor b/extra/project-euler/039/039.factor
index d0caa6d0e4..6b56015667 100755
--- a/extra/project-euler/039/039.factor
+++ b/extra/project-euler/039/039.factor
@@ -60,6 +60,6 @@ PRIVATE>
     ] with-scope ;
 
 ! [ euler039 ] 100 ave-time
-! 2 ms run / 0 ms GC ave time - 100 trials
+! 1 ms ave run time - 0.37 SD (100 trials)
 
 MAIN: euler039
diff --git a/extra/project-euler/040/040-tests.factor b/extra/project-euler/040/040-tests.factor
new file mode 100644
index 0000000000..5934e65ed6
--- /dev/null
+++ b/extra/project-euler/040/040-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.040 tools.test ;
+IN: project-euler.040.tests
+
+[ 210 ] [ euler040 ] unit-test
diff --git a/extra/project-euler/040/040.factor b/extra/project-euler/040/040.factor
index e2df1df2c9..6b8a3f267a 100755
--- a/extra/project-euler/040/040.factor
+++ b/extra/project-euler/040/040.factor
@@ -46,6 +46,6 @@ PRIVATE>
     [ swap nth-integer ] with map product ;
 
 ! [ euler040 ] 100 ave-time
-! 1002 ms run / 43 ms GC ave time - 100 trials
+! 444 ms ave run time - 23.64 SD (100 trials)
 
 MAIN: euler040
diff --git a/extra/project-euler/041/041-tests.factor b/extra/project-euler/041/041-tests.factor
new file mode 100644
index 0000000000..5226860bd0
--- /dev/null
+++ b/extra/project-euler/041/041-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.041 tools.test ;
+IN: project-euler.041.tests
+
+[ 7652413 ] [ euler041 ] unit-test
diff --git a/extra/project-euler/041/041.factor b/extra/project-euler/041/041.factor
index 14084cc01d..d6d428a11f 100644
--- a/extra/project-euler/041/041.factor
+++ b/extra/project-euler/041/041.factor
@@ -35,6 +35,6 @@ IN: project-euler.041
     [ 10 digits>integer ] map [ prime? ] find nip ;
 
 ! [ euler041 ] 100 ave-time
-! 107 ms run / 7 ms GC ave time - 100 trials
+! 64 ms ave run time - 4.22 SD (100 trials)
 
 MAIN: euler041
diff --git a/extra/project-euler/042/042-tests.factor b/extra/project-euler/042/042-tests.factor
new file mode 100644
index 0000000000..ef8f06f9e0
--- /dev/null
+++ b/extra/project-euler/042/042-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.042 tools.test ;
+IN: project-euler.042.tests
+
+[ 162 ] [ euler042 ] unit-test
+[ 162 ] [ euler042a ] unit-test
diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor
index 009570d92c..c8236db118 100644
--- a/extra/project-euler/042/042.factor
+++ b/extra/project-euler/042/042.factor
@@ -50,7 +50,7 @@ PRIVATE>
     triangle-upto [ member? ] curry count ;
 
 ! [ euler042 ] 100 ave-time
-! 27 ms run / 1 ms GC ave time - 100 trials
+! 19 ms ave run time - 1.97 SD (100 trials)
 
 
 ! ALTERNATE SOLUTIONS
@@ -69,6 +69,6 @@ PRIVATE>
     source-042 [ alpha-value ] map [ triangle? ] count ;
 
 ! [ euler042a ] 100 ave-time
-! 25 ms run / 1 ms GC ave time - 100 trials
+! 21 ms ave run time - 2.2 SD (100 trials)
 
 MAIN: euler042a
diff --git a/extra/project-euler/043/043-tests.factor b/extra/project-euler/043/043-tests.factor
new file mode 100644
index 0000000000..4c96721db2
--- /dev/null
+++ b/extra/project-euler/043/043-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.043 tools.test ;
+IN: project-euler.043.tests
+
+[ 16695334890 ] [ euler043 ] unit-test
+[ 16695334890 ] [ euler043a ] unit-test
diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index 9eb78e5153..28dc0b8bd6 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -56,7 +56,7 @@ PRIVATE>
     [ interesting? ] filter [ 10 digits>integer ] map sum ;
 
 ! [ euler043 ] time
-! 125196 ms run / 19548 ms GC time
+! 104526 ms run / 42735 ms GC time
 
 
 ! ALTERNATE SOLUTIONS
@@ -92,6 +92,6 @@ PRIVATE>
     interesting-pandigitals [ 10 digits>integer ] sigma ;
 
 ! [ euler043a ] 100 ave-time
-! 12 ms ave run time - 2.32 SD (100 trials)
+! 10 ms ave run time - 1.37 SD (100 trials)
 
 MAIN: euler043a
diff --git a/extra/project-euler/044/044-tests.factor b/extra/project-euler/044/044-tests.factor
new file mode 100644
index 0000000000..df93dd6a1b
--- /dev/null
+++ b/extra/project-euler/044/044-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.044 tools.test ;
+IN: project-euler.044.tests
+
+[ 5482660 ] [ euler044 ] unit-test
diff --git a/extra/project-euler/044/044.factor b/extra/project-euler/044/044.factor
index 0af3a3167e..e7b1959023 100644
--- a/extra/project-euler/044/044.factor
+++ b/extra/project-euler/044/044.factor
@@ -40,7 +40,7 @@ PRIVATE>
     [ first2 sum-and-diff? ] filter [ first2 - abs ] map infimum ;
 
 ! [ euler044 ] 10 ave-time
-! 5727 ms ave run time - 1102.38 SD (10 trials)
+! 4996 ms ave run time - 87.46 SD (10 trials)
 
 ! TODO: this solution is ugly and not very efficient...find a better algorithm
 
diff --git a/extra/project-euler/045/045-tests.factor b/extra/project-euler/045/045-tests.factor
new file mode 100644
index 0000000000..4beb8f8e3c
--- /dev/null
+++ b/extra/project-euler/045/045-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.045 tools.test ;
+IN: project-euler.045.tests
+
+[ 1533776805 ] [ euler045 ] unit-test
diff --git a/extra/project-euler/045/045.factor b/extra/project-euler/045/045.factor
index d9cf8c99f8..ca5cd83f41 100644
--- a/extra/project-euler/045/045.factor
+++ b/extra/project-euler/045/045.factor
@@ -44,6 +44,6 @@ PRIVATE>
     143 next-solution ;
 
 ! [ euler045 ] 100 ave-time
-! 18 ms run / 1 ms GC ave time - 100 trials
+! 12 ms ave run time - 1.71 SD (100 trials)
 
 MAIN: euler045
diff --git a/extra/project-euler/046/046-tests.factor b/extra/project-euler/046/046-tests.factor
new file mode 100644
index 0000000000..ecfff9dd77
--- /dev/null
+++ b/extra/project-euler/046/046-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.046 tools.test ;
+IN: project-euler.046.tests
+
+[ 5777 ] [ euler046 ] unit-test
diff --git a/extra/project-euler/046/046.factor b/extra/project-euler/046/046.factor
index 1e7630c142..7f5ad9e0d8 100644
--- a/extra/project-euler/046/046.factor
+++ b/extra/project-euler/046/046.factor
@@ -47,6 +47,6 @@ PRIVATE>
     9 disprove-conjecture ;
 
 ! [ euler046 ] 100 ave-time
-! 150 ms run / 2 ms GC ave time - 100 trials
+! 37 ms ave run time - 3.39 SD (100 trials)
 
 MAIN: euler046
diff --git a/extra/project-euler/047/047-tests.factor b/extra/project-euler/047/047-tests.factor
new file mode 100644
index 0000000000..fb3c72f736
--- /dev/null
+++ b/extra/project-euler/047/047-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.047 tools.test ;
+IN: project-euler.047.tests
+
+[ 134043 ] [ euler047 ] unit-test
+[ 134043 ] [ euler047a ] unit-test
diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor
index 87a1387887..84041babb7 100644
--- a/extra/project-euler/047/047.factor
+++ b/extra/project-euler/047/047.factor
@@ -49,7 +49,7 @@ PRIVATE>
     4 646 consecutive ;
 
 ! [ euler047 ] time
-! 542708 ms run / 60548 ms GC time
+! 344688 ms run / 20727 ms GC time
 
 
 ! ALTERNATE SOLUTIONS
@@ -88,7 +88,7 @@ PRIVATE>
     4 200000 consecutive-under ;
 
 ! [ euler047a ] 100 ave-time
-! 503 ms run / 5 ms GC ave time - 100 trials
+! 331 ms ave run time - 19.14 SD (100 trials)
 
 ! TODO: I don't like that you have to specify the upper bound, maybe try making
 ! this lazy so it could also short-circuit when it finds the answer?
diff --git a/extra/project-euler/048/048-tests.factor b/extra/project-euler/048/048-tests.factor
new file mode 100644
index 0000000000..172623ab05
--- /dev/null
+++ b/extra/project-euler/048/048-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.048 tools.test ;
+IN: project-euler.048.tests
+
+[ 9110846700 ] [ euler048 ] unit-test
diff --git a/extra/project-euler/052/052-tests.factor b/extra/project-euler/052/052-tests.factor
new file mode 100644
index 0000000000..be032c86a3
--- /dev/null
+++ b/extra/project-euler/052/052-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.052 tools.test ;
+IN: project-euler.052.tests
+
+[ 142857 ] [ euler052 ] unit-test
diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor
index 3f562baa85..cfbb718200 100644
--- a/extra/project-euler/052/052.factor
+++ b/extra/project-euler/052/052.factor
@@ -46,6 +46,6 @@ PRIVATE>
     6 123456 next-all-same ;
 
 ! [ euler052 ] 100 ave-time
-! 403 ms run / 7 ms GC ave time - 100 trials
+! 92 ms ave run time - 6.29 SD (100 trials)
 
 MAIN: euler052
diff --git a/extra/project-euler/053/053-tests.factor b/extra/project-euler/053/053-tests.factor
new file mode 100644
index 0000000000..6c9ffaea97
--- /dev/null
+++ b/extra/project-euler/053/053-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.053 tools.test ;
+IN: project-euler.053.tests
+
+[ 4075 ] [ euler053 ] unit-test
diff --git a/extra/project-euler/053/053.factor b/extra/project-euler/053/053.factor
index b2a50e4ac7..d264bca4bf 100644
--- a/extra/project-euler/053/053.factor
+++ b/extra/project-euler/053/053.factor
@@ -30,6 +30,6 @@ IN: project-euler.053
     23 100 [a,b] [ dup [ nCk 1000000 > ] with count ] sigma ;
 
 ! [ euler053 ] 100 ave-time
-! 64 ms run / 2 ms GC ave time - 100 trials
+! 52 ms ave run time - 4.44 SD (100 trials)
 
 MAIN: euler053
diff --git a/extra/project-euler/055/055-tests.factor b/extra/project-euler/055/055-tests.factor
new file mode 100644
index 0000000000..ad23695da6
--- /dev/null
+++ b/extra/project-euler/055/055-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.055 tools.test ;
+IN: project-euler.055.tests
+
+[ 249 ] [ euler055 ] unit-test
diff --git a/extra/project-euler/055/055.factor b/extra/project-euler/055/055.factor
index bf1dd43b97..d07d0c8e31 100644
--- a/extra/project-euler/055/055.factor
+++ b/extra/project-euler/055/055.factor
@@ -64,6 +64,6 @@ PRIVATE>
     10000 [ lychrel? ] count ;
 
 ! [ euler055 ] 100 ave-time
-! 1370 ms run / 31 ms GC ave time - 100 trials
+! 478 ms ave run time - 30.63 SD (100 trials)
 
 MAIN: euler055
diff --git a/extra/project-euler/056/056-tests.factor b/extra/project-euler/056/056-tests.factor
new file mode 100644
index 0000000000..b1f37514d1
--- /dev/null
+++ b/extra/project-euler/056/056-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.056 tools.test ;
+IN: project-euler.056.tests
+
+[ 972 ] [ euler056 ] unit-test
diff --git a/extra/project-euler/056/056.factor b/extra/project-euler/056/056.factor
index 0efe32b254..34626b796d 100644
--- a/extra/project-euler/056/056.factor
+++ b/extra/project-euler/056/056.factor
@@ -26,6 +26,6 @@ IN: project-euler.056
     [ first2 ^ number>digits sum ] map supremum ;
 
 ! [ euler056 ] 100 ave-time
-! 33 ms run / 1 ms GC ave time - 100 trials
+! 22 ms ave run time - 2.13 SD (100 trials)
 
 MAIN: euler056
diff --git a/extra/project-euler/059/059-tests.factor b/extra/project-euler/059/059-tests.factor
new file mode 100644
index 0000000000..231c7339a3
--- /dev/null
+++ b/extra/project-euler/059/059-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.059 tools.test ;
+IN: project-euler.059.tests
+
+[ 107359 ] [ euler059 ] unit-test
diff --git a/extra/project-euler/059/059.factor b/extra/project-euler/059/059.factor
index e3ab9762d8..bbeeff1eec 100644
--- a/extra/project-euler/059/059.factor
+++ b/extra/project-euler/059/059.factor
@@ -87,6 +87,6 @@ PRIVATE>
     source-059 dup 3 crack-key decrypt sum ;
 
 ! [ euler059 ] 100 ave-time
-! 13 ms run / 0 ms GC ave time - 100 trials
+! 8 ms ave run time - 1.4 SD (100 trials)
 
 MAIN: euler059
diff --git a/extra/project-euler/067/067-tests.factor b/extra/project-euler/067/067-tests.factor
new file mode 100644
index 0000000000..1e8940f91e
--- /dev/null
+++ b/extra/project-euler/067/067-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.067 tools.test ;
+IN: project-euler.067.tests
+
+[ 7273 ] [ euler067 ] unit-test
+[ 7273 ] [ euler067a ] unit-test
diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor
index 3e16996e04..3f9d67091d 100644
--- a/extra/project-euler/067/067.factor
+++ b/extra/project-euler/067/067.factor
@@ -47,7 +47,7 @@ PRIVATE>
     source-067 propagate-all first first ;
 
 ! [ euler067 ] 100 ave-time
-! 18 ms run / 0 ms GC time
+! 20 ms ave run time - 2.12 SD (100 trials)
 
 
 ! ALTERNATE SOLUTIONS
@@ -57,6 +57,6 @@ PRIVATE>
     source-067 max-path ;
 
 ! [ euler067a ] 100 ave-time
-! 14 ms run / 0 ms GC ave time - 100 trials
+! 21 ms ave run time - 2.65 SD (100 trials)
 
 MAIN: euler067a
diff --git a/extra/project-euler/075/075-tests.factor b/extra/project-euler/075/075-tests.factor
new file mode 100644
index 0000000000..8c69a99e1b
--- /dev/null
+++ b/extra/project-euler/075/075-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.075 tools.test ;
+IN: project-euler.075.tests
+
+[ 214954 ] [ euler075 ] unit-test
diff --git a/extra/project-euler/075/075.factor b/extra/project-euler/075/075.factor
index 76f2a2a26e..2b5b931165 100755
--- a/extra/project-euler/075/075.factor
+++ b/extra/project-euler/075/075.factor
@@ -26,7 +26,7 @@ IN: project-euler.075
 
 !     120 cm: (30,40,50), (20,48,52), (24,45,51)
 
-! Given that L is the length of the wire, for how many values of L ≤ 1,000,000
+! Given that L is the length of the wire, for how many values of L ≤ 2,000,000
 ! can exactly one right angle triangle be formed?
 
 
@@ -36,9 +36,9 @@ IN: project-euler.075
 ! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html
 ! Identical implementation as problem #39
 
-! Basically, this makes an array of 1000000 zeros, recursively creates
+! Basically, this makes an array of 2000000 zeros, recursively creates
 ! primitive triples using the three transforms and then increments the array at
-! index [a+b+c] by one for each triple's sum AND its multiples under 1000000
+! index [a+b+c] by one for each triple's sum AND its multiples under 2000000
 ! (to account for non-primitive triples). The answer is just the total number
 ! of indexes that are equal to one.
 
@@ -69,10 +69,10 @@ PRIVATE>
 
 : euler075 ( -- answer )
     [
-        1000000 count-perimeters p-count get [ 1 = ] count
+        2000000 count-perimeters p-count get [ 1 = ] count
     ] with-scope ;
 
-! [ euler075 ] 100 ave-time
-! 1873 ms run / 123 ms GC ave time - 100 trials
+! [ euler075 ] 10 ave-time
+! 3341 ms ave run timen - 157.77 SD (10 trials)
 
 MAIN: euler075
diff --git a/extra/project-euler/076/076-tests.factor b/extra/project-euler/076/076-tests.factor
new file mode 100644
index 0000000000..9d435b1f30
--- /dev/null
+++ b/extra/project-euler/076/076-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.076 tools.test ;
+IN: project-euler.076.tests
+
+[ 190569291 ] [ euler076 ] unit-test
diff --git a/extra/project-euler/079/079-tests.factor b/extra/project-euler/079/079-tests.factor
new file mode 100644
index 0000000000..d9f47cffb8
--- /dev/null
+++ b/extra/project-euler/079/079-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.079 tools.test ;
+IN: project-euler.079.tests
+
+[ 73162890 ] [ euler079 ] unit-test
diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor
index 29b76c7ba4..ad75c43c42 100644
--- a/extra/project-euler/079/079.factor
+++ b/extra/project-euler/079/079.factor
@@ -58,7 +58,7 @@ PRIVATE>
     source-079 >edges topological-sort 10 digits>integer ;
 
 ! [ euler079 ] 100 ave-time
-! 1 ms ave run time - 1.41 SD (100 trials)
+! 1 ms ave run time - 0.46 SD (100 trials)
 
 ! TODO: prune and diff are relatively slow; topological sort could be
 ! cleaned up and generalized much better, but it works for this problem
diff --git a/extra/project-euler/092/092-tests.factor b/extra/project-euler/092/092-tests.factor
new file mode 100644
index 0000000000..0a89e18504
--- /dev/null
+++ b/extra/project-euler/092/092-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.092 tools.test ;
+IN: project-euler.092.tests
+
+[ 8581146 ] [ euler092 ] unit-test
diff --git a/extra/project-euler/097/097-tests.factor b/extra/project-euler/097/097-tests.factor
new file mode 100644
index 0000000000..3a484032ae
--- /dev/null
+++ b/extra/project-euler/097/097-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.097 tools.test ;
+IN: project-euler.097.tests
+
+[ 8739992577 ] [ euler097 ] unit-test
diff --git a/extra/project-euler/097/097.factor b/extra/project-euler/097/097.factor
index 50e7af563d..6e6547a7e9 100644
--- a/extra/project-euler/097/097.factor
+++ b/extra/project-euler/097/097.factor
@@ -26,6 +26,6 @@ IN: project-euler.097
      2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1+ ;
 
 ! [ euler097 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run timen - 0.22 SD (100 trials)
 
 MAIN: euler097
diff --git a/extra/project-euler/100/100-tests.factor b/extra/project-euler/100/100-tests.factor
new file mode 100644
index 0000000000..bbe84eb86e
--- /dev/null
+++ b/extra/project-euler/100/100-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.100 tools.test ;
+IN: project-euler.100.tests
+
+[ 756872327473 ] [ euler100 ] unit-test
diff --git a/extra/project-euler/100/100.factor b/extra/project-euler/100/100.factor
index fca1bf8af8..98dbba19fd 100644
--- a/extra/project-euler/100/100.factor
+++ b/extra/project-euler/100/100.factor
@@ -28,9 +28,9 @@ IN: project-euler.100
     [ dup dup 1- * 2 * 10 24 ^ <= ]
     [ tuck 6 * swap - 2 - ] [ ] while nip ;
 
-! TODO: solution is incredibly slow (>30 minutes) and needs generalization
+! TODO: solution needs generalization
 
-! [ euler100 ] time
-! ? ms run time
+! [ euler100 ] 100 ave-time
+! 0 ms ave run time - 0.14 SD (100 trials)
 
 MAIN: euler100
diff --git a/extra/project-euler/116/116-tests.factor b/extra/project-euler/116/116-tests.factor
new file mode 100644
index 0000000000..fae67f3d2d
--- /dev/null
+++ b/extra/project-euler/116/116-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.116 tools.test ;
+IN: project-euler.116.tests
+
+[ 20492570929 ] [ euler116 ] unit-test
diff --git a/extra/project-euler/116/116.factor b/extra/project-euler/116/116.factor
index 0e3633dc9a..742fe9d625 100644
--- a/extra/project-euler/116/116.factor
+++ b/extra/project-euler/116/116.factor
@@ -55,6 +55,6 @@ PRIVATE>
     50 (euler116) ;
 
 ! [ euler116 ] 100 ave-time
-! 0 ms run time - 100 trials
+! 0 ms ave run time - 0.34 SD (100 trials)
 
 MAIN: euler116
diff --git a/extra/project-euler/117/117-tests.factor b/extra/project-euler/117/117-tests.factor
new file mode 100644
index 0000000000..ba677cf49d
--- /dev/null
+++ b/extra/project-euler/117/117-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.117 tools.test ;
+IN: project-euler.117.tests
+
+[ 100808458960497 ] [ euler117 ] unit-test
diff --git a/extra/project-euler/117/117.factor b/extra/project-euler/117/117.factor
index cc5dea8f37..7174066227 100644
--- a/extra/project-euler/117/117.factor
+++ b/extra/project-euler/117/117.factor
@@ -42,6 +42,6 @@ PRIVATE>
     50 (euler117) ;
 
 ! [ euler117 ] 100 ave-time
-! 0 ms run time - 100 trials
+! 0 ms ave run time - 0.29 SD (100 trials)
 
 MAIN: euler117
diff --git a/extra/project-euler/134/134-tests.factor b/extra/project-euler/134/134-tests.factor
new file mode 100644
index 0000000000..63c25eaf58
--- /dev/null
+++ b/extra/project-euler/134/134-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.134 tools.test ;
+IN: project-euler.134.tests
+
+[ 18613426663617118 ] [ euler134 ] unit-test
diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor
index 4e54a18f19..7bdf17ef68 100644
--- a/extra/project-euler/134/134.factor
+++ b/extra/project-euler/134/134.factor
@@ -43,6 +43,6 @@ PRIVATE>
     [ [ s + ] keep ] leach drop ;
 
 ! [ euler134 ] 10 ave-time
-! 2430 ms run / 36 ms GC ave time - 10 trials
+! 933 ms ave run timen - 19.58 SD (10 trials)
 
 MAIN: euler134
diff --git a/extra/project-euler/148/148-tests.factor b/extra/project-euler/148/148-tests.factor
new file mode 100644
index 0000000000..66c8f6c45c
--- /dev/null
+++ b/extra/project-euler/148/148-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.148 tools.test ;
+IN: project-euler.148.tests
+
+[ 2129970655314432 ] [ euler148 ] unit-test
diff --git a/extra/project-euler/148/148.factor b/extra/project-euler/148/148.factor
index 0509936e52..533874fa67 100644
--- a/extra/project-euler/148/148.factor
+++ b/extra/project-euler/148/148.factor
@@ -49,6 +49,6 @@ PRIVATE>
     10 9 ^ (euler148) ;
 
 ! [ euler148 ] 100 ave-time
-! 0 ms run time - 100 trials
+! 0 ms ave run time - 0.17 SD (100 trials)
 
 MAIN: euler148
diff --git a/extra/project-euler/150/150-tests.factor b/extra/project-euler/150/150-tests.factor
new file mode 100644
index 0000000000..19fb31b3eb
--- /dev/null
+++ b/extra/project-euler/150/150-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.150 tools.test ;
+IN: project-euler.150.tests
+
+[ -271248680 ] [ euler150 ] unit-test
diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor
index c7d878edcb..1b84b25d37 100644
--- a/extra/project-euler/150/150.factor
+++ b/extra/project-euler/150/150.factor
@@ -73,6 +73,6 @@ PRIVATE>
     1000 (euler150) ;
 
 ! [ euler150 ] 10 ave-time
-! 32858 ms run time - 10 trials
+! 30208 ms ave run time - 593.45 SD (10 trials)
 
 MAIN: euler150
diff --git a/extra/project-euler/164/164-tests.factor b/extra/project-euler/164/164-tests.factor
new file mode 100644
index 0000000000..013e8bd872
--- /dev/null
+++ b/extra/project-euler/164/164-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.164 tools.test ;
+IN: project-euler.164.tests
+
+[ 378158756814587 ] [ euler164 ] unit-test
diff --git a/extra/project-euler/164/164.factor b/extra/project-euler/164/164.factor
index 9d88e49e0e..5bc4fdc74e 100644
--- a/extra/project-euler/164/164.factor
+++ b/extra/project-euler/164/164.factor
@@ -33,6 +33,6 @@ PRIVATE>
     init-table 19 [ next-table ] times values sum ;
 
 ! [ euler164 ] 100 ave-time
-! 8 ms run time - 100 trials
+! 7 ms ave run time - 1.23 SD (100 trials)
 
 MAIN: euler164
diff --git a/extra/project-euler/169/169-tests.factor b/extra/project-euler/169/169-tests.factor
new file mode 100644
index 0000000000..0722e7fa16
--- /dev/null
+++ b/extra/project-euler/169/169-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.169 tools.test ;
+IN: project-euler.169.tests
+
+[ 178653872807 ] [ euler169 ] unit-test
diff --git a/extra/project-euler/169/169.factor b/extra/project-euler/169/169.factor
index 4387662c90..ef43fc3c34 100644
--- a/extra/project-euler/169/169.factor
+++ b/extra/project-euler/169/169.factor
@@ -20,7 +20,7 @@ USING: combinators kernel math math.functions memoize ;
 ! 2 + 4 + 4
 ! 2 + 8
 
-! What is f(1025)?
+! What is f(10^25)?
 
 
 ! SOLUTION
@@ -37,6 +37,6 @@ MEMO: fn ( n -- x )
     10 25 ^ fn ;
 
 ! [ euler169 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.2 SD (100 trials)
 
 MAIN: euler169
diff --git a/extra/project-euler/173/173-tests.factor b/extra/project-euler/173/173-tests.factor
new file mode 100644
index 0000000000..9417ba862f
--- /dev/null
+++ b/extra/project-euler/173/173-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.173 tools.test ;
+IN: project-euler.173.tests
+
+[ 1572729 ] [ euler173 ] unit-test
diff --git a/extra/project-euler/173/173.factor b/extra/project-euler/173/173.factor
index 9f2984d37d..757dfb017a 100644
--- a/extra/project-euler/173/173.factor
+++ b/extra/project-euler/173/173.factor
@@ -33,6 +33,6 @@ PRIVATE>
     1000000 laminae ;
 
 ! [ euler173 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.35 SD (100 trials)
 
 MAIN: euler173
diff --git a/extra/project-euler/175/175-tests.factor b/extra/project-euler/175/175-tests.factor
new file mode 100644
index 0000000000..541aa7dc47
--- /dev/null
+++ b/extra/project-euler/175/175-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.175 tools.test ;
+IN: project-euler.175.tests
+
+[ "1,13717420,8" ] [ euler175 ] unit-test
diff --git a/extra/project-euler/175/175.factor b/extra/project-euler/175/175.factor
index 853bf9a10f..9aebcf565c 100644
--- a/extra/project-euler/175/175.factor
+++ b/extra/project-euler/175/175.factor
@@ -53,6 +53,6 @@ PRIVATE>
     V{ 1 } clone dup 123456789/987654321 compute [ number>string ] map "," join ;
 
 ! [ euler175 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.31 SD (100 trials)
 
 MAIN: euler175
diff --git a/extra/project-euler/186/186-tests.factor b/extra/project-euler/186/186-tests.factor
new file mode 100644
index 0000000000..71d2f1c59b
--- /dev/null
+++ b/extra/project-euler/186/186-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.186 tools.test ;
+IN: project-euler.186.tests
+
+[ 2325629 ] [ euler186 ] unit-test
diff --git a/extra/project-euler/186/186.factor b/extra/project-euler/186/186.factor
index b86f3675a1..679748b3c2 100644
--- a/extra/project-euler/186/186.factor
+++ b/extra/project-euler/186/186.factor
@@ -51,11 +51,10 @@ IN: project-euler.186
     [ first ] [ advance ] bi ;
 
 : 2unless? ( x y ?quot quot -- )
-    >r 2keep rot [ 2drop ] r> if ; inline
+    [ 2keep rot [ 2drop ] ] dip if ; inline
 
 : (p186) ( generator counter unionfind -- counter )
-    524287 over equiv-set-size 990000 <
-    [
+    524287 over equiv-set-size 990000 < [
         pick [ next ] [ next ] bi
         [ = ] [
             pick equate
diff --git a/extra/project-euler/190/190-tests.factor b/extra/project-euler/190/190-tests.factor
new file mode 100644
index 0000000000..edcfa981bb
--- /dev/null
+++ b/extra/project-euler/190/190-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.190 tools.test ;
+IN: project-euler.190.tests
+
+[ 371048281 ] [ euler190 ] unit-test
diff --git a/extra/project-euler/190/190.factor b/extra/project-euler/190/190.factor
index c0b7cb577f..84ab74bb03 100644
--- a/extra/project-euler/190/190.factor
+++ b/extra/project-euler/190/190.factor
@@ -49,6 +49,6 @@ PRIVATE>
     2 15 [a,b] [ P_m truncate ] sigma ;
 
 ! [ euler150 ] 100 ave-time
-! 7 ms run time - 100 trials
+! 5 ms ave run time - 1.01 SD (100 trials)
 
 MAIN: euler190

From 10d3b4a55d63df3002d1d91ad9ca2d3701857d7a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 00:31:08 -0600
Subject: [PATCH 136/318] New PPC backend (untested)

---
 basis/cpu/ppc/allot/allot.factor              | 112 ---
 basis/cpu/ppc/allot/authors.txt               |   1 -
 basis/cpu/ppc/allot/summary.txt               |   1 -
 basis/cpu/ppc/allot/tags.txt                  |   1 -
 .../cpu/ppc/architecture/architecture.factor  | 331 ---------
 basis/cpu/ppc/architecture/authors.txt        |   1 -
 basis/cpu/ppc/architecture/summary.txt        |   1 -
 basis/cpu/ppc/architecture/tags.txt           |   1 -
 basis/cpu/ppc/intrinsics/authors.txt          |   1 -
 basis/cpu/ppc/intrinsics/intrinsics.factor    | 640 ------------------
 basis/cpu/ppc/intrinsics/tags.txt             |   1 -
 basis/cpu/ppc/ppc.factor                      | 558 ++++++++++++++-
 12 files changed, 553 insertions(+), 1096 deletions(-)
 delete mode 100644 basis/cpu/ppc/allot/allot.factor
 delete mode 100644 basis/cpu/ppc/allot/authors.txt
 delete mode 100644 basis/cpu/ppc/allot/summary.txt
 delete mode 100644 basis/cpu/ppc/allot/tags.txt
 delete mode 100644 basis/cpu/ppc/architecture/architecture.factor
 delete mode 100644 basis/cpu/ppc/architecture/authors.txt
 delete mode 100644 basis/cpu/ppc/architecture/summary.txt
 delete mode 100644 basis/cpu/ppc/architecture/tags.txt
 delete mode 100755 basis/cpu/ppc/intrinsics/authors.txt
 delete mode 100644 basis/cpu/ppc/intrinsics/intrinsics.factor
 delete mode 100644 basis/cpu/ppc/intrinsics/tags.txt

diff --git a/basis/cpu/ppc/allot/allot.factor b/basis/cpu/ppc/allot/allot.factor
deleted file mode 100644
index 3190973f26..0000000000
--- a/basis/cpu/ppc/allot/allot.factor
+++ /dev/null
@@ -1,112 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel cpu.ppc.architecture cpu.ppc.assembler
-kernel.private namespaces math sequences generic arrays
-compiler.generator compiler.generator.registers
-compiler.generator.fixup system layouts
-cpu.architecture alien ;
-IN: cpu.ppc.allot
-
-: load-zone-ptr ( reg -- )
-    >r "nursery" f r> %load-dlsym ;
-
-: %allot ( header size -- )
-    #! Store a pointer to 'size' bytes allocated from the
-    #! nursery in r11.
-    8 align ! align the size
-    12 load-zone-ptr ! nusery -> r12
-    11 12 cell LWZ ! nursery.here -> r11
-    11 11 pick ADDI ! increment r11
-    11 12 cell STW ! r11 -> nursery.here
-    11 11 rot SUBI ! old value
-    type-number tag-fixnum 12 LI ! compute header
-    12 11 0 STW ! store header
-    ;
-
-: %store-tagged ( reg tag -- )
-    >r dup fresh-object v>operand 11 r> tag-number ORI ;
-
-M: ppc %gc
-    "end" define-label
-    12 load-zone-ptr
-    11 12 cell LWZ ! nursery.here -> r11
-    12 12 3 cells LWZ ! nursery.end -> r12
-    11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
-    11 0 12 CMP ! is here >= end?
-    "end" get BLE
-    0 frame-required
-    %prepare-alien-invoke
-    "minor_gc" f %alien-invoke
-    "end" resolve-label ;
-
-: %allot-float ( reg -- )
-    #! exits with tagged ptr to object in r12, untagged in r11
-    float 16 %allot
-    11 8 STFD
-    12 11 float tag-number ORI
-    f fresh-object ;
-
-M: ppc %box-float ( dst src -- )
-    [ v>operand ] bi@ %allot-float 12 MR ;
-
-: %allot-bignum ( #digits -- )
-    #! 1 cell header, 1 cell length, 1 cell sign, + digits
-    #! length is the # of digits + sign
-    bignum over 3 + cells %allot
-    1+ v>operand 12 LI ! compute the length
-    12 11 cell STW ! store the length
-    ;
-
-: %allot-bignum-signed-1 ( reg -- )
-    #! on entry, reg is a 30-bit quantity sign-extended to
-    #! 32-bits.
-    #! exits with tagged ptr to bignum in reg
-    [
-        { "end" "non-zero" "pos" "store" } [ define-label ] each
-        ! is it zero?
-        0 over v>operand 0 CMPI
-        "non-zero" get BNE
-        dup 0 >bignum %load-literal
-        "end" get B
-        ! it is non-zero
-        "non-zero" resolve-label
-        1 %allot-bignum
-        ! is the fixnum negative?
-        0 over v>operand 0 CMPI
-        "pos" get BGE
-        1 12 LI
-        ! store negative sign
-        12 11 2 cells STW
-        ! negate fixnum
-        dup v>operand dup -1 MULI
-        "store" get B
-        "pos" resolve-label
-        0 12 LI
-        ! store positive sign
-        12 11 2 cells STW
-        "store" resolve-label
-        ! store the number
-        dup v>operand 11 3 cells STW
-        ! tag the bignum, store it in reg
-        bignum %store-tagged
-        "end" resolve-label
-    ] with-scope ;
-
-M: ppc %box-alien ( dst src -- )
-    { "end" "f" } [ define-label ] each
-    0 over v>operand 0 CMPI
-    "f" get BEQ
-    alien 4 cells %allot
-    ! Store offset
-    v>operand 11 3 cells STW
-    f v>operand 12 LI
-    ! Store expired slot
-    12 11 1 cells STW
-    ! Store underlying-alien slot
-    12 11 2 cells STW
-    ! Store tagged ptr in reg
-    dup object %store-tagged
-    "end" get B
-    "f" resolve-label
-    f v>operand swap v>operand LI
-    "end" resolve-label ;
diff --git a/basis/cpu/ppc/allot/authors.txt b/basis/cpu/ppc/allot/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/basis/cpu/ppc/allot/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/cpu/ppc/allot/summary.txt b/basis/cpu/ppc/allot/summary.txt
deleted file mode 100644
index 3c4941ea1d..0000000000
--- a/basis/cpu/ppc/allot/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-PowerPC inline memory allocation
diff --git a/basis/cpu/ppc/allot/tags.txt b/basis/cpu/ppc/allot/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/basis/cpu/ppc/allot/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor
deleted file mode 100644
index f19b71f3e4..0000000000
--- a/basis/cpu/ppc/architecture/architecture.factor
+++ /dev/null
@@ -1,331 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types cpu.ppc.assembler
-cpu.architecture generic kernel kernel.private math memory
-namespaces sequences words assocs compiler.generator
-compiler.generator.registers compiler.generator.fixup system
-layouts classes words.private alien combinators
-compiler.constants math.order make ;
-IN: cpu.ppc.architecture
-
-! PowerPC register assignments
-! r3-r10, r16-r31: integer vregs
-! f0-f13: float vregs
-! r11, r12: scratch
-! r14: data stack
-! r15: retain stack
-
-: ds-reg 14 ; inline
-: rs-reg 15 ; inline
-
-: reserved-area-size ( -- n )
-    os {
-        { linux [ 2 ] }
-        { macosx [ 6 ] }
-    } case cells ; foldable
-
-: lr-save ( -- n )
-    os {
-        { linux [ 1 ] }
-        { macosx [ 2 ] }
-    } case cells ; foldable
-
-: param@ ( n -- x ) reserved-area-size + ; inline
-
-: param-save-size ( -- n ) 8 cells ; foldable
-
-: local@ ( n -- x )
-    reserved-area-size param-save-size + + ; inline
-
-: factor-area-size ( -- n ) 2 cells ; foldable
-
-: next-save ( n -- i ) cell - ;
-
-: xt-save ( n -- i ) 2 cells - ;
-
-M: ppc stack-frame-size ( n -- i )
-    local@ factor-area-size + 4 cells align ;
-
-M: temp-reg v>operand drop 11 ;
-
-M: int-regs return-reg drop 3 ;
-M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
-M: int-regs vregs
-    drop {
-        3 4 5 6 7 8 9 10
-        16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
-    } ;
-
-M: float-regs return-reg drop 1 ;
-M: float-regs param-regs 
-    drop os H{
-        { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
-        { linux { 1 2 3 4 5 6 7 8 } }
-    } at ;
-M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
-
-GENERIC: loc>operand ( loc -- reg n )
-
-M: ds-loc loc>operand n>> cells neg ds-reg swap ;
-M: rs-loc loc>operand n>> cells neg rs-reg swap ;
-
-M: immediate load-literal
-    [ v>operand ] bi@ LOAD ;
-
-M: ppc load-indirect ( obj reg -- )
-    [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
-    dup 0 LWZ ;
-
-M: ppc %save-word-xt ( -- )
-    0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
-
-M: ppc %prologue ( n -- )
-    0 MFLR
-    1 1 pick neg ADDI
-    11 1 pick xt-save STW
-    dup 11 LI
-    11 1 pick next-save STW
-    0 1 rot lr-save + STW ;
-
-M: ppc %epilogue ( n -- )
-    #! At the end of each word that calls a subroutine, we store
-    #! the previous link register value in r0 by popping it off
-    #! the stack, set the link register to the contents of r0,
-    #! and jump to the link register.
-    0 1 pick lr-save + LWZ
-    1 1 rot ADDI
-    0 MTLR ;
-
-: (%call) ( reg -- ) MTLR BLRL ;
-
-: (%jump) ( reg -- ) MTCTR BCTR ;
-
-: %load-dlsym ( symbol dll register -- )
-    0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
-
-M: ppc %call ( label -- ) BL ;
-
-M: ppc %jump-label ( label -- ) B ;
-
-M: ppc %jump-f ( label -- )
-    0 "flag" operand f v>operand CMPI BEQ ;
-
-M: ppc %dispatch ( -- )
-    [
-        %epilogue-later
-        0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
-        "offset" operand "n" operand 1 SRAWI
-        11 11 "offset" operand ADD
-        11 dup 6 cells LWZ
-        11 (%jump)
-    ] H{
-        { +input+ { { f "n" } } }
-        { +scratch+ { { f "offset" } } }
-    } with-template ;
-
-M: ppc %dispatch-label ( word -- )
-    0 , rc-absolute-cell rel-word ;
-
-M: ppc %return ( -- ) %epilogue-later BLR ;
-
-M: ppc %peek ( vreg loc -- )
-    >r v>operand r> loc>operand LWZ ;
-
-M: ppc %replace
-    >r v>operand r> loc>operand STW ;
-
-M: ppc %unbox-float ( dst src -- )
-    [ v>operand ] bi@ float-offset LFD ;
-
-M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
-
-M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
-
-M: int-regs %save-param-reg drop 1 rot local@ STW ;
-
-M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
-
-GENERIC: STF ( src dst off reg-class -- )
-
-M: single-float-regs STF drop STFS ;
-
-M: double-float-regs STF drop STFD ;
-
-M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
-
-GENERIC: LF ( dst src off reg-class -- )
-
-M: single-float-regs LF drop LFS ;
-
-M: double-float-regs LF drop LFD ;
-
-M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
-
-M: stack-params %load-param-reg ( stack reg reg-class -- )
-    drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
-
-: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
-
-M: stack-params %save-param-reg ( stack reg reg-class -- )
-    #! Funky. Read the parameter from the caller's stack frame.
-    #! This word is used in callbacks
-    drop
-    0 1 rot next-param@ LWZ
-    0 1 rot local@ STW ;
-
-M: ppc %prepare-unbox ( -- )
-    ! First parameter is top of stack
-    3 ds-reg 0 LWZ
-    ds-reg dup cell SUBI ;
-
-M: ppc %unbox ( n reg-class func -- )
-    ! Value must be in r3
-    ! Call the unboxer
-    f %alien-invoke
-    ! Store the return value on the C stack
-    over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-
-M: ppc %unbox-long-long ( n func -- )
-    ! Value must be in r3:r4
-    ! Call the unboxer
-    f %alien-invoke
-    ! Store the return value on the C stack
-    [
-        3 1 pick local@ STW
-        4 1 rot cell + local@ STW
-    ] when* ;
-
-M: ppc %unbox-large-struct ( n c-type -- )
-    ! Value must be in r3
-    ! Compute destination address and load struct size
-    [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
-    ! Call the function
-    "to_value_struct" f %alien-invoke ;
-
-M: ppc %box ( n reg-class func -- )
-    ! If the source is a stack location, load it into freg #0.
-    ! If the source is f, then we assume the value is already in
-    ! freg #0.
-    >r
-    over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
-    r> f %alien-invoke ;
-
-M: ppc %box-long-long ( n func -- )
-    >r [
-        3 1 pick local@ LWZ
-        4 1 rot cell + local@ LWZ
-    ] when* r> f %alien-invoke ;
-
-: struct-return@ ( n -- n )
-    [ stack-frame get params>> ] unless* local@ ;
-
-M: ppc %prepare-box-struct ( -- )
-    #! Compute target address for value struct return
-    3 1 f struct-return@ ADDI
-    3 1 0 local@ STW ;
-
-M: ppc %box-large-struct ( n c-type -- )
-    ! If n = f, then we're boxing a returned struct
-    ! Compute destination address and load struct size
-    [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
-    ! Call the function
-    "box_value_struct" f %alien-invoke ;
-
-M: ppc %prepare-alien-invoke
-    #! Save Factor stack pointers in case the C code calls a
-    #! callback which does a GC, which must reliably trace
-    #! all roots.
-    "stack_chain" f 11 %load-dlsym
-    11 11 0 LWZ
-    1 11 0 STW
-    ds-reg 11 8 STW
-    rs-reg 11 12 STW ;
-
-M: ppc %alien-invoke ( symbol dll -- )
-    11 %load-dlsym 11 (%call) ;
-
-M: ppc %alien-callback ( quot -- )
-    3 load-indirect "c_to_factor" f %alien-invoke ;
-
-M: ppc %prepare-alien-indirect ( -- )
-    "unbox_alien" f %alien-invoke
-    13 3 MR ;
-
-M: ppc %alien-indirect ( -- )
-    13 (%call) ;
-
-M: ppc %callback-value ( ctype -- )
-     ! Save top of data stack
-     3 ds-reg 0 LWZ
-     3 1 0 local@ STW
-     ! Restore data/call/retain stacks
-     "unnest_stacks" f %alien-invoke
-     ! Restore top of data stack
-     3 1 0 local@ LWZ
-     ! Unbox former top of data stack to return registers
-     unbox-return ;
-
-: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
-
-: %tag-fixnum ( src dest -- ) tag-bits get SLWI ;
-
-: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
-
-M: ppc value-structs?
-    #! On Linux/PPC, value structs are passed in the same way
-    #! as reference structs, we just have to make a copy first.
-    os linux? not ;
-
-M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
-
-M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
-
-M: ppc struct-small-enough? ( size -- ? ) drop f ;
-
-M: ppc %box-small-struct
-    drop "No small structs" throw ;
-
-M: ppc %unbox-small-struct
-    drop "No small structs" throw ;
-
-! Alien intrinsics
-M: ppc %unbox-byte-array ( dst src -- )
-    [ v>operand ] bi@ byte-array-offset ADDI ;
-
-M: ppc %unbox-alien ( dst src -- )
-    [ v>operand ] bi@ alien-offset LWZ ;
-
-M: ppc %unbox-f ( dst src -- )
-    drop 0 swap v>operand LI ;
-
-M: ppc %unbox-any-c-ptr ( dst src -- )
-    { "is-byte-array" "end" "start" } [ define-label ] each
-    ! Address is computed in R12
-    0 12 LI
-    ! Load object into R11
-    11 swap v>operand MR
-    ! We come back here with displaced aliens
-    "start" resolve-label
-    ! Is the object f?
-    0 11 f v>operand CMPI
-    ! If so, done
-    "end" get BEQ
-    ! Is the object an alien?
-    0 11 header-offset LWZ
-    0 0 alien type-number tag-fixnum CMPI
-    "is-byte-array" get BNE
-    ! If so, load the offset
-    0 11 alien-offset LWZ
-    ! Add it to address being computed
-    12 12 0 ADD
-    ! Now recurse on the underlying alien
-    11 11 underlying-alien-offset LWZ
-    "start" get B
-    "is-byte-array" resolve-label
-    ! Add byte array address to address being computed
-    12 12 11 ADD
-    ! Add an offset to start of byte array's data area
-    12 12 byte-array-offset ADDI
-    "end" resolve-label
-    ! Done, store address in destination register
-    v>operand 12 MR ;
diff --git a/basis/cpu/ppc/architecture/authors.txt b/basis/cpu/ppc/architecture/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/basis/cpu/ppc/architecture/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/cpu/ppc/architecture/summary.txt b/basis/cpu/ppc/architecture/summary.txt
deleted file mode 100644
index 76fe694abe..0000000000
--- a/basis/cpu/ppc/architecture/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-PowerPC architecture description
diff --git a/basis/cpu/ppc/architecture/tags.txt b/basis/cpu/ppc/architecture/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/basis/cpu/ppc/architecture/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/basis/cpu/ppc/intrinsics/authors.txt b/basis/cpu/ppc/intrinsics/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/basis/cpu/ppc/intrinsics/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor
deleted file mode 100644
index 634040b0d0..0000000000
--- a/basis/cpu/ppc/intrinsics/intrinsics.factor
+++ /dev/null
@@ -1,640 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors alien.c-types arrays
-cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
-cpu.architecture kernel kernel.private math math.private
-namespaces sequences words generic quotations byte-arrays
-hashtables hashtables.private
-sequences.private sbufs vectors system layouts
-math.floats.private classes slots.private
-combinators
-compiler.constants
-compiler.intrinsics
-compiler.generator
-compiler.generator.fixup
-compiler.generator.registers ;
-IN: cpu.ppc.intrinsics
-
-: %slot-literal-known-tag ( -- out value offset )
-    "val" operand
-    "obj" operand
-    "n" get cells
-    "obj" get operand-tag - ;
-
-: %slot-literal-any-tag ( -- out value offset )
-    "obj" operand "scratch1" operand %untag
-    "val" operand "scratch1" operand "n" get cells ;
-
-: %slot-any ( -- out value offset )
-    "obj" operand "scratch1" operand %untag
-    "offset" operand "n" operand 1 SRAWI
-    "scratch1" operand "val" operand "offset" operand ;
-
-\ slot {
-    ! Slot number is literal and the tag is known
-    {
-        [ %slot-literal-known-tag LWZ ] H{
-            { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "val" } } }
-            { +output+ { "val" } }
-        }
-    }
-    ! Slot number is literal
-    {
-        [ %slot-literal-any-tag LWZ ] H{
-            { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "scratch1" } { f "val" } } }
-            { +output+ { "val" } }
-        }
-    }
-    ! Slot number in a register
-    {
-        [ %slot-any LWZX ] H{
-            { +input+ { { f "obj" } { f "n" } } }
-            { +scratch+ { { f "val" } { f "scratch1" } { f "offset" } } }
-            { +output+ { "val" } }
-        }
-    }
-} define-intrinsics
-
-: load-cards-offset ( dest -- )
-    "cards_offset" f pick %load-dlsym  dup 0 LWZ ;
-
-: load-decks-offset ( dest -- )
-    "decks_offset" f pick %load-dlsym  dup 0 LWZ ;
-
-: %write-barrier ( -- )
-    "val" get operand-immediate? "obj" get fresh-object? or [
-        card-mark "scratch1" operand LI
-
-        ! Mark the card
-        "val" operand load-cards-offset
-        "obj" operand "scratch2" operand card-bits SRWI
-        "scratch2" operand "scratch1" operand "val" operand STBX
-
-        ! Mark the card deck
-        "val" operand load-decks-offset
-        "obj" operand "scratch2" operand deck-bits SRWI
-        "scratch2" operand "scratch1" operand "val" operand STBX
-    ] unless ;
-
-\ set-slot {
-    ! Slot number is literal and tag is known
-    {
-        [ %slot-literal-known-tag STW %write-barrier ] H{
-            { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "scratch1" } { f "scratch2" } } }
-            { +clobber+ { "val" } }
-        }
-    }
-    ! Slot number is literal
-    {
-        [ %slot-literal-any-tag STW %write-barrier ] H{
-            { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "scratch1" } { f "scratch2" } } }
-            { +clobber+ { "val" } }
-        }
-    }
-    ! Slot number is in a register
-    {
-        [ %slot-any STWX %write-barrier ] H{
-            { +input+ { { f "val" } { f "obj" } { f "n" } } }
-            { +scratch+ { { f "scratch1" } { f "scratch2" } { f "offset" } } }
-            { +clobber+ { "val" } }
-        }
-    }
-} define-intrinsics
-
-: fixnum-register-op ( op -- pair )
-    [ "out" operand "y" operand "x" operand ] swap suffix H{
-        { +input+ { { f "x" } { f "y" } } }
-        { +scratch+ { { f "out" } } }
-        { +output+ { "out" } }
-    } 2array ;
-
-: fixnum-value-op ( op -- pair )
-    [ "out" operand "x" operand "y" operand ] swap suffix H{
-        { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
-        { +scratch+ { { f "out" } } }
-        { +output+ { "out" } }
-    } 2array ;
-
-: define-fixnum-op ( word imm-op reg-op -- )
-    >r fixnum-value-op r> fixnum-register-op 2array
-    define-intrinsics ;
-
-{
-    { fixnum+fast ADDI ADD }
-    { fixnum-fast SUBI SUBF }
-    { fixnum-bitand ANDI AND }
-    { fixnum-bitor ORI OR }
-    { fixnum-bitxor XORI XOR }
-} [
-    first3 define-fixnum-op
-] each
-
-\ fixnum*fast {
-    {
-        [
-            "out" operand "x" operand "y" get MULLI
-        ] H{
-            { +input+ { { f "x" } { [ small-tagged? ] "y" } } }
-            { +scratch+ { { f "out" } } }
-            { +output+ { "out" } }
-        }
-    } {
-        [
-            "out" operand "x" operand %untag-fixnum
-            "out" operand "y" operand "out" operand MULLW
-        ] H{
-            { +input+ { { f "x" } { f "y" } } }
-            { +scratch+ { { f "out" } } }
-            { +output+ { "out" } }
-        }
-    }
-} define-intrinsics
-
-: %untag-fixnums ( seq -- )
-    [ dup %untag-fixnum ] unique-operands ;
-
-\ fixnum-shift-fast {
-    {
-        [
-            "out" operand "x" operand "y" get
-            dup 0 < [ neg SRAWI ] [ swapd SLWI ] if
-            ! Mask off low bits
-            "out" operand dup %untag
-        ] H{
-            { +input+ { { f "x" } { [ ] "y" } } }
-            { +scratch+ { { f "out" } } }
-            { +output+ { "out" } }
-        }
-    }
-    {
-        [
-            { "positive" "end" } [ define-label ] each
-            "out" operand "y" operand %untag-fixnum
-            0 "y" operand 0 CMPI
-            "positive" get BGE
-            "out" operand dup NEG
-            "out" operand "x" operand "out" operand SRAW
-            "end" get B
-            "positive" resolve-label
-            "out" operand "x" operand "out" operand SLW
-            "end" resolve-label
-            ! Mask off low bits
-            "out" operand dup %untag
-        ] H{
-            { +input+ { { f "x" } { f "y" } } }
-            { +scratch+ { { f "out" } } }
-            { +output+ { "out" } }
-        }
-    }
-} define-intrinsics
-
-: generate-fixnum-mod ( -- )
-    #! PowerPC doesn't have a MOD instruction; so we compute
-    #! x-(x/y)*y. Puts the result in "s" operand.
-    "s" operand "r" operand "y" operand MULLW
-    "s" operand "s" operand "x" operand SUBF ;
-
-\ fixnum-mod [
-    ! divide x by y, store result in x
-    "r" operand "x" operand "y" operand DIVW
-    generate-fixnum-mod
-] H{
-    { +input+ { { f "x" } { f "y" } } }
-    { +scratch+ { { f "r" } { f "s" } } }
-    { +output+ { "s" } }
-} define-intrinsic
-
-\ fixnum-bitnot [
-    "x" operand dup NOT
-    "x" operand dup %untag
-] H{
-    { +input+ { { f "x" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
-: fixnum-register-jump ( op -- pair )
-    [ "x" operand 0 "y" operand CMP ] swap suffix
-    { { f "x" } { f "y" } } 2array ;
-
-: fixnum-value-jump ( op -- pair )
-    [ 0 "x" operand "y" operand CMPI ] swap suffix
-    { { f "x" } { [ small-tagged? ] "y" } } 2array ;
-
-: define-fixnum-jump ( word op -- )
-    [ fixnum-value-jump ] keep fixnum-register-jump
-    2array define-if-intrinsics ;
-
-{
-    { fixnum< BGE }
-    { fixnum<= BGT }
-    { fixnum> BLE }
-    { fixnum>= BLT }
-    { eq? BNE }
-} [
-    first2 define-fixnum-jump
-] each
-
-: overflow-check ( insn1 insn2 -- )
-    [
-        >r 0 0 LI
-        0 MTXER
-        "r" operand "y" operand "x" operand r> execute
-        >r
-        "end" define-label
-        "end" get BNO
-        { "x" "y" } %untag-fixnums
-        "r" operand "y" operand "x" operand r> execute
-        "r" get %allot-bignum-signed-1
-        "end" resolve-label
-    ] with-scope ; inline
-
-: overflow-template ( word insn1 insn2 -- )
-    [ overflow-check ] 2curry H{
-        { +input+ { { f "x" } { f "y" } } }
-        { +scratch+ { { f "r" } } }
-        { +output+ { "r" } }
-        { +clobber+ { "x" "y" } }
-    } define-intrinsic ;
-
-\ fixnum+ \ ADD \ ADDO. overflow-template
-\ fixnum- \ SUBF \ SUBFO. overflow-template
-
-: generate-fixnum/i ( -- )
-    #! This VOP is funny. If there is an overflow, it falls
-    #! through to the end, and the result is in "x" operand.
-    #! Otherwise it jumps to the "no-overflow" label and the
-    #! result is in "r" operand.
-    "end" define-label
-    "no-overflow" define-label
-    "r" operand "x" operand "y" operand DIVW
-    ! if the result is greater than the most positive fixnum,
-    ! which can only ever happen if we do
-    ! most-negative-fixnum -1 /i, then the result is a bignum.
-    most-positive-fixnum "s" operand LOAD
-    "r" operand 0 "s" operand CMP
-    "no-overflow" get BLE
-    most-negative-fixnum neg "x" operand LOAD
-    "x" get %allot-bignum-signed-1 ;
-
-\ fixnum/i [
-    generate-fixnum/i
-    "end" get B
-    "no-overflow" resolve-label
-    "r" operand "x" operand %tag-fixnum
-    "end" resolve-label
-] H{
-    { +input+ { { f "x" } { f "y" } } }
-    { +scratch+ { { f "r" } { f "s" } } }
-    { +output+ { "x" } }
-    { +clobber+ { "y" } }
-} define-intrinsic
-
-\ fixnum/mod [
-    generate-fixnum/i
-    0 "s" operand LI
-    "end" get B
-    "no-overflow" resolve-label
-    generate-fixnum-mod
-    "r" operand "x" operand %tag-fixnum
-    "end" resolve-label
-] H{
-    { +input+ { { f "x" } { f "y" } } }
-    { +scratch+ { { f "r" } { f "s" } } }
-    { +output+ { "x" "s" } }
-    { +clobber+ { "y" } }
-} define-intrinsic
-
-\ fixnum>bignum [
-    "x" operand dup %untag-fixnum
-    "x" get %allot-bignum-signed-1
-] H{
-    { +input+ { { f "x" } } }
-    { +output+ { "x" } }
-} define-intrinsic
-
-\ bignum>fixnum [
-    "nonzero" define-label
-    "positive" define-label
-    "end" define-label
-    "x" operand dup %untag
-    "y" operand "x" operand cell LWZ
-     ! if the length is 1, its just the sign and nothing else,
-     ! so output 0
-    0 "y" operand 1 v>operand CMPI
-    "nonzero" get BNE
-    0 "y" operand LI
-    "end" get B
-    "nonzero" resolve-label
-    ! load the value
-    "y" operand "x" operand 3 cells LWZ
-    ! load the sign
-    "x" operand "x" operand 2 cells LWZ
-    ! is the sign negative?
-    0 "x" operand 0 CMPI
-    "positive" get BEQ
-    "y" operand dup -1 MULI
-    "positive" resolve-label
-    "y" operand dup %tag-fixnum
-    "end" resolve-label
-] H{
-    { +input+ { { f "x" } } }
-    { +scratch+ { { f "y" } } }
-    { +clobber+ { "x" } }
-    { +output+ { "y" } }
-} define-intrinsic
-
-: define-float-op ( word op -- )
-    [ "z" operand "x" operand "y" operand ] swap suffix H{
-        { +input+ { { float "x" } { float "y" } } }
-        { +scratch+ { { float "z" } } }
-        { +output+ { "z" } }
-    } define-intrinsic ;
-
-{
-    { float+ FADD }
-    { float- FSUB }
-    { float* FMUL }
-    { float/f FDIV }
-} [
-    first2 define-float-op
-] each
-
-: define-float-jump ( word op -- )
-    [ "x" operand 0 "y" operand FCMPU ] swap suffix
-    { { float "x" } { float "y" } } define-if-intrinsic ;
-
-{
-    { float< BGE }
-    { float<= BGT }
-    { float> BLE }
-    { float>= BLT }
-    { float= BNE }
-} [
-    first2 define-float-jump
-] each
-
-\ float>fixnum [
-    "scratch" operand "in" operand FCTIWZ
-    "scratch" operand 1 0 param@ STFD
-    "out" operand 1 cell param@ LWZ
-    "out" operand dup %tag-fixnum
-] H{
-    { +input+ { { float "in" } } }
-    { +scratch+ { { float "scratch" } { f "out" } } }
-    { +output+ { "out" } }
-} define-intrinsic
-
-\ fixnum>float [
-    HEX: 4330 "scratch" operand LIS
-    "scratch" operand 1 0 param@ STW
-    "scratch" operand "in" operand %untag-fixnum
-    "scratch" operand dup HEX: 8000 XORIS
-    "scratch" operand 1 cell param@ STW
-    "f1" operand 1 0 param@ LFD
-    4503601774854144.0 "scratch" operand load-indirect
-    "f2" operand "scratch" operand float-offset LFD
-    "f1" operand "f1" operand "f2" operand FSUB
-] H{
-    { +input+ { { f "in" } } }
-    { +scratch+ { { f "scratch" } { float "f1" } { float "f2" } } }
-    { +output+ { "f1" } }
-} define-intrinsic
-
-
-\ tag [
-    "out" operand "in" operand tag-mask get ANDI
-    "out" operand dup %tag-fixnum
-] H{
-    { +input+ { { f "in" } } }
-    { +scratch+ { { f "out" } } }
-    { +output+ { "out" } }
-} define-intrinsic
-
-: userenv ( reg -- )
-    #! Load the userenv pointer in a register.
-    "userenv" f rot %load-dlsym ;
-
-\ getenv [
-    "n" operand dup 1 SRAWI
-    "x" operand userenv
-    "x" operand "n" operand "x" operand ADD
-    "x" operand dup 0 LWZ
-] H{
-    { +input+ { { f "n" } } }
-    { +scratch+ { { f "x" } } }
-    { +output+ { "x" } }
-    { +clobber+ { "n" } }
-} define-intrinsic
-
-\ setenv [
-    "n" operand dup 1 SRAWI
-    "x" operand userenv
-    "x" operand "n" operand "x" operand ADD
-    "val" operand "x" operand 0 STW
-] H{
-    { +input+ { { f "val" } { f "n" } } }
-    { +scratch+ { { f "x" } } }
-    { +clobber+ { "n" } }
-} define-intrinsic
-
-\ (tuple) [
-    tuple "layout" get size>> 2 + cells %allot
-    ! Store layout
-    "layout" get 12 load-indirect
-    12 11 cell STW
-    ! Store tagged ptr in reg
-    "tuple" get tuple %store-tagged
-] H{
-    { +input+ { { [ ] "layout" } } }
-    { +scratch+ { { f "tuple" } } }
-    { +output+ { "tuple" } }
-} define-intrinsic
-
-\ (array) [
-    array "n" get 2 + cells %allot
-    ! Store length
-    "n" operand 12 LI
-    12 11 cell STW
-    ! Store tagged ptr in reg
-    "array" get object %store-tagged
-] H{
-    { +input+ { { [ ] "n" } } }
-    { +scratch+ { { f "array" } } }
-    { +output+ { "array" } }
-} define-intrinsic
-
-\ (byte-array) [
-    byte-array "n" get 2 cells + %allot
-    ! Store length
-    "n" operand 12 LI
-    12 11 cell STW
-    ! Store tagged ptr in reg
-    "array" get object %store-tagged
-] H{
-    { +input+ { { [ ] "n" } } }
-    { +scratch+ { { f "array" } } }
-    { +output+ { "array" } }
-} define-intrinsic
-
-\ <ratio> [
-    ratio 3 cells %allot
-    "numerator" operand 11 1 cells STW
-    "denominator" operand 11 2 cells STW
-    ! Store tagged ptr in reg
-    "ratio" get ratio %store-tagged
-] H{
-    { +input+ { { f "numerator" } { f "denominator" } } }
-    { +scratch+ { { f "ratio" } } }
-    { +output+ { "ratio" } }
-} define-intrinsic
-
-\ <complex> [
-    complex 3 cells %allot
-    "real" operand 11 1 cells STW
-    "imaginary" operand 11 2 cells STW
-    ! Store tagged ptr in reg
-    "complex" get complex %store-tagged
-] H{
-    { +input+ { { f "real" } { f "imaginary" } } }
-    { +scratch+ { { f "complex" } } }
-    { +output+ { "complex" } }
-} define-intrinsic
-
-\ <wrapper> [
-    wrapper 2 cells %allot
-    "obj" operand 11 1 cells STW
-    ! Store tagged ptr in reg
-    "wrapper" get object %store-tagged
-] H{
-    { +input+ { { f "obj" } } }
-    { +scratch+ { { f "wrapper" } } }
-    { +output+ { "wrapper" } }
-} define-intrinsic
-
-! Alien intrinsics
-: %alien-accessor ( quot -- )
-    "offset" operand dup %untag-fixnum
-    "scratch" operand "offset" operand "alien" operand ADD
-    "value" operand "scratch" operand 0 roll call ; inline
-
-: alien-integer-get-template
-    H{
-        { +input+ {
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { +scratch+ { { f "value" } { f "scratch" } } }
-        { +output+ { "value" } }
-        { +clobber+ { "offset" } }
-    } ;
-
-: %alien-integer-get ( quot -- )
-    %alien-accessor
-    "value" operand dup %tag-fixnum ; inline
-
-: alien-integer-set-template
-    H{
-        { +input+ {
-            { f "value" fixnum }
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { +scratch+ { { f "scratch" } } }
-        { +clobber+ { "value" "offset" } }
-    } ;
-
-: %alien-integer-set ( quot -- )
-    "offset" get "value" get = [
-        "value" operand dup %untag-fixnum
-    ] unless
-    %alien-accessor ; inline
-
-: define-alien-integer-intrinsics ( word get-quot word set-quot -- )
-    [ %alien-integer-set ] curry
-    alien-integer-set-template
-    define-intrinsic
-    [ %alien-integer-get ] curry
-    alien-integer-get-template
-    define-intrinsic ;
-
-\ alien-unsigned-1 [ LBZ ]
-\ set-alien-unsigned-1 [ STB ]
-define-alien-integer-intrinsics
-
-\ alien-signed-1 [ pick >r LBZ r> dup EXTSB ]
-\ set-alien-signed-1 [ STB ]
-define-alien-integer-intrinsics
-
-\ alien-unsigned-2 [ LHZ ]
-\ set-alien-unsigned-2 [ STH ]
-define-alien-integer-intrinsics
-
-\ alien-signed-2 [ LHA ]
-\ set-alien-signed-2 [ STH ]
-define-alien-integer-intrinsics
-
-\ alien-cell [
-    [ LWZ ] %alien-accessor
-] H{
-    { +input+ {
-        { unboxed-c-ptr "alien" c-ptr }
-        { f "offset" fixnum }
-    } }
-    { +scratch+ { { unboxed-alien "value" } { f "scratch" } } }
-    { +output+ { "value" } }
-    { +clobber+ { "offset" } }
-} define-intrinsic
-
-\ set-alien-cell [
-    [ STW ] %alien-accessor
-] H{
-    { +input+ {
-        { unboxed-c-ptr "value" pinned-c-ptr }
-        { unboxed-c-ptr "alien" c-ptr }
-        { f "offset" fixnum }
-    } }
-    { +scratch+ { { f "scratch" } } }
-    { +clobber+ { "offset" } }
-} define-intrinsic
-
-: alien-float-get-template
-    H{
-        { +input+ {
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { +scratch+ { { float "value" } { f "scratch" } } }
-        { +output+ { "value" } }
-        { +clobber+ { "offset" } }
-    } ;
-
-: alien-float-set-template
-    H{
-        { +input+ {
-            { float "value" float }
-            { unboxed-c-ptr "alien" c-ptr }
-            { f "offset" fixnum }
-        } }
-        { +scratch+ { { f "scratch" } } }
-        { +clobber+ { "offset" } }
-    } ;
-
-: define-alien-float-intrinsics ( word get-quot word set-quot -- )
-    [ %alien-accessor ] curry
-    alien-float-set-template
-    define-intrinsic
-    [ %alien-accessor ] curry
-    alien-float-get-template
-    define-intrinsic ;
-
-\ alien-double [ LFD ]
-\ set-alien-double [ STFD ]
-define-alien-float-intrinsics
-
-\ alien-float [ LFS ]
-\ set-alien-float [ STFS ]
-define-alien-float-intrinsics
diff --git a/basis/cpu/ppc/intrinsics/tags.txt b/basis/cpu/ppc/intrinsics/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/basis/cpu/ppc/intrinsics/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 1577945118..8e7d8fed7d 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -1,8 +1,15 @@
-USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics
-cpu.architecture namespaces alien.c-types kernel system
-combinators ;
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: cpu.ppc.architecture
 
-{
+! PowerPC register assignments
+! r3-r11, r16-r31: integer vregs
+! f0-f13: float vregs
+! r12: scratch
+! r14: data stack
+! r15: retain stack
+
+<< {
     { [ os macosx? ] [
         4 "longlong" c-type (>>align)
         4 "ulonglong" c-type (>>align)
@@ -12,4 +19,545 @@ combinators ;
         t "longlong" c-type (>>stack-align?)
         t "ulonglong" c-type (>>stack-align?)
     ] }
-} cond
+} cond >>
+
+M: ppc machine-registers
+    {
+        { int-regs { 3 4 5 6 7 8 9 10 11 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } }
+        { double-float-regs { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
+    } ;
+
+: scratch-reg 12 ; inline
+
+M: ppc two-operand? t ;
+
+M: ppc %load-immediate ( reg n -- ) swap LOAD ;
+
+M:: ppc %load-indirect ( reg obj -- )
+    0 reg LOAD32
+    obj rc-absolute-ppc-2/2 rel-literal
+    reg reg 0 LWZ ;
+
+: ds-reg 14 ; inline
+: rs-reg 15 ; inline
+
+GENERIC: loc-reg ( loc -- reg )
+
+M: ds-loc log-reg drop ds-reg ;
+M: rs-loc log-reg drop rs-reg ;
+
+: loc>operand ( loc -- reg n )
+    [ loc-reg ] [ n>> cells neg ] bi ; inline
+
+M: ppc %peek loc>operand LWZ ;
+M: ppc %replace loc>operand STW ;
+
+: (%inc) ( n reg -- ) dup rot cells ADDI ; inline
+
+M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
+M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
+
+: reserved-area-size ( -- n )
+    os {
+        { linux [ 2 ] }
+        { macosx [ 6 ] }
+    } case cells ; foldable
+
+: lr-save ( -- n )
+    os {
+        { linux [ 1 ] }
+        { macosx [ 2 ] }
+    } case cells ; foldable
+
+: param@ ( n -- x ) reserved-area-size + ; inline
+
+: param-save-size ( -- n ) 8 cells ; foldable
+
+: local@ ( n -- x )
+    reserved-area-size param-save-size + + ; inline
+
+: factor-area-size ( -- n ) 2 cells ; foldable
+
+: next-save ( n -- i ) cell - ;
+
+: xt-save ( n -- i ) 2 cells - ;
+
+M: ppc stack-frame-size ( stack-frame -- i )
+    local@ factor-area-size + 4 cells align ;
+
+! M: x86 stack-frame-size ( stack-frame -- i )
+!     [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+!     [ params>> ]
+!     [ return>> ]
+!     tri + +
+!     3 cells +
+!     align-stack ;
+
+M: ppc %call ( label -- ) BL ;
+M: ppc %jump-label ( label -- ) B ;
+M: ppc %return ( -- ) BLR ;
+
+M:: ppc %dispatch ( src temp -- )
+    0 temp LOAD32 rc-absolute-ppc-2/2 rel-here
+    temp temp src ADD
+    temp temp 5 cells LWZ
+    temp MTCTR
+    BCTR ;
+
+M: ppc %dispatch-label ( word -- )
+    0 , rc-absolute-cell rel-word ;
+
+:: (%slot) ( obj slot tag temp -- reg offset )
+    temp slot obj ADD
+    temp tag neg ; inline
+
+: (%slot-imm) ( obj slot tag -- reg offset )
+    [ cells ] dip - ; inline
+
+M: ppc %slot ( dst obj slot tag temp -- ) (%slot) LWZ ;
+M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ;
+M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
+M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
+
+M: ppc %add     ADD ;
+M: ppc %add-imm ADDI ;
+M: ppc %sub     swapd SUBF ;
+M: ppc %sub-imm SUBI ;
+M: ppc %mul     MULLW ;
+M: ppc %mul-imm MULLI ;
+M: ppc %and     AND ;
+M: ppc %and-imm ANDI ;
+M: ppc %or      OR ;
+M: ppc %or-imm  ORI ;
+M: ppc %xor     XOR ;
+M: ppc %xor-imm XORI ;
+M: ppc %shl-imm swapd SLWI ;
+M: ppc %shr-imm swapd SRWI ;
+M: ppc %sar-imm SRAWI ;
+M: ppc %not     NOT ;
+
+M: ppc %integer>bignum ( dst src temp -- )
+    [
+        { "end" "non-zero" "pos" "store" } [ define-label ] each
+        ! is it zero?
+        0 over v>operand 0 CMPI
+        "non-zero" get BNE
+        dup 0 >bignum %load-literal
+        "end" get B
+        ! it is non-zero
+        "non-zero" resolve-label
+        1 bignum over 3 + cells %allot
+        1+ v>operand 12 LI ! compute the length
+        12 11 cell STW ! store the length
+        ! is the fixnum negative?
+        0 over v>operand 0 CMPI
+        "pos" get BGE
+        1 12 LI
+        ! store negative sign
+        12 11 2 cells STW
+        ! negate fixnum
+        dup v>operand dup -1 MULI
+        "store" get B
+        "pos" resolve-label
+        0 12 LI
+        ! store positive sign
+        12 11 2 cells STW
+        "store" resolve-label
+        ! store the number
+        dup v>operand 11 3 cells STW
+        ! tag the bignum, store it in reg
+        bignum %store-tagged
+        "end" resolve-label
+    ] with-scope ;
+
+: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
+
+M:: %bignum>integer ( dst src -- )
+    [
+        "end" define-label
+        scratch-reg src 1 bignum@ LWZ
+        ! if the length is 1, its just the sign and nothing else,
+        ! so output 0
+        0 dst LI
+        0 scratch-reg 1 v>operand CMPI
+        "end" get BEQ
+        ! load the value
+        dst src 3 bignum@ LWZ
+        ! load the sign
+        scratch-reg src 2 bignum@ LWZ
+        ! branchless arithmetic: we want to turn 0 into 1,
+        ! and 1 into -1
+        scratch-reg scratch-reg 1 SLWI
+        scratch-reg scratch-reg NEG
+        scratch-reg scratch-reg 1 ADDI
+        ! multiply value by sign
+        dst dst scratch-reg MULLW
+        "end" resolve-label
+    ] with-scope ;
+
+M: ppc %add-float FADD ;
+M: ppc %sub-float FSUB ;
+M: ppc %mul-float FMUL ;
+M: ppc %div-float FDIV ;
+
+M: ppc %integer>float
+    HEX: 4330 "scratch" operand LIS
+    "scratch" operand 1 0 param@ STW
+    "in" operand dup HEX: 8000 XORIS
+    "in" operand 1 cell param@ STW
+    "f1" operand 1 0 param@ LFD
+    4503601774854144.0 "in" operand load-indirect
+    "f2" operand "in" operand float-offset LFD
+    "f1" operand "f1" operand "f2" operand FSUB ;
+
+M: ppc %float>integer
+    "scratch" operand "in" operand FCTIWZ
+    "scratch" operand 1 0 param@ STFD
+    "out" operand 1 cell param@ LWZ ;
+
+M: ppc %copy ( dst src -- ) MR ;
+
+M: ppc %copy-float ( dst src -- ) MFR ;
+
+M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
+
+M:: ppc %unbox-any-c-ptr ( dst src temp -- )
+    [
+        { "is-byte-array" "end" "start" } [ define-label ] each
+        ! Address is computed in dst
+        0 dst LI
+        ! Load object into scratch-reg
+        scratch-reg src MR
+        ! We come back here with displaced aliens
+        "start" resolve-label
+        ! Is the object f?
+        0 scratch-reg \ f tag-number CMPI
+        ! If so, done
+        "end" get BEQ
+        ! Is the object an alien?
+        0 scratch-reg header-offset LWZ
+        0 0 alien type-number tag-fixnum CMPI
+        "is-byte-array" get BNE
+        ! If so, load the offset
+        0 scratch-reg alien-offset LWZ
+        ! Add it to address being computed
+        dst dst 0 ADD
+        ! Now recurse on the underlying alien
+        scratch-reg scratch-reg underlying-alien-offset LWZ
+        "start" get B
+        "is-byte-array" resolve-label
+        ! Add byte array address to address being computed
+        dst dst scratch-reg ADD
+        ! Add an offset to start of byte array's data area
+        dst dst byte-array-offset ADDI
+        "end" resolve-label
+    ] with-scope ;
+
+: alien@ ( n -- n' ) cells object tag-number - ;
+
+M:: ppc %box-alien ( dst src temp -- )
+    [
+        "f" define-label
+        dst \ f tag-number %load-immediate
+        0 src 0 CMPI
+        "f" get BEQ
+        dst 4 cells alien temp %allot
+        ! Store offset
+        dst src 3 alien@ STW
+        temp \ f tag-number %load-immediate
+        ! Store expired slot
+        temp dst 1 alien@ STW
+        ! Store underlying-alien slot
+        temp dst 2 alien@ STW
+        "f" resolve-label
+    ] with-scope ;
+
+M: ppc %alien-unsigned-1 0 LBZ ;
+M: ppc %alien-unsigned-2 0 LHZ ;
+
+M: ppc %alien-signed-1 dupd 0 LBZ EXTSB ;
+M: ppc %alien-signed-2 0 LHA ;
+
+M: ppc %alien-cell 0 LWZ ;
+
+M: ppc %alien-float 0 LFS ;
+M: ppc %alien-double 0 LFD ;
+
+M: ppc %set-alien-integer-1 0 STB ;
+M: ppc %set-alien-integer-2 0 STH ;
+
+M: ppc %set-alien-cell 0 STW ;
+
+M: ppc %set-alien-float 0 STFS ;
+M: ppc %set-alien-double 0 STFD ;
+
+: load-zone-ptr ( reg -- )
+    [ "nursery" f ] dip %load-dlsym ;
+
+: load-allot-ptr ( nursery-ptr allot-ptr -- )
+    [ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ;
+
+:: inc-allot-ptr ( nursery-ptr n -- )
+    scratch-reg inc-allot-ptr 4 LWZ
+    scratch-reg scratch-reg n 8 align ADD
+    scratch-reg inc-allot-ptr 4 STW ;
+
+:: store-header ( temp class -- )
+    class type-number tag-fixnum scratch-reg LI
+    temp scratch-reg 0 STW ;
+
+: store-tagged ( dst tag -- )
+    dupd tag-number ORI ;
+
+M:: ppc %allot ( dst size class nursery-ptr -- )
+    nursery-ptr dst load-allot-ptr
+    dst class store-header
+    dst class store-tagged
+    nursery-ptr size inc-allot-ptr ;
+
+: %alien-global ( dest name -- )
+    [ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
+
+: load-cards-offset ( dest -- )
+    "cards_offset" %alien-global ;
+
+: load-decks-offset ( dest -- )
+    "decks_offset" %alien-global ;
+
+M:: ppc %write-barrier ( src card# table -- )
+    card-mark scratch-reg LI
+
+    ! Mark the card
+    table load-cards-offset
+    src card# card-bits SRWI
+    table scratch-reg card# STBX
+
+    ! Mark the card deck
+    table load-decks-offset
+    src card# deck-bits SRWI
+    table scratch-reg card# STBX ;
+
+M: ppc %gc
+    "end" define-label
+    12 load-zone-ptr
+    11 12 cell LWZ ! nursery.here -> r11
+    12 12 3 cells LWZ ! nursery.end -> r12
+    11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
+    11 0 12 CMP ! is here >= end?
+    "end" get BLE
+    0 frame-required
+    %prepare-alien-invoke
+    "minor_gc" f %alien-invoke
+    "end" resolve-label ;
+
+M: ppc %prologue ( n -- )
+    0 scrach-reg LOAD32 rc-absolute-ppc-2/2 rel-this
+    0 MFLR
+    1 1 pick neg ADDI
+    scrach-reg 1 pick xt-save STW
+    dup scrach-reg LI
+    scrach-reg 1 pick next-save STW
+    0 1 rot lr-save + STW ;
+
+M: ppc %epilogue ( n -- )
+    #! At the end of each word that calls a subroutine, we store
+    #! the previous link register value in r0 by popping it off
+    #! the stack, set the link register to the contents of r0,
+    #! and jump to the link register.
+    0 1 pick lr-save + LWZ
+    1 1 rot ADDI
+    0 MTLR ;
+
+:: (%boolean) ( dst word -- )
+    "end" define-label
+    \ f tag-number %load-immediate
+    "end" get word execute
+    dst \ t %load-indirect
+    "end" get resolve-label ; inline
+
+: %boolean ( dst cc -- )
+    negate-cc {
+        { cc< [ \ BLT %boolean ] }
+        { cc<= [ \ BLE %boolean ] }
+        { cc> [ \ BGT %boolean ] }
+        { cc>= [ \ BGE %boolean ] }
+        { cc= [ \ BEQ %boolean ] }
+        { cc/= [ \ BNE %boolean ] }
+    } case ;
+
+: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
+: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline
+: (%compare-float) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
+
+M: ppc %compare (%compare) %boolean ;
+M: ppc %compare-imm (%compare-imm) %boolean ;
+M: ppc %compare-float (%compare-float) %boolean ;
+
+: %branch ( label cc -- )
+    {
+        { cc< [ BLT ] }
+        { cc<= [ BLE ] }
+        { cc> [ BGT ] }
+        { cc>= [ BGE ] }
+        { cc= [ BEQ ] }
+        { cc/= [ BNE ] }
+    } case ;
+
+M: ppc %compare-branch (%compare) %branch ;
+M: ppc %compare-imm-branch (%compare-imm) %branch ;
+M: ppc %compare-float-branch (%compare-float) %branch ;
+
+! M: ppc %spill-integer ( src n -- ) spill-integer@ swap MOV ;
+! M: ppc %reload-integer ( dst n -- ) spill-integer@ MOV ;
+! 
+! M: ppc %spill-float ( src n -- ) spill-float@ swap MOVSD ;
+! M: ppc %reload-float ( dst n -- ) spill-float@ MOVSD ;
+
+M: ppc %loop-entry ;
+
+M: int-regs return-reg drop 3 ;
+M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
+M: float-regs return-reg drop 1 ;
+M: float-regs param-regs 
+    drop os H{
+        { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
+        { linux { 1 2 3 4 5 6 7 8 } }
+    } at ;
+
+M: int-regs %save-param-reg drop 1 rot local@ STW ;
+M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
+
+GENERIC: STF ( src dst off reg-class -- )
+
+M: single-float-regs STF drop STFS ;
+M: double-float-regs STF drop STFD ;
+
+M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
+
+GENERIC: LF ( dst src off reg-class -- )
+
+M: single-float-regs LF drop LFS ;
+M: double-float-regs LF drop LFD ;
+
+M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
+
+M: stack-params %load-param-reg ( stack reg reg-class -- )
+    drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
+
+: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
+
+M: stack-params %save-param-reg ( stack reg reg-class -- )
+    #! Funky. Read the parameter from the caller's stack frame.
+    #! This word is used in callbacks
+    drop
+    0 1 rot next-param@ LWZ
+    0 1 rot local@ STW ;
+
+M: ppc %prepare-unbox ( -- )
+    ! First parameter is top of stack
+    3 ds-reg 0 LWZ
+    ds-reg dup cell SUBI ;
+
+M: ppc %unbox ( n reg-class func -- )
+    ! Value must be in r3
+    ! Call the unboxer
+    f %alien-invoke
+    ! Store the return value on the C stack
+    over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+
+M: ppc %unbox-long-long ( n func -- )
+    ! Value must be in r3:r4
+    ! Call the unboxer
+    f %alien-invoke
+    ! Store the return value on the C stack
+    [
+        3 1 pick local@ STW
+        4 1 rot cell + local@ STW
+    ] when* ;
+
+M: ppc %unbox-large-struct ( n c-type -- )
+    ! Value must be in r3
+    ! Compute destination address and load struct size
+    [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
+    ! Call the function
+    "to_value_struct" f %alien-invoke ;
+
+M: ppc %box ( n reg-class func -- )
+    ! If the source is a stack location, load it into freg #0.
+    ! If the source is f, then we assume the value is already in
+    ! freg #0.
+    >r
+    over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
+    r> f %alien-invoke ;
+
+M: ppc %box-long-long ( n func -- )
+    >r [
+        3 1 pick local@ LWZ
+        4 1 rot cell + local@ LWZ
+    ] when* r> f %alien-invoke ;
+
+: struct-return@ ( n -- n )
+    [ stack-frame get params>> ] unless* local@ ;
+
+M: ppc %prepare-box-struct ( -- )
+    #! Compute target address for value struct return
+    3 1 f struct-return@ ADDI
+    3 1 0 local@ STW ;
+
+M: ppc %box-large-struct ( n c-type -- )
+    ! If n = f, then we're boxing a returned struct
+    ! Compute destination address and load struct size
+    [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
+    ! Call the function
+    "box_value_struct" f %alien-invoke ;
+
+M: ppc %prepare-alien-invoke
+    #! Save Factor stack pointers in case the C code calls a
+    #! callback which does a GC, which must reliably trace
+    #! all roots.
+    "stack_chain" f 11 %load-dlsym
+    11 11 0 LWZ
+    1 11 0 STW
+    ds-reg 11 8 STW
+    rs-reg 11 12 STW ;
+
+M: ppc %alien-invoke ( symbol dll -- )
+    11 %load-dlsym 11 MTLR BLRL ;
+
+M: ppc %alien-callback ( quot -- )
+    3 load-indirect "c_to_factor" f %alien-invoke ;
+
+M: ppc %prepare-alien-indirect ( -- )
+    "unbox_alien" f %alien-invoke
+    13 3 MR ;
+
+M: ppc %alien-indirect ( -- )
+    13 MTLR BLRL ;
+
+M: ppc %callback-value ( ctype -- )
+    ! Save top of data stack
+    3 ds-reg 0 LWZ
+    3 1 0 local@ STW
+    ! Restore data/call/retain stacks
+    "unnest_stacks" f %alien-invoke
+    ! Restore top of data stack
+    3 1 0 local@ LWZ
+    ! Unbox former top of data stack to return registers
+    unbox-return ;
+
+M: ppc value-structs?
+    #! On Linux/PPC, value structs are passed in the same way
+    #! as reference structs, we just have to make a copy first.
+    os linux? not ;
+
+M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
+
+M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
+
+M: ppc struct-small-enough? ( size -- ? ) drop f ;
+
+M: ppc %box-small-struct
+    drop "No small structs" throw ;
+
+M: ppc %unbox-small-struct
+    drop "No small structs" throw ;

From 8b7c47a68b992b67cabd1c4141cbd47991c9e80a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 04:15:48 -0600
Subject: [PATCH 137/318] Clean up x86 backend: move cpu.x86.architecture to
 cpu.x86, use branchless arithmetic in some intrinsics

---
 basis/cpu/x86/32/32.factor                    |  2 +-
 basis/cpu/x86/64/64.factor                    |  2 +-
 basis/cpu/x86/architecture/authors.txt        |  1 -
 basis/cpu/x86/architecture/tags.txt           |  1 -
 basis/cpu/x86/bootstrap.factor                | 10 +--
 .../architecture.factor => x86.factor}        | 84 ++++++++++---------
 6 files changed, 48 insertions(+), 52 deletions(-)
 delete mode 100755 basis/cpu/x86/architecture/authors.txt
 delete mode 100644 basis/cpu/x86/architecture/tags.txt
 rename basis/cpu/x86/{architecture/architecture.factor => x86.factor} (91%)

diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 0e4107eaee..890938c6b3 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -3,7 +3,7 @@
 USING: locals alien.c-types alien.syntax arrays kernel
 math namespaces sequences system layouts io vocabs.loader
 accessors init combinators command-line cpu.x86.assembler
-cpu.x86.architecture cpu.architecture compiler compiler.units
+cpu.x86 cpu.architecture compiler compiler.units
 compiler.constants compiler.alien compiler.codegen
 compiler.codegen.fixup compiler.cfg.instructions
 compiler.cfg.builder compiler.cfg.intrinsics ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 3b0403a07e..16e7319c03 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.structs
 slots splitting assocs combinators cpu.x86.assembler
-cpu.x86.architecture cpu.architecture compiler.constants
+cpu.x86 cpu.architecture compiler.constants
 compiler.codegen compiler.codegen.fixup
 compiler.cfg.instructions compiler.cfg.builder
 compiler.cfg.intrinsics ;
diff --git a/basis/cpu/x86/architecture/authors.txt b/basis/cpu/x86/architecture/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/basis/cpu/x86/architecture/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/cpu/x86/architecture/tags.txt b/basis/cpu/x86/architecture/tags.txt
deleted file mode 100644
index 6bf68304bb..0000000000
--- a/basis/cpu/x86/architecture/tags.txt
+++ /dev/null
@@ -1 +0,0 @@
-unportable
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index c7c4d0de52..d2ff9a5928 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -271,9 +271,7 @@ big-endian off
 : jit-math ( insn -- )
     arg0 ds-reg [] MOV                         ! load second input
     ds-reg bootstrap-cell SUB                  ! pop stack
-    arg1 ds-reg [] MOV                         ! load first input
-    [ arg1 arg0 ] dip execute                  ! compute result
-    ds-reg [] arg1 MOV                         ! push result
+    [ ds-reg [] arg0 ] dip execute             ! compute result
     ;
 
 [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
@@ -296,10 +294,8 @@ big-endian off
 [ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
 
 [
-    arg0 ds-reg [] MOV                         ! load input input
-    arg0 NOT                                   ! complement
-    arg0 tag-mask get XOR                      ! clear tag bits
-    ds-reg [] arg0 MOV                         ! save
+    ds-reg [] NOT                              ! complement
+    ds-reg [] tag-mask get XOR                 ! clear tag bits
 ] f f f \ fixnum-bitnot define-sub-primitive
 
 [
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/x86.factor
similarity index 91%
rename from basis/cpu/x86/architecture/architecture.factor
rename to basis/cpu/x86/x86.factor
index 74b8818d16..83c9ee7f0d 100644
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/x86.factor
@@ -7,7 +7,7 @@ words system layouts combinators math.order fry locals
 compiler.constants compiler.cfg.registers
 compiler.cfg.instructions compiler.codegen
 compiler.codegen.fixup ;
-IN: cpu.x86.architecture
+IN: cpu.x86
 
 M: x86 two-operand? t ;
 
@@ -111,49 +111,54 @@ M:: x86 %integer>bignum ( dst src temp -- )
     #! 1 cell header, 1 cell length, 1 cell sign, + digits
     #! length is the # of digits + sign
     [
-        { "end" "nonzero" "positive" } [ define-label ] each
-        src 0 CMP ! is it zero?
-        "nonzero" get JNE
-        ! Use cached zero value
+        "end" define-label
+        ! Load cached zero value
         dst 0 >bignum %load-indirect
-        "end" get JMP
-        "nonzero" resolve-label
+        src 0 CMP
+        ! Is it zero? Then just go to the end and return this zero
+        "end" get JE
         ! Allocate a bignum
         dst 4 cells bignum temp %allot
         ! Write length
         dst 1 bignum@ 2 tag-fixnum MOV
-        ! Test sign
-        src 0 CMP
-        "positive" get JGE
-        dst 2 bignum@ 1 MOV ! negative sign
-        src NEG
-        dst 3 bignum@ src MOV
-        src NEG ! we don't want to clobber src
-        "end" get JMP
-        "positive" resolve-label
-        dst 2 bignum@ 0 MOV ! positive sign
+        ! Store value
         dst 3 bignum@ src MOV
+        ! Compute sign
+        temp src MOV
+        temp cell-bits 1- SAR
+        temp 1 AND
+        ! Store sign
+        dst 2 bignum@ temp MOV
+        ! Make negative value positive
+        temp temp ADD
+        temp NEG
+        temp 1 ADD
+        src temp IMUL2
+        ! Store the bignum
+        dst 3 bignum@ temp MOV
         "end" resolve-label
     ] with-scope ;
 
-M:: x86 %bignum>integer ( dst src -- )
+M:: x86 %bignum>integer ( dst src temp -- )
     [
-        "nonzero" define-label
         "end" define-label
-        dst src 1 bignum@ MOV
-         ! if the length is 1, its just the sign and nothing else,
-         ! so output 0
-        dst 1 tag-fixnum CMP
-        "nonzero" get JNE
+        ! load length
+        temp src 1 bignum@ MOV
+        ! if the length is 1, its just the sign and nothing else,
+        ! so output 0
         dst 0 MOV
-        "end" get JMP
-        "nonzero" resolve-label
+        temp 1 tag-fixnum CMP
+        "end" get JE
         ! load the value
         dst src 3 bignum@ MOV
-        ! is the sign negative?
-        src 2 bignum@ 0 CMP
-        "end" get JE
-        dst NEG
+        ! load the sign
+        temp src 2 bignum@ MOV
+        ! convert it into -1 or 1
+        temp temp ADD
+        temp NEG
+        temp 1 ADD
+        ! make dst signed
+        temp dst IMUL2
         "end" resolve-label
     ] with-scope ;
 
@@ -206,21 +211,19 @@ M:: x86 %box-float ( dst src temp -- )
     dst 16 float temp %allot
     dst float-offset [+] src MOVSD ;
 
-: alien@ ( reg n -- op ) cells object tag-number - [+] ;
+: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
 
 M:: x86 %box-alien ( dst src temp -- )
     [
-        { "end" "f" } [ define-label ] each
+        "end" define-label
+        dst \ f tag-number MOV
         src 0 CMP
-        "f" get JE
+        "end" get JE
         dst 4 cells alien temp %allot
         dst 1 alien@ \ f tag-number MOV
         dst 2 alien@ \ f tag-number MOV
         ! Store src in alien-offset slot
         dst 3 alien@ src MOV
-        "end" get JMP
-        "f" resolve-label
-        dst \ f tag-number MOV
         "end" resolve-label
     ] with-scope ;
 
@@ -339,7 +342,7 @@ M: x86 %set-alien-double [ [] ] dip MOVSD ;
 : inc-allot-ptr ( nursery-ptr n -- )
     [ cell [+] ] dip 8 align ADD ;
 
-: store-header ( temp type -- )
+: store-header ( temp class -- )
     [ [] ] [ type-number tag-fixnum ] bi* MOV ;
 
 : store-tagged ( dst tag -- )
@@ -463,11 +466,10 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
 M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
 M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
 
-M: x86 %spill-float spill-float@ swap MOVSD ;
-M: x86 %reload-float spill-float@ MOVSD ;
+M: x86 %spill-float ( src n -- ) spill-float@ swap MOVSD ;
+M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
 
-M: x86 %loop-entry
-    16 code-alignment [ NOP ] times ;
+M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
 M: int-regs %save-param-reg drop >r stack@ r> MOV ;
 M: int-regs %load-param-reg drop swap stack@ MOV ;

From dae41147fe32b4555440ea7ecf3c71dc0520cbc3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 04:16:08 -0600
Subject: [PATCH 138/318] %bignum>integer now takes a temporary register since
 this is useful on both x86 and ppc

---
 basis/compiler/codegen/codegen.factor      | 2 +-
 basis/cpu/architecture/architecture.factor | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 7dca752cf7..0d36a88b45 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -152,7 +152,7 @@ M: ##not     generate-insn dst/src       %not     ;
     [ dst/src ] [ temp>> register ] bi ; inline
 
 M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
-M: ##bignum>integer generate-insn dst/src %bignum>integer ;
+M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
 
 M: ##add-float generate-insn dst/src1/src2 %add-float ;
 M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index 618be9a11f..c86f236976 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -76,7 +76,7 @@ HOOK: %sar-imm cpu ( dst src1 src2 -- )
 HOOK: %not     cpu ( dst src -- )
 
 HOOK: %integer>bignum cpu ( dst src temp -- )
-HOOK: %bignum>integer cpu ( dst src -- )
+HOOK: %bignum>integer cpu ( dst src temp -- )
 
 HOOK: %add-float cpu ( dst src1 src2 -- )
 HOOK: %sub-float cpu ( dst src1 src2 -- )

From 7aa530c64efff9edaa9aa4643e41cd32db201893 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 04:16:15 -0600
Subject: [PATCH 139/318] Fix ABOUT: docs

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

diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor
index 643e121f5e..2fe4edfe7f 100644
--- a/basis/help/help-docs.factor
+++ b/basis/help/help-docs.factor
@@ -407,7 +407,7 @@ HELP: ARTICLE:
 } ;
 
 HELP: ABOUT:
-{ $syntax "MAIN: article" }
+{ $syntax "ABOUT: article" }
 { $values { "article" "a help article" } }
 { $description "Defines the main documentation article for the current vocabulary." } ;
 

From 2239f4fb9958c1e6973a11eb4291cae38e97890e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 04:20:35 -0600
Subject: [PATCH 140/318] More work on PowerPC backend; change register usage,
 free up some more integer and float regs (untested)

---
 basis/cpu/ppc/bootstrap.factor |   4 +-
 basis/cpu/ppc/ppc.factor       | 191 ++++++++++++++++-----------
 vm/cpu-ppc.S                   | 233 ++++++++++++++++++++-------------
 vm/cpu-ppc.h                   |   4 +-
 4 files changed, 256 insertions(+), 176 deletions(-)

diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index 47c31111a9..7d5e359a80 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -11,8 +11,8 @@ big-endian on
 
 4 jit-code-format set
 
-: ds-reg 14 ;
-: rs-reg 15 ;
+: ds-reg 30 ;
+: rs-reg 31 ;
 
 : factor-area-size ( -- n ) 4 bootstrap-cells ;
 
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 8e7d8fed7d..0857c4405c 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -1,13 +1,30 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: cpu.ppc.architecture
+USING: alien.c-types
+accessors
+cpu.architecture
+compiler.cfg.registers
+cpu.ppc.assembler
+kernel
+locals
+layouts
+combinators
+make
+compiler.cfg.instructions
+math.order
+system
+math
+compiler.constants
+namespaces compiler.codegen.fixup ;
+IN: cpu.ppc
 
-! PowerPC register assignments
-! r3-r11, r16-r31: integer vregs
-! f0-f13: float vregs
-! r12: scratch
-! r14: data stack
-! r15: retain stack
+! PowerPC register assignments:
+! r2-r28: integer vregs
+! r29: integer scratch
+! r30: data stack
+! r31: retain stack
+! f0-f29: float vregs
+! f30, f31: float scratch
 
 << {
     { [ os macosx? ] [
@@ -23,13 +40,15 @@ IN: cpu.ppc.architecture
 
 M: ppc machine-registers
     {
-        { int-regs { 3 4 5 6 7 8 9 10 11 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 } }
-        { double-float-regs { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
+        { int-regs T{ range f 2 27 1 } }
+        { double-float-regs T{ range f 0 28 1 } }
     } ;
 
-: scratch-reg 12 ; inline
+: scratch-reg 29 ; inline
+: fp-scratch-reg-1 30 ; inline
+: fp-scratch-reg-2 31 ; inline
 
-M: ppc two-operand? t ;
+M: ppc two-operand? f ;
 
 M: ppc %load-immediate ( reg n -- ) swap LOAD ;
 
@@ -38,8 +57,8 @@ M:: ppc %load-indirect ( reg obj -- )
     obj rc-absolute-ppc-2/2 rel-literal
     reg reg 0 LWZ ;
 
-: ds-reg 14 ; inline
-: rs-reg 15 ; inline
+: ds-reg 30 ; inline
+: rs-reg 31 ; inline
 
 GENERIC: loc-reg ( loc -- reg )
 
@@ -83,15 +102,14 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
 : xt-save ( n -- i ) 2 cells - ;
 
 M: ppc stack-frame-size ( stack-frame -- i )
-    local@ factor-area-size + 4 cells align ;
-
-! M: x86 stack-frame-size ( stack-frame -- i )
-!     [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
-!     [ params>> ]
-!     [ return>> ]
-!     tri + +
-!     3 cells +
-!     align-stack ;
+    [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+    [ params>> ]
+    [ return>> ]
+    tri + +
+    reserved-area-size +
+    param-save-size +
+    factor-area-size +
+    4 cells align ;
 
 M: ppc %call ( label -- ) BL ;
 M: ppc %jump-label ( label -- ) B ;
@@ -136,62 +154,57 @@ M: ppc %shr-imm swapd SRWI ;
 M: ppc %sar-imm SRAWI ;
 M: ppc %not     NOT ;
 
+: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
+
 M: ppc %integer>bignum ( dst src temp -- )
     [
         { "end" "non-zero" "pos" "store" } [ define-label ] each
-        ! is it zero?
-        0 over v>operand 0 CMPI
-        "non-zero" get BNE
-        dup 0 >bignum %load-literal
-        "end" get B
-        ! it is non-zero
-        "non-zero" resolve-label
-        1 bignum over 3 + cells %allot
-        1+ v>operand 12 LI ! compute the length
-        12 11 cell STW ! store the length
-        ! is the fixnum negative?
-        0 over v>operand 0 CMPI
-        "pos" get BGE
-        1 12 LI
-        ! store negative sign
-        12 11 2 cells STW
-        ! negate fixnum
-        dup v>operand dup -1 MULI
-        "store" get B
-        "pos" resolve-label
-        0 12 LI
-        ! store positive sign
-        12 11 2 cells STW
-        "store" resolve-label
-        ! store the number
-        dup v>operand 11 3 cells STW
-        ! tag the bignum, store it in reg
-        bignum %store-tagged
+        dst 0 >bignum %load-immediate
+        ! Is it zero? Then just go to the end and return this zero
+        0 src 0 CMPI
+        "end" get BEQ
+        ! Allocate a bignum
+        dst 4 cells bignum temp %allot
+        ! Write length
+        2 temp LI
+        dst 1 bignum@ temp STW
+        ! Store value
+        dst 3 bignum@ src STW
+        ! Compute sign
+        temp src MR
+        temp cell-bits 1- SRAWI
+        temp temp 1 ANDI
+        ! Store sign
+        dst 2 bignum@ temp STW
+        ! Make negative value positive
+        temp temp temp ADD
+        temp temp NEG
+        temp temp 1 ADDI
+        temp src temp MULLW
+        ! Store the bignum
+        dst 3 bignum@ temp STW
         "end" resolve-label
     ] with-scope ;
 
-: bignum@ ( n -- offset ) cells bignum tag-number - ; inline
-
-M:: %bignum>integer ( dst src -- )
+M:: %bignum>integer ( dst src temp -- )
     [
         "end" define-label
-        scratch-reg src 1 bignum@ LWZ
+        temp src 1 bignum@ LWZ
         ! if the length is 1, its just the sign and nothing else,
         ! so output 0
         0 dst LI
-        0 scratch-reg 1 v>operand CMPI
+        0 temp 1 v>operand CMPI
         "end" get BEQ
         ! load the value
         dst src 3 bignum@ LWZ
         ! load the sign
-        scratch-reg src 2 bignum@ LWZ
+        temp src 2 bignum@ LWZ
         ! branchless arithmetic: we want to turn 0 into 1,
         ! and 1 into -1
-        scratch-reg scratch-reg 1 SLWI
-        scratch-reg scratch-reg NEG
-        scratch-reg scratch-reg 1 ADDI
+        temp temp temp ADD
+        temp temp 1 SUBI
         ! multiply value by sign
-        dst dst scratch-reg MULLW
+        dst dst temp MULLW
         "end" resolve-label
     ] with-scope ;
 
@@ -200,20 +213,21 @@ M: ppc %sub-float FSUB ;
 M: ppc %mul-float FMUL ;
 M: ppc %div-float FDIV ;
 
-M: ppc %integer>float
-    HEX: 4330 "scratch" operand LIS
-    "scratch" operand 1 0 param@ STW
-    "in" operand dup HEX: 8000 XORIS
-    "in" operand 1 cell param@ STW
-    "f1" operand 1 0 param@ LFD
-    4503601774854144.0 "in" operand load-indirect
-    "f2" operand "in" operand float-offset LFD
-    "f1" operand "f1" operand "f2" operand FSUB ;
+M: ppc %integer>float ( dst src -- )
+    HEX: 4330 scratch-reg LIS
+    scratch-reg 1 0 param@ STW
+    scratch-reg src MR
+    scratch-reg dup HEX: 8000 XORIS
+    scratch-reg 1 cell param@ STW
+    fp-scratch-reg-2 1 0 param@ LFD
+    4503601774854144.0 scratch-reg load-indirect
+    fp-scratch-reg-2 scratch-reg float-offset LFD
+    fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
 
-M: ppc %float>integer
-    "scratch" operand "in" operand FCTIWZ
-    "scratch" operand 1 0 param@ STFD
-    "out" operand 1 cell param@ LWZ ;
+M:: ppc %float>integer ( dst src -- )
+    fp-scratch-reg-1 src FCTIWZ
+    fp-scratch-reg-2 1 0 param@ STFD
+    dst 1 4 param@ LWZ ;
 
 M: ppc %copy ( dst src -- ) MR ;
 
@@ -407,11 +421,32 @@ M: ppc %compare-branch (%compare) %branch ;
 M: ppc %compare-imm-branch (%compare-imm) %branch ;
 M: ppc %compare-float-branch (%compare-float) %branch ;
 
-! M: ppc %spill-integer ( src n -- ) spill-integer@ swap MOV ;
-! M: ppc %reload-integer ( dst n -- ) spill-integer@ MOV ;
-! 
-! M: ppc %spill-float ( src n -- ) spill-float@ swap MOVSD ;
-! M: ppc %reload-float ( dst n -- ) spill-float@ MOVSD ;
+: spill-integer-base ( stack-frame -- n )
+    [ params>> ] [ return>> ] bi + ;
+
+: stack@ 1 swap ; inline
+
+: spill-integer@ ( n -- op )
+    cells
+    stack-frame get spill-integer-base
+    + stack@ ;
+
+: spill-float-base ( stack-frame -- n )
+    [ spill-counts>> int-regs swap at int-regs reg-size * ]
+    [ params>> ]
+    [ return>> ]
+    tri + + ;
+
+: spill-float@ ( n -- op )
+    double-float-regs reg-size *
+    stack-frame get spill-float-base
+    + stack@ ;
+
+M: ppc %spill-integer ( src n -- ) spill-integer@ STW ;
+M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ;
+
+M: ppc %spill-float ( src n -- ) spill-float@ STFD ;
+M: ppc %reload-float ( dst n -- ) spill-float@ LFD ;
 
 M: ppc %loop-entry ;
 
diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S
index 412e277ea6..9fadc5df4a 100755
--- a/vm/cpu-ppc.S
+++ b/vm/cpu-ppc.S
@@ -4,30 +4,32 @@ in the public domain. */
 
 /* Note that the XT is passed to the quotation in r11 */
 #define CALL_OR_JUMP_QUOT \
-        lwz r11,9(r3)      /* load quotation-xt slot */ XX \
+	lwz r11,9(r3)	   /* load quotation-xt slot */ XX \
 
 #define CALL_QUOT \
-        CALL_OR_JUMP_QUOT XX \
-        mtlr r11           /* prepare to call XT with quotation in r3 */ XX \
-        blrl               /* go */
+	CALL_OR_JUMP_QUOT XX \
+	mtlr r11	   /* prepare to call XT with quotation in r3 */ XX \
+	blrl		   /* go */
 
 #define JUMP_QUOT \
-        CALL_OR_JUMP_QUOT XX \
-        mtctr r11          /* prepare to call XT with quotation in r3 */ XX \
-        bctr               /* go */
+	CALL_OR_JUMP_QUOT XX \
+	mtctr r11	   /* prepare to call XT with quotation in r3 */ XX \
+	bctr		   /* go */
 
 #define PARAM_SIZE 32
 
-#define SAVED_REGS_SIZE 96
+#define SAVED_INT_REGS_SIZE 96
 
-#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_REGS_SIZE + 8)
+#define SAVED_FP_REGS_SIZE 144
+
+#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8)
    
 #if defined( __APPLE__)
-        #define LR_SAVE 8
-        #define RESERVED_SIZE 24
+	#define LR_SAVE 8
+	#define RESERVED_SIZE 24
 #else
-        #define LR_SAVE 4
-        #define RESERVED_SIZE 8
+	#define LR_SAVE 4
+	#define RESERVED_SIZE 8
 #endif
 
 #define SAVE_LR(reg) stw reg,(LR_SAVE + FRAME)(r1)
@@ -36,99 +38,142 @@ in the public domain. */
 
 #define SAVE_AT(offset) (RESERVED_SIZE + PARAM_SIZE + 4 * offset)
 
-#define SAVE(register,offset) stw register,SAVE_AT(offset)(r1)
+#define SAVE_INT(register,offset) stw register,SAVE_AT(offset)(r1)
+#define RESTORE_INT(register,offset) lwz register,SAVE_AT(offset)(r1)
 
-#define RESTORE(register,offset) lwz register,SAVE_AT(offset)(r1)
+#define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1)
+#define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1)
 
 #define PROLOGUE \
-	mflr r0 XX         /* get caller's return address */ \
-        stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
-        SAVE_LR(r0)
+	mflr r0 XX	   /* get caller's return address */ \
+	stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
+	SAVE_LR(r0)
 
 #define EPILOGUE \
 	LOAD_LR(r0) XX \
-        lwz r1,0(r1) XX    /* destroy the stack frame */ \
-        mtlr r0            /* get ready to return */
+	lwz r1,0(r1) XX	   /* destroy the stack frame */ \
+	mtlr r0		   /* get ready to return */
 
+/* We have to save and restore nonvolatile registers because
+the Factor compiler treats the entire register file as volatile. */
 DEF(void,c_to_factor,(CELL quot)):
-        PROLOGUE
+	PROLOGUE
 
-	SAVE(r13,0)        /* save GPRs */
-                           /* don't save ds pointer */
-                           /* don't save rs pointer */
-        SAVE(r16,3)
-        SAVE(r17,4)
-        SAVE(r18,5)
-        SAVE(r19,6)
-        SAVE(r20,7)
-        SAVE(r21,8)
-        SAVE(r22,9)
-        SAVE(r23,10)
-        SAVE(r24,11)
-        SAVE(r25,12)
-        SAVE(r26,13)
-        SAVE(r27,14)
-        SAVE(r28,15)
-        SAVE(r29,16)
-        SAVE(r30,17)
-        SAVE(r31,18)
-	SAVE(r3,19)        /* save quotation since we're about to mangle it */
+	SAVE_INT(r13,0)	   /* save GPRs */
+			   /* don't save ds pointer */
+			   /* don't save rs pointer */
+	SAVE_INT(r16,3)
+	SAVE_INT(r17,4)
+	SAVE_INT(r18,5)
+	SAVE_INT(r19,6)
+	SAVE_INT(r20,7)
+	SAVE_INT(r21,8)
+	SAVE_INT(r22,9)
+	SAVE_INT(r23,10)
+	SAVE_INT(r24,11)
+	SAVE_INT(r25,12)
+	SAVE_INT(r26,13)
+	SAVE_INT(r27,14)
+	SAVE_INT(r28,15)
+	SAVE_INT(r29,16)
+	SAVE_INT(r30,17)
+	SAVE_INT(r31,18)
 
-        mr r3,r1           /* pass call stack pointer as an argument */
+	SAVE_FP(f14,20)    /* save FPRs */
+	SAVE_FP(f15,22)
+	SAVE_FP(f16,24)
+	SAVE_FP(f17,26)
+	SAVE_FP(f18,28)
+	SAVE_FP(f19,30)
+	SAVE_FP(f20,32)
+	SAVE_FP(f21,34)
+	SAVE_FP(f22,36)
+	SAVE_FP(f23,38)
+	SAVE_FP(f24,40)
+	SAVE_FP(f25,42)
+	SAVE_FP(f26,44)
+	SAVE_FP(f27,46)
+	SAVE_FP(f28,48)
+	SAVE_FP(f29,50)
+	SAVE_FP(f30,52)
+	SAVE_FP(f31,54)
+
+	SAVE_INT(r3,19)	   /* save quotation since we're about to mangle it */
+
+	mr r3,r1	   /* pass call stack pointer as an argument */
 	bl MANGLE(save_callstack_bottom)
 
-	RESTORE(r3,19)     /* restore quotation */
-        CALL_QUOT
+	RESTORE_INT(r3,19)     /* restore quotation */
+	CALL_QUOT
 
-        RESTORE(r31,18)    /* restore GPRs */
-        RESTORE(r30,17)
-        RESTORE(r29,16)
-        RESTORE(r28,15)
-        RESTORE(r27,14)
-        RESTORE(r26,13)
-        RESTORE(r25,12)
-        RESTORE(r24,11)
-        RESTORE(r23,10)
-        RESTORE(r22,9)
-        RESTORE(r21,8)
-        RESTORE(r20,7)
-        RESTORE(r19,6)
-        RESTORE(r18,5)
-        RESTORE(r17,4)
-        RESTORE(r16,3)
-                           /* don't restore rs pointer */
-                           /* don't restore ds pointer */
-        RESTORE(r13,0)
+	RESTORE_FP(f31,54)
+	RESTORE_FP(f30,52)
+	RESTORE_FP(f29,50)
+	RESTORE_FP(f28,48)
+	RESTORE_FP(f27,46)
+	RESTORE_FP(f26,44)
+	RESTORE_FP(f25,42)
+	RESTORE_FP(f24,40)
+	RESTORE_FP(f23,38)
+	RESTORE_FP(f22,36)
+	RESTORE_FP(f21,34)
+	RESTORE_FP(f20,32)
+	RESTORE_FP(f19,30)
+	RESTORE_FP(f18,28)
+	RESTORE_FP(f17,26)
+	RESTORE_FP(f16,24)
+	RESTORE_FP(f15,22)
+	RESTORE_FP(f14,20)    /* save FPRs */
 
-        EPILOGUE
-        blr
+	RESTORE_INT(r31,18)    /* restore GPRs */
+	RESTORE_INT(r30,17)
+	RESTORE_INT(r29,16)
+	RESTORE_INT(r28,15)
+	RESTORE_INT(r27,14)
+	RESTORE_INT(r26,13)
+	RESTORE_INT(r25,12)
+	RESTORE_INT(r24,11)
+	RESTORE_INT(r23,10)
+	RESTORE_INT(r22,9)
+	RESTORE_INT(r21,8)
+	RESTORE_INT(r20,7)
+	RESTORE_INT(r19,6)
+	RESTORE_INT(r18,5)
+	RESTORE_INT(r17,4)
+	RESTORE_INT(r16,3)
+			   /* don't restore rs pointer */
+			   /* don't restore ds pointer */
+	RESTORE_INT(r13,0)
+
+	EPILOGUE
+	blr
 
 /* We pass a function pointer to memcpy in r6 to work around a Mac OS X ABI
 limitation which would otherwise require us to do a bizzaro PC-relative
 trampoline to retrieve the function address */
 DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
-        sub r1,r3,r5       /* compute new stack pointer */
-        mr r3,r1           /* start of destination of memcpy() */
-	stwu r1,-64(r1)    /* setup fake stack frame for memcpy() */
-	mtlr r6            /* prepare to call memcpy() */
-        blrl               /* go */
-	lwz r1,0(r1)       /* tear down fake stack frame */
-        lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */
-        mtlr r0            /* prepare to return to restored callstack */
-        blr                /* go */
+	sub r1,r3,r5	   /* compute new stack pointer */
+	mr r3,r1	   /* start of destination of memcpy() */
+	stwu r1,-64(r1)	   /* setup fake stack frame for memcpy() */
+	mtlr r6		   /* prepare to call memcpy() */
+	blrl		   /* go */
+	lwz r1,0(r1)	   /* tear down fake stack frame */
+	lwz r0,LR_SAVE(r1) /* we have restored the stack; load return address */
+	mtlr r0		   /* prepare to return to restored callstack */
+	blr		   /* go */
 
 DEF(void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
-	mr r1,r4           /* compute new stack pointer */
+	mr r1,r4	   /* compute new stack pointer */
 	lwz r0,LR_SAVE(r1) /* we have rewound the stack; load return address */
 	mtlr r0
-	JUMP_QUOT          /* call the quotation */
+	JUMP_QUOT	   /* call the quotation */
 
 DEF(void,lazy_jit_compile,(CELL quot)):
-	mr r4,r1           /* save stack pointer */
+	mr r4,r1	   /* save stack pointer */
 	PROLOGUE
 	bl MANGLE(primitive_jit_compile)
 	EPILOGUE
-        JUMP_QUOT          /* call the quotation */
+	JUMP_QUOT	   /* call the quotation */
 
 /* Thanks to Joshua Grams for this code.
 
@@ -136,19 +181,19 @@ On PowerPC processors, we must flush the instruction cache manually
 after writing to the code heap. */
 
 DEF(void,flush_icache,(void *start, int len)):
-        /* compute number of cache lines to flush */
-        add r4,r4,r3
-        clrrwi r3,r3,5     /* align addr to next lower cache line boundary */
-        sub r4,r4,r3       /* then n_lines = (len + 0x1f) / 0x20 */
-        addi r4,r4,0x1f
-        srwi. r4,r4,5      /* note '.' suffix */
-        beqlr              /* if n_lines == 0, just return. */
-        mtctr r4           /* flush cache lines */
-0:      dcbf 0,r3          /* for each line... */
-        sync
-        icbi 0,r3
-        addi r3,r3,0x20
-        bdnz 0b
-        sync               /* finish up */
-        isync
-        blr
+	/* compute number of cache lines to flush */
+	add r4,r4,r3
+	clrrwi r3,r3,5	   /* align addr to next lower cache line boundary */
+	sub r4,r4,r3	   /* then n_lines = (len + 0x1f) / 0x20 */
+	addi r4,r4,0x1f
+	srwi. r4,r4,5	   /* note '.' suffix */
+	beqlr		   /* if n_lines == 0, just return. */
+	mtctr r4	   /* flush cache lines */
+0:	dcbf 0,r3	   /* for each line... */
+	sync
+	icbi 0,r3
+	addi r3,r3,0x20
+	bdnz 0b
+	sync		   /* finish up */
+	isync
+	blr
diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h
index 810aef8b5d..0f10aa34aa 100755
--- a/vm/cpu-ppc.h
+++ b/vm/cpu-ppc.h
@@ -1,8 +1,8 @@
 #define FACTOR_CPU_STRING "ppc"
 #define F_FASTCALL
 
-register CELL ds asm("r14");
-register CELL rs asm("r15");
+register CELL ds asm("r30");
+register CELL rs asm("r31");
 
 void c_to_factor(CELL quot);
 void undefined(CELL word);

From affb48a067cd60026eb7d07402d8297347e76fdb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 04:27:12 -0600
Subject: [PATCH 141/318] Fix docs

---
 basis/unix/groups/groups-docs.factor | 23 ++++++-------------
 basis/unix/users/users-docs.factor   | 33 +++++++++-------------------
 2 files changed, 17 insertions(+), 39 deletions(-)

diff --git a/basis/unix/groups/groups-docs.factor b/basis/unix/groups/groups-docs.factor
index ef2631ae3f..18c2e2384a 100644
--- a/basis/unix/groups/groups-docs.factor
+++ b/basis/unix/groups/groups-docs.factor
@@ -4,21 +4,15 @@ USING: help.markup help.syntax io.streams.string kernel quotations sequences str
 IN: unix.groups
 
 HELP: all-groups
-{ $values
-    
-     { "seq" sequence } }
+{ $values { "seq" sequence } }
 { $description "Returns a sequence of " { $link group } " tuples that are platform-dependent and field for field complete with the Unix " { $link group } " structure." } ;
 
 HELP: effective-group-id
-{ $values
-    
-     { "string" string } }
+{ $values { "string" string } }
 { $description "Returns the effective group id for the current user." } ;
 
 HELP: effective-group-name
-{ $values
-    
-     { "string" string } }
+{ $values { "string" string } }
 { $description "Returns the effective group name for the current user." } ;
 
 HELP: group
@@ -46,15 +40,11 @@ HELP: group-struct
 { $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ;
 
 HELP: real-group-id
-{ $values
-    
-     { "id" integer } }
+{ $values { "id" integer } }
 { $description "Returns the real group id for the current user." } ;
 
 HELP: real-group-name
-{ $values
-    
-     { "string" string } }
+{ $values { "string" string } }
 { $description "Returns the real group name for the current user." } ;
 
 HELP: set-effective-group
@@ -88,8 +78,9 @@ HELP: with-real-group
      { "string/id" "a string or a group id" } { "quot" quotation } }
 { $description "Sets the real group name and calls the quotation. Restores the current group name on success or on error after the call." } ;
 
-ARTICLE: "unix.groups" "unix.groups"
+ARTICLE: "unix.groups" "Unix groups"
 "The " { $vocab-link "unix.groups" } " vocabulary contains words that return information about Unix groups."
+$nl
 "Listing all groups:"
 { $subsection all-groups }
 "Returning a passwd tuple:"
diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor
index f8586ffc35..c466ad1575 100644
--- a/basis/unix/users/users-docs.factor
+++ b/basis/unix/users/users-docs.factor
@@ -4,27 +4,19 @@ USING: help.markup help.syntax io.streams.string kernel quotations sequences str
 IN: unix.users
 
 HELP: all-users
-{ $values
-    
-     { "seq" sequence } }
+{ $values { "seq" sequence } }
 { $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ;
 
 HELP: effective-username
-{ $values
-    
-     { "string" string } }
+{ $values { "string" string } }
 { $description "Returns the effective username for the current user." } ;
 
 HELP: effective-user-id
-{ $values
-    
-     { "id" integer } }
+{ $values { "id" integer } }
 { $description "Returns the effective username id for the current user." } ;
 
 HELP: new-passwd
-{ $values
-    
-     { "passwd" passwd } }
+{ $values { "passwd" passwd } }
 { $description "Creates a new passwd tuple dependent on the operating system." } ;
 
 HELP: passwd
@@ -40,25 +32,19 @@ HELP: passwd>new-passwd
 { $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ;
 
 HELP: real-username
-{ $values
-    
-     { "string" string } }
+{ $values { "string" string } }
 { $description "The real username of the current user." } ;
 
 HELP: real-user-id
-{ $values
-    
-     { "id" integer } }
+{ $values { "id" integer } }
 { $description "The real user id of the current user." } ;
 
 HELP: set-effective-user
-{ $values
-     { "string/id" "a string or a user id" } }
+{ $values { "string/id" "a string or a user id" } }
 { $description "Sets the current effective user given a username or a user id." } ;
 
 HELP: set-real-user
-{ $values
-     { "string/id" "a string or a user id" } }
+{ $values { "string/id" "a string or a user id" } }
 { $description "Sets the current real user given a username or a user id." } ;
 
 HELP: user-passwd
@@ -100,8 +86,9 @@ HELP: with-real-user
     set-effective-user
 } related-words
 
-ARTICLE: "unix.users" "unix.users"
+ARTICLE: "unix.users" "Unix users"
 "The " { $vocab-link "unix.users" } " vocabulary contains words that return information about Unix users."
+$nl
 "Listing all users:"
 { $subsection all-users }
 "Returning a passwd tuple:"

From 7f59942219260c109efe0ffa63c0d9115e2bb4bd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 04:28:13 -0600
Subject: [PATCH 142/318] Change title to be more consistent

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

diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor
index 7f7b012a35..f54e1e4041 100644
--- a/basis/ui/tools/tools-docs.factor
+++ b/basis/ui/tools/tools-docs.factor
@@ -117,7 +117,7 @@ ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts"
 { $heading "Implementation" }
 "Workspaces are instances of " { $link workspace } "." ;
 
-ARTICLE: "ui-tools" "UI development tools"
+ARTICLE: "ui-tools" "UI developer tools"
 "The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
 $nl
 "To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."

From 81c7320f7b89dda21843fb9d88d2878d5bd723c0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 05:14:35 -0600
Subject: [PATCH 143/318] mason.updates was calling download-my-image, which
 uses the current CPU/OS instead of target-cpu and target-os. So doing 32-bit
 builds from a 64-bit Factor instance didn't work... oops

---
 extra/mason/platform/platform.factor | 12 +++++-------
 extra/mason/updates/updates.factor   |  3 ++-
 2 files changed, 7 insertions(+), 8 deletions(-)

diff --git a/extra/mason/platform/platform.factor b/extra/mason/platform/platform.factor
index e4bba51491..cd7d3f3836 100644
--- a/extra/mason/platform/platform.factor
+++ b/extra/mason/platform/platform.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel system accessors namespaces splitting sequences make
+USING: kernel system accessors namespaces splitting sequences
 mason.config ;
 IN: mason.platform
 
@@ -10,10 +10,8 @@ IN: mason.platform
 : gnu-make ( -- string )
     target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
 
+: boot-image-arch ( -- string )
+    target-cpu get dup "ppc" = [ target-os get "-" append prepend ] when ;
+
 : boot-image-name ( -- string )
-    [
-        "boot." %
-        target-cpu get "ppc" = [ target-os get % "-" % ] when
-        target-cpu get %
-        ".image" %
-    ] "" make ;
+    "boot." boot-image-arch ".image" 3append ;
diff --git a/extra/mason/updates/updates.factor b/extra/mason/updates/updates.factor
index 9c42ba2850..b3f6847c35 100644
--- a/extra/mason/updates/updates.factor
+++ b/extra/mason/updates/updates.factor
@@ -20,7 +20,8 @@ IN: mason.updates
     = not ;
 
 : new-image-available? ( -- ? )
-    boot-image-name need-new-image? [ download-my-image t ] [ f ] if ;
+    boot-image-name need-new-image?
+    [ boot-image-arch download-image t ] [ f ] if ;
 
 : new-code-available? ( -- ? )
     updates-available?

From 373c05ee499d0f3c175ed9ddb563e4df658fdae2 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 5 Nov 2008 19:24:19 -0500
Subject: [PATCH 144/318] Forgot to inline collect-benchmarks word

---
 extra/project-euler/ave-time/ave-time.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor
index 2a516513a5..f176bbc7d2 100644
--- a/extra/project-euler/ave-time/ave-time.factor
+++ b/extra/project-euler/ave-time/ave-time.factor
@@ -9,7 +9,7 @@ IN: project-euler.ave-time
         [ datastack ]
         [ '[ _ gc benchmark , ] tuck '[ _ _ with-datastack drop ] ]
         [ 1- ] tri* swap times call
-    ] { } make ;
+    ] { } make ; inline
 
 : nth-place ( x n -- y )
     10 swap ^ [ * round ] keep / ;

From 4fd1767768c85332913d208c32a6abb8f2a0ce28 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 18:32:02 -0600
Subject: [PATCH 145/318] Old fix for classes-intersect? no-method bug was
 incorrect; we were ignoring anonymous classes in compiled-generic-crossref.
 Also, forget* now calls reset-word so that references to predicates of
 forgotten classes don't break the compiler with a similar error.

---
 basis/compiler/tests/redefine12.factor | 20 +++++++++++++++
 core/classes/algebra/algebra.factor    |  8 ++++++
 core/classes/classes-tests.factor      | 34 ++++++++++++++++++++++++++
 core/classes/classes.factor            | 24 +++++++++---------
 core/compiler/units/units.factor       |  2 +-
 core/words/words.factor                | 12 +++------
 6 files changed, 80 insertions(+), 20 deletions(-)
 create mode 100644 basis/compiler/tests/redefine12.factor

diff --git a/basis/compiler/tests/redefine12.factor b/basis/compiler/tests/redefine12.factor
new file mode 100644
index 0000000000..87dc4596e9
--- /dev/null
+++ b/basis/compiler/tests/redefine12.factor
@@ -0,0 +1,20 @@
+USING: kernel tools.test eval ;
+IN: compiler.tests.redefine12
+
+! A regression that came about when fixing the
+! 'no method on classes-intersect?' bug
+
+GENERIC: g ( a -- b )
+
+M: object g drop t ;
+
+: h ( a -- b ) dup [ g ] when ;
+
+[ f ] [ f h ] unit-test
+[ t ] [ "hi" h ] unit-test
+
+TUPLE: jeah ;
+
+[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
+
+[ f ] [ T{ jeah } h ] unit-test
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index 51dad033a9..b7e6800950 100644
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -20,6 +20,14 @@ C: <anonymous-complement> anonymous-complement
 : 2cache ( key1 key2 assoc quot -- value )
     >r >r 2array r> [ first2 ] r> compose cache ; inline
 
+GENERIC: valid-class? ( obj -- ? )
+
+M: class valid-class? drop t ;
+M: anonymous-union valid-class? members>> [ valid-class? ] all? ;
+M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;
+M: anonymous-complement valid-class? class>> valid-class? ;
+M: word valid-class? drop f ;
+
 DEFER: (class<=)
 
 : class<= ( first second -- ? )
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index c7900da316..673c108b27 100644
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -79,3 +79,37 @@ USE: multiline
     : q ( -- b ) j new g ;"> <string-reader>
     "class-intersect-no-method-b" parse-stream drop
 ] unit-test
+
+! Similar problem, but with anonymous classes
+[ ] [
+    <" IN: classes.test.c
+    USE: kernel
+    GENERIC: g ( a -- b )
+    M: object g ;
+    TUPLE: z ;"> <string-reader>
+    "class-intersect-no-method-c" parse-stream drop
+] unit-test
+
+[ ] [
+    <" IN: classes.test.d
+    USE: classes.test.c
+    USE: kernel
+    : q ( a -- b ) dup z? [ g ] unless ;"> <string-reader>
+    "class-intersect-no-method-d" parse-stream drop
+] unit-test
+
+! Now, the user removes the z class and adds a method,
+[ ] [
+    <" IN: classes.test.c
+    USE: kernel
+    GENERIC: g ( a -- b )
+    M: object g ;
+    TUPLE: j ;
+    M: j g ;"> <string-reader>
+    "class-intersect-no-method-c" parse-stream drop
+] unit-test
+
+TUPLE: forgotten-predicate-test ;
+
+[ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
+[ f ] [ \ forgotten-predicate-test? predicate? ] unit-test
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 70fb869c5c..2ce4b934c8 100644
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -32,8 +32,7 @@ SYMBOL: update-map
 
 SYMBOL: implementors-map
 
-PREDICATE: class < word
-    "class" word-prop ;
+PREDICATE: class < word "class" word-prop ;
 
 : classes ( -- seq ) implementors-map get keys ;
 
@@ -42,9 +41,12 @@ PREDICATE: class < word
 
 PREDICATE: predicate < word "predicating" word-prop >boolean ;
 
+M: predicate reset-word
+    [ call-next-method ] [ { "predicating" } reset-props ] bi ;
+
 : define-predicate ( class quot -- )
-    >r "predicate" word-prop first
-    r> (( object -- ? )) define-declared ;
+    [ "predicate" word-prop first ] dip
+    (( object -- ? )) define-declared ;
 
 : superclass ( class -- super )
     #! Output f for non-classes to work with algebra code
@@ -121,13 +123,13 @@ M: sequence implementors [ implementors ] gather ;
     ] H{ } make-assoc ;
 
 : (define-class) ( word props -- )
-    >r
-    dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
-    dup reset-class
-    dup deferred? [ dup define-symbol ] when
-    dup redefined
-    dup props>>
-    r> assoc-union >>props
+    [
+        dup class? [ dup [ implementors-map+ ] [ new-class ] bi ] unless
+        dup reset-class
+        dup deferred? [ dup define-symbol ] when
+        dup redefined
+        dup props>>
+    ] dip assoc-union >>props
     dup predicate-word
     [ 1quotation "predicate" set-word-prop ]
     [ swap "predicating" set-word-prop ]
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 1b6b934dae..72496a5f76 100644
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -111,7 +111,7 @@ SYMBOL: remake-generics-hook
 : (compiled-generic-usages) ( generic class -- assoc )
     [ compiled-generic-usage ] dip
     [
-        2dup [ class? ] both?
+        2dup [ valid-class? ] both?
         [ classes-intersect? ] [ 2drop f ] if nip
     ] curry assoc-filter ;
 
diff --git a/core/words/words.factor b/core/words/words.factor
index b7b34f1d22..ce1fdf194b 100644
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -204,13 +204,9 @@ GENERIC: reset-word ( word -- )
 
 M: word reset-word
     {
-        "unannotated-def"
-        "parsing" "inline" "recursive" "foldable" "flushable"
-        "predicating"
-        "reading" "writing"
-        "reader" "writer"
-        "constructing"
-        "declared-effect" "constructor-quot" "delimiter"
+        "unannotated-def" "parsing" "inline" "recursive"
+        "foldable" "flushable" "reading" "writing" "reader"
+        "writer" "declared-effect" "delimiter"
     } reset-props ;
 
 GENERIC: subwords ( word -- seq )
@@ -261,7 +257,7 @@ M: word forget*
     dup "forgotten" word-prop [ drop ] [
         [ delete-xref ]
         [ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
-        [ t "forgotten" set-word-prop ]
+        [ [ reset-word ] [ t "forgotten" set-word-prop ] bi ]
         tri
     ] if ;
 

From fbb958da829d40b43c1d0ff3b0ed616f07b43703 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 18:59:58 -0600
Subject: [PATCH 146/318] Fix lambda-method forget

---
 basis/locals/locals-tests.factor | 9 ++++++++-
 basis/locals/locals.factor       | 2 +-
 2 files changed, 9 insertions(+), 2 deletions(-)

diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor
index c449c26348..003ef459e3 100644
--- a/basis/locals/locals-tests.factor
+++ b/basis/locals/locals-tests.factor
@@ -1,7 +1,8 @@
 USING: locals math sequences tools.test hashtables words kernel
 namespaces arrays strings prettyprint io.streams.string parser
 accessors generic eval combinators combinators.short-circuit
-combinators.short-circuit.smart math.order math.functions ;
+combinators.short-circuit.smart math.order math.functions
+definitions compiler.units ;
 IN: locals.tests
 
 :: foo ( a b -- a a ) a a ;
@@ -378,6 +379,12 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
 
 [ 9 ] [ 3 big-case-test ] unit-test
 
+GENERIC: lambda-method-forget-test ( a -- b )
+
+M:: integer lambda-method-forget-test ( a -- b ) ;
+
+[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
+
 ! :: wlet-&&-test ( a -- ? )
 !     [wlet | is-integer? [ a integer? ]
 !             is-even? [ a even? ]
diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
index 89a5c02746..c588269284 100644
--- a/basis/locals/locals.factor
+++ b/basis/locals/locals.factor
@@ -450,7 +450,7 @@ M: lambda-method definition
     "lambda" word-prop body>> ;
 
 M: lambda-method reset-word
-    [ f "lambda" set-word-prop ] [ call-next-method ] bi ;
+    [ call-next-method ] [ f "lambda" set-word-prop ] bi ;
 
 INTERSECTION: lambda-memoized memoized lambda-word ;
 

From 4e98751ce027dd181b3c6a6eb17f6a0cac0cc7b0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 20:23:38 -0600
Subject: [PATCH 147/318] Remove a conditional branch from all tuple
 dispatches, since we don't have to check if the class height is at least 1;
 and remove memory accesses from tuple dispatch where all tuples are height 1

---
 .../standard/engines/tuple/tuple.factor       | 45 +++++++++++--------
 core/generic/standard/standard.factor         | 29 ++++++------
 2 files changed, 42 insertions(+), 32 deletions(-)

diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 8c61aa4240..250ccef6cc 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -123,8 +123,8 @@ M: echelon-dispatch-engine engine>quot
         ] [ ] make
     ] if ;
 
-: >=-case-quot ( alist -- quot )
-    default get [ drop ] prepend swap
+: >=-case-quot ( default alist -- quot )
+    [ [ drop ] prepend ] dip
     [
         [ [ dup ] swap [ fixnum>= ] curry compose ]
         [ [ drop ] prepose ]
@@ -132,31 +132,40 @@ M: echelon-dispatch-engine engine>quot
     ] assoc-map
     alist>quot ;
 
-: tuple-layout-echelon% ( -- )
+: tuple-layout-echelon-quot ( -- quot )
     [
         { tuple } declare
         1 slot { tuple-layout } declare
         5 slot
-    ] % ; inline
+    ] ; inline
+
+: echelon-case-quot ( alist -- quot )
+    #! We don't have to test for echelon 1 since all tuple
+    #! classes are at least at depth 1 in the inheritance
+    #! hierarchy.
+    dup first first 1 = [ unclip second ] [ default get ] if swap
+    [
+        [
+            picker %
+            tuple-layout-echelon-quot %
+            >=-case-quot %
+        ] [ ] make
+    ] unless-empty ;
 
 M: tuple-dispatch-engine engine>quot
     [
-        picker %
-        tuple-layout-echelon%
         [
             tuple assumed set
-            echelons>> dup empty? [
-                unclip-last
+            echelons>> unclip-last
+            [
                 [
-                    [
-                        engine>quot define-engine-word
-                        [ remember-engine ] [ 1quotation ] bi
-                        dup default set
-                    ] assoc-map
-                ]
-                [ first2 engine>quot 2array ] bi*
-                suffix
-            ] unless
+                    engine>quot define-engine-word
+                    [ remember-engine ] [ 1quotation ] bi
+                    dup default set
+                ] assoc-map
+            ]
+            [ first2 engine>quot 2array ] bi*
+            suffix
         ] with-scope
-        >=-case-quot %
+        echelon-case-quot %
     ] [ ] make ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index d22d20a0fc..284a58836f 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -60,21 +60,22 @@ ERROR: no-method object generic ;
     [ 1quotation ] [ extra-values \ drop <repetition> ] bi*
     prepend [ ] like ;
 
+: <standard-engine> ( word -- engine )
+    object bootstrap-word assumed set {
+        [ generic set ]
+        [ "engines" word-prop forget-all ]
+        [ V{ } clone "engines" set-word-prop ]
+        [
+            "methods" word-prop
+            [ generic get mangle-method ] assoc-map
+            [ find-default default set ]
+            [ <big-dispatch-engine> ]
+            bi
+        ]
+    } cleave ;
+
 : single-combination ( word -- quot )
-    [
-        object bootstrap-word assumed set {
-            [ generic set ]
-            [ "engines" word-prop forget-all ]
-            [ V{ } clone "engines" set-word-prop ]
-            [
-                "methods" word-prop
-                [ generic get mangle-method ] assoc-map
-                [ find-default default set ]
-                [ <big-dispatch-engine> ]
-                bi engine>quot
-            ]
-        } cleave
-    ] with-scope ;
+    [ <standard-engine> engine>quot ] with-scope ;
 
 ERROR: inconsistent-next-method class generic ;
 

From 15257b91ac4489fd4fe447204bcb3a88b96f28f8 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 5 Nov 2008 22:59:06 -0500
Subject: [PATCH 148/318] Refactor math.text.english using new combinators

---
 extra/math/text/english/english.factor | 25 +++++++++++--------------
 1 file changed, 11 insertions(+), 14 deletions(-)

diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor
index 439d0a75fe..dfb0c00388 100755
--- a/extra/math/text/english/english.factor
+++ b/extra/math/text/english/english.factor
@@ -1,7 +1,7 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.lib kernel math math.functions math.parser namespaces
-sequences splitting grouping combinators.short-circuit ;
+USING: combinators.short-circuit grouping kernel math math.parser namespaces
+    sequences ;
 IN: math.text.english
 
 <PRIVATE
@@ -52,13 +52,11 @@ SYMBOL: and-needed?
     ] if ;
 
 : 3digits>text ( n -- str )
-    dup hundreds-place swap tens-place append ;
+    [ hundreds-place ] [ tens-place ] bi append ;
 
 : text-with-scale ( index seq -- str )
-    dupd nth 3digits>text swap
-    scale-numbers [
-        " " swap 3append
-    ] unless-empty ;
+    [ nth 3digits>text ] [ drop scale-numbers ] 2bi
+    [ " " swap 3append ] unless-empty ;
 
 : append-with-conjunction ( str1 str2 -- newstr )
     over length zero? [
@@ -68,20 +66,19 @@ SYMBOL: and-needed?
         and-needed? off
     ] if ;
 
-: (recombine) ( str index seq -- newstr seq )
+: (recombine) ( str index seq -- newstr )
     2dup nth zero? [
-        nip
+        2drop
     ] [
-        [ text-with-scale ] keep
-        -rot append-with-conjunction swap
+        text-with-scale append-with-conjunction
     ] if ;
 
 : recombine ( seq -- str )
     dup length 1 = [
         first 3digits>text
     ] [
-        dup set-conjunction "" swap
-        dup length [ swap (recombine) ] each drop
+        [ set-conjunction "" ] [ length ] [ ] tri
+        [ (recombine) ] curry each
     ] if ;
 
 : (number>text) ( n -- str )

From cc879fa9b7c1febf7d6d5aec38aa55f496d63d28 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 5 Nov 2008 22:20:29 -0600
Subject: [PATCH 149/318] Tuple layouts are now arrays, instead of built-in
 types. The superclass array is now part of the tuple layout object itself,
 and class hashcodes are stored alongside class words there. This removes 2
 indirections when reading a superclass, and 3 when reading a superclass
 hashcode.

---
 basis/bootstrap/image/image.factor            | 15 ----
 .../cfg/intrinsics/allot/allot.factor         |  6 +-
 .../tree/propagation/info/info.factor         |  2 +-
 .../known-words/known-words.factor            |  2 +-
 .../tree/propagation/propagation-tests.factor |  2 +-
 .../tree/propagation/slots/slots.factor       |  2 +-
 basis/prettyprint/backend/backend.factor      |  3 -
 .../known-words/known-words.factor            |  5 +-
 core/bootstrap/layouts/layouts.factor         |  5 +-
 core/bootstrap/primitives.factor              | 10 ---
 core/bootstrap/stage1.factor                  |  3 +-
 core/classes/tuple/tuple-docs.factor          |  6 +-
 core/classes/tuple/tuple-tests.factor         |  2 +-
 core/classes/tuple/tuple.factor               | 34 +++++---
 .../standard/engines/tuple/tuple.factor       | 79 +++++++------------
 vm/data_gc.c                                  |  2 -
 vm/debug.c                                    | 11 ++-
 vm/layouts.h                                  | 16 ++--
 vm/primitives.c                               |  1 -
 vm/types.c                                    | 16 +---
 20 files changed, 85 insertions(+), 137 deletions(-)

diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index 643899102e..fdc8451173 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -368,21 +368,6 @@ M: byte-array '
 
 M: tuple ' emit-tuple ;
 
-M: tuple-layout '
-    [
-        [
-            {
-                [ hashcode>> , ]
-                [ class>> , ]
-                [ size>> , ]
-                [ superclasses>> , ]
-                [ echelon>> , ]
-            } cleave
-        ] { } make [ ' ] map
-        \ tuple-layout type-number
-        object tag-number [ emit-seq ] emit-object
-    ] cache-object ;
-
 M: tombstone '
     state>> "((tombstone))" "((empty))" ?
     "hashtables.private" lookup def>> first
diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor
index f0796c59f0..ceac5e960c 100644
--- a/basis/compiler/cfg/intrinsics/allot/allot.factor
+++ b/basis/compiler/cfg/intrinsics/allot/allot.factor
@@ -16,14 +16,14 @@ IN: compiler.cfg.intrinsics.allot
     [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
 
 : tuple-slot-regs ( layout -- vregs )
-    [ size>> ds-load ] [ ^^load-literal ] bi prefix ;
+    [ second ds-load ] [ ^^load-literal ] bi prefix ;
 
 : emit-<tuple-boa> ( node -- )
     dup node-input-infos peek literal>>
-    dup tuple-layout? [
+    dup array? [
         nip
         ds-drop
-        [ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
+        [ tuple-slot-regs ] [ second ^^allot-tuple ] bi
         [ tuple ##set-slots ] [ ds-push drop ] 2bi
     ] [ drop emit-primitive ] if ;
 
diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 5f8de4eb49..d1d8189f7a 100644
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -307,5 +307,5 @@ SYMBOL: value-infos
 : immutable-tuple-boa? ( #call -- ? )
     dup word>> \ <tuple-boa> eq? [
         dup in-d>> peek node-value-info
-        literal>> class>> immutable-tuple-class?
+        literal>> first immutable-tuple-class?
     ] [ drop f ] if ;
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index a1ccaa95bd..3b698e0001 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -281,7 +281,7 @@ generic-comparison-ops [
 
 { <tuple> <tuple-boa> } [
     [
-        literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
+        literal>> dup array? [ first ] [ drop tuple ] if <class-info>
         [ clear ] dip
     ] "outputs" set-word-prop
 ] each
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 19ee051ac6..101320f92c 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -379,7 +379,7 @@ TUPLE: mutable-tuple-test { x sequence } ;
     [ T{ mutable-tuple-test f "hey" } x>> ] final-classes
 ] unit-test
 
-[ V{ tuple-layout } ] [
+[ V{ array } ] [
     [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
 ] unit-test
 
diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor
index 08a8520d0a..83e71c3363 100644
--- a/basis/compiler/tree/propagation/slots/slots.factor
+++ b/basis/compiler/tree/propagation/slots/slots.factor
@@ -45,7 +45,7 @@ UNION: fixed-length-sequence array byte-array string ;
 
 : propagate-<tuple-boa> ( #call -- info )
     in-d>> unclip-last
-    value-info literal>> class>> (propagate-tuple-constructor) ;
+    value-info literal>> first (propagate-tuple-constructor) ;
 
 : propagate-<complex> ( #call -- info )
     in-d>> [ value-info ] map complex <tuple-info> ;
diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index f8445c7783..b749bd63eb 100644
--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@@ -233,6 +233,3 @@ M: wrapper pprint*
     ] [
         pprint-object
     ] if ;
-
-M: tuple-layout pprint*
-    "( tuple layout )" swap present-text ;
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 2c0bae5328..c40b94fd3c 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -108,7 +108,7 @@ M: object infer-call*
 
 : infer-<tuple-boa> ( -- )
     \ <tuple-boa>
-    peek-d literal value>> size>> 1+ { tuple } <effect>
+    peek-d literal value>> second 1+ { tuple } <effect>
     apply-word/effect ;
 
 : infer-(throw) ( -- )
@@ -561,9 +561,6 @@ do-primitive alien-invoke alien-indirect alien-callback
 \ <tuple> { tuple-layout } { tuple } define-primitive
 \ <tuple> make-flushable
 
-\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } define-primitive
-\ <tuple-layout> make-foldable
-
 \ datastack { } { array } define-primitive
 \ datastack make-flushable
 
diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor
index 08df740305..26100277a8 100644
--- a/core/bootstrap/layouts/layouts.factor
+++ b/core/bootstrap/layouts/layouts.factor
@@ -9,7 +9,7 @@ BIN: 111 tag-mask set
 8 num-tags set
 3 tag-bits set
 
-18 num-types set
+17 num-types set
 
 H{
     { fixnum      BIN: 000 }
@@ -29,9 +29,8 @@ tag-numbers get H{
     { byte-array 10 }
     { callstack 11 }
     { string 12 }
-    { tuple-layout 13 }
+    { word 13 }
     { quotation 14 }
     { dll 15 }
     { alien 16 }
-    { word 17 }
 } assoc-union type-numbers set
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index bbc86c2e3c..3accb8a9b8 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -147,7 +147,6 @@ bootstrapping? on
 "alien" "alien" create register-builtin
 "word" "words" create register-builtin
 "byte-array" "byte-arrays" create register-builtin
-"tuple-layout" "classes.tuple.private" create register-builtin
 
 ! For predicate classes
 "predicate-instance?" "classes.predicate" create drop
@@ -272,14 +271,6 @@ bi
 
 "callstack" "kernel" create { } define-builtin
 
-"tuple-layout" "classes.tuple.private" create {
-    { "hashcode" { "fixnum" "math" } read-only }
-    { "class" { "word" "words" } initial: t read-only }
-    { "size" { "fixnum" "math" } read-only }
-    { "superclasses" { "array" "arrays" } initial: { } read-only }
-    { "echelon" { "fixnum" "math" } read-only }
-} define-builtin
-
 "tuple" "kernel" create
 [ { } define-builtin ]
 [ define-tuple-layout ]
@@ -510,7 +501,6 @@ tuple
     { "array>quotation" "quotations.private" }
     { "quotation-xt" "quotations" }
     { "<tuple>" "classes.tuple.private" }
-    { "<tuple-layout>" "classes.tuple.private" }
     { "profiling" "tools.profiler.private" }
     { "become" "kernel.private" }
     { "(sleep)" "threads.private" }
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index efa7c4b877..26a27ecefb 100644
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -49,4 +49,5 @@ load-help? off
             1 exit
         ] if
     ] %
-] [ ] make bootstrap-boot-quot set
+] [ ] make
+bootstrap-boot-quot set
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index e16be25ce4..4d2c537522 100644
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -348,7 +348,7 @@ $nl
 { $list
     { { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
     { { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
-    { { $snippet "\"tuple-layout\"" } " - a " { $link tuple-layout } " instance" }
+    { { $snippet "\"tuple-layout\"" } " - an array with the tuple size and superclasses encoded in a format amneable to fast method dispatch" }
 } } ;
 
 HELP: define-tuple-predicate
@@ -405,11 +405,11 @@ HELP: tuple>array ( tuple -- array )
 { $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
 
 HELP: <tuple> ( layout -- tuple )
-{ $values { "layout" tuple-layout } { "tuple" tuple } }
+{ $values { "layout" "a tuple layout array" } { "tuple" tuple } }
 { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
 
 HELP: <tuple-boa> ( ... layout -- tuple )
-{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
+{ $values { "..." "values" } { "layout" "a tuple layout array" } { "tuple" tuple } }
 { $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
 
 HELP: new
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 5c91bdf8dd..dc078f5ac3 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -94,7 +94,7 @@ TUPLE: size-test a b c d ;
 
 [ t ] [
     T{ size-test } tuple-size
-    size-test tuple-layout size>> =
+    size-test tuple-layout second =
 ] unit-test
 
 GENERIC: <yo-momma>
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index ef2cf616be..e9c560bd90 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -10,8 +10,6 @@ IN: classes.tuple
 PREDICATE: tuple-class < class
     "metaclass" word-prop tuple-class eq? ;
 
-M: tuple class 1 slot 2 slot { word } declare ;
-
 ERROR: not-a-tuple object ;
 
 : check-tuple ( object -- tuple )
@@ -29,10 +27,12 @@ PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
     "layout" word-prop ;
 
 : layout-of ( tuple -- layout )
-    1 slot { tuple-layout } declare ; inline
+    1 slot { array } declare ; inline
+
+M: tuple class layout-of 2 slot { word } declare ;
 
 : tuple-size ( tuple -- size )
-    layout-of size>> ; inline
+    layout-of second ; inline
 
 : prepare-tuple>array ( tuple -- n tuple layout )
     check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
@@ -90,15 +90,19 @@ ERROR: bad-superclass class ;
         2drop f
     ] if ; inline
 
-: tuple-instance? ( object class echelon -- ? )
+: tuple-instance? ( object class offset -- ? )
     #! 4 slot == superclasses>>
     rot dup tuple? [
-        layout-of 4 slot { array } declare
-        2dup 1 slot fixnum< [ array-nth eq? ] [ 3drop f ] if
+        layout-of
+        2dup 1 slot fixnum<=
+        [ swap slot eq? ] [ 3drop f ] if
     ] [ 3drop f ] if ; inline
 
+: layout-class-offset ( class -- n )
+    tuple-layout third 2 * 5 + ;
+
 : define-tuple-predicate ( class -- )
-    dup dup tuple-layout echelon>>
+    dup dup layout-class-offset
     [ tuple-instance? ] 2curry define-predicate ;
 
 : class-size ( class -- n )
@@ -145,10 +149,14 @@ ERROR: bad-superclass class ;
     define-accessors ;
 
 : make-tuple-layout ( class -- layout )
-    [ ]
-    [ [ superclass class-size ] [ "slots" word-prop length ] bi + ]
-    [ superclasses dup length 1- ] tri
-    <tuple-layout> ;
+    [
+        {
+            [ , ]
+            [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
+            [ superclasses length 1- , ]
+            [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
+        } cleave
+    ] { } make ;
 
 : define-tuple-layout ( class -- )
     dup make-tuple-layout "layout" set-word-prop ;
@@ -284,7 +292,7 @@ M: tuple-class reset-class
 M: tuple-class rank-class drop 0 ;
 
 M: tuple-class instance?
-    dup tuple-layout echelon>> tuple-instance? ;
+    dup layout-class-offset tuple-instance? ;
 
 M: tuple-class (flatten-class) dup set ;
 
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 250ccef6cc..34447fb92d 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -7,18 +7,28 @@ classes.algebra math math.private kernel.private
 quotations arrays definitions ;
 IN: generic.standard.engines.tuple
 
+: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline
+
+: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline
+
+: tuple-layout% ( -- )
+    [ { tuple } declare 1 slot { array } declare ] % ; inline
+
+: tuple-layout-echelon% ( -- )
+    [ 4 slot ] % ; inline
+
 TUPLE: echelon-dispatch-engine n methods ;
 
 C: <echelon-dispatch-engine> echelon-dispatch-engine
 
-TUPLE: trivial-tuple-dispatch-engine methods ;
+TUPLE: trivial-tuple-dispatch-engine n methods ;
 
 C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
 
 TUPLE: tuple-dispatch-engine echelons ;
 
 : push-echelon ( class method assoc -- )
-    >r swap dup "layout" word-prop echelon>> r>
+    [ swap dup "layout" word-prop third ] dip
     [ ?set-at ] change-at ;
 
 : echelon-sort ( assoc -- assoc' )
@@ -38,19 +48,20 @@ TUPLE: tuple-dispatch-engine echelons ;
     \ <tuple-dispatch-engine> convert-methods ;
 
 M: trivial-tuple-dispatch-engine engine>quot
-    methods>> engines>quots* linear-dispatch-quot ;
+    [
+        [ n>> nth-superclass% ]
+        [ methods>> engines>quots* linear-dispatch-quot % ] bi
+    ] [ ] make ;
 
-: hash-methods ( methods -- buckets )
+: hash-methods ( n methods -- buckets )
     >alist V{ } clone [ hashcode 1array ] distribute-buckets
-    [ <trivial-tuple-dispatch-engine> ] map ;
+    [ <trivial-tuple-dispatch-engine> ] with map ;
 
-: word-hashcode% ( -- ) [ 1 slot ] % ;
-
-: class-hash-dispatch-quot ( methods -- quot )
+: class-hash-dispatch-quot ( n methods -- quot )
     [
         \ dup ,
-        word-hashcode%
-        hash-methods [ engine>quot ] map hash-dispatch-quot %
+        [ drop nth-hashcode% ]
+        [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi
     ] [ ] make ;
 
 : engine-word-name ( -- string )
@@ -79,29 +90,16 @@ M: engine-word irrelevant? drop t ;
     dup generic get "tuple-dispatch-generic" set-word-prop ;
 
 : define-engine-word ( quot -- word )
-    >r <engine-word> dup r> define ;
-
-: array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ;
-
-: tuple-layout-superclasses% ( -- )
-    [
-        { tuple } declare
-        1 slot { tuple-layout } declare
-        4 slot { array } declare
-    ] % ; inline
+    [ <engine-word> dup ] dip define ;
 
 : tuple-dispatch-engine-body ( engine -- quot )
     [
         picker %
-        tuple-layout-superclasses%
-        [ n>> array-nth% ]
-        [
-            methods>> [
-                <trivial-tuple-dispatch-engine> engine>quot
-            ] [
-                class-hash-dispatch-quot
-            ] if-small? %
-        ] bi
+        tuple-layout%
+        [ n>> ] [ methods>> ] bi
+        [ <trivial-tuple-dispatch-engine> engine>quot ]
+        [ class-hash-dispatch-quot ]
+        if-small? %
     ] [ ] make ;
 
 M: echelon-dispatch-engine engine>quot
@@ -109,18 +107,7 @@ M: echelon-dispatch-engine engine>quot
         methods>> dup assoc-empty?
         [ drop default get ] [ values first engine>quot ] if
     ] [
-        [
-            picker %
-            tuple-layout-superclasses%
-            [ n>> array-nth% ]
-            [
-                methods>> [
-                    <trivial-tuple-dispatch-engine> engine>quot
-                ] [
-                    class-hash-dispatch-quot
-                ] if-small? %
-            ] bi
-        ] [ ] make
+        tuple-dispatch-engine-body
     ] if ;
 
 : >=-case-quot ( default alist -- quot )
@@ -132,13 +119,6 @@ M: echelon-dispatch-engine engine>quot
     ] assoc-map
     alist>quot ;
 
-: tuple-layout-echelon-quot ( -- quot )
-    [
-        { tuple } declare
-        1 slot { tuple-layout } declare
-        5 slot
-    ] ; inline
-
 : echelon-case-quot ( alist -- quot )
     #! We don't have to test for echelon 1 since all tuple
     #! classes are at least at depth 1 in the inheritance
@@ -147,7 +127,8 @@ M: echelon-dispatch-engine engine>quot
     [
         [
             picker %
-            tuple-layout-echelon-quot %
+            tuple-layout%
+            tuple-layout-echelon%
             >=-case-quot %
         ] [ ] make
     ] unless-empty ;
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 2e05395d19..9aa4f88de6 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -244,8 +244,6 @@ CELL unaligned_object_size(CELL pointer)
 	case CALLSTACK_TYPE:
 		return callstack_size(
 			untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
-	case TUPLE_LAYOUT_TYPE:
-		return sizeof(F_TUPLE_LAYOUT);
 	default:
 		critical_error("Invalid header",pointer);
 		return -1; /* can't happen */
diff --git a/vm/debug.c b/vm/debug.c
index 0869d6a885..2550931c72 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -1,5 +1,7 @@
 #include "master.h"
 
+static bool full_output;
+
 void print_chars(F_STRING* str)
 {
 	CELL i;
@@ -39,7 +41,7 @@ void print_array(F_ARRAY* array, CELL nesting)
 	CELL i;
 	bool trimmed;
 
-	if(length > 10)
+	if(length > 10 && !full_output)
 	{
 		trimmed = true;
 		length = 10;
@@ -68,7 +70,7 @@ void print_tuple(F_TUPLE* tuple, CELL nesting)
 	CELL i;
 	bool trimmed;
 
-	if(length > 10)
+	if(length > 10 && !full_output)
 	{
 		trimmed = true;
 		length = 10;
@@ -88,7 +90,7 @@ void print_tuple(F_TUPLE* tuple, CELL nesting)
 
 void print_nested_obj(CELL obj, F_FIXNUM nesting)
 {
-	if(nesting <= 0)
+	if(nesting <= 0 && !full_output)
 	{
 		printf(" ... ");
 		return;
@@ -342,6 +344,7 @@ void factorbug(void)
 	printf("d <addr> <count> -- dump memory\n");
 	printf("u <addr>         -- dump object at tagged <addr>\n");
 	printf(". <addr>         -- print object at tagged <addr>\n");
+	printf("t                -- toggle output trimming\n");
 	printf("s r              -- dump data, retain stacks\n");
 	printf(".s .r .c         -- print data, retain, call stacks\n");
 	printf("e                -- dump environment\n");
@@ -404,6 +407,8 @@ void factorbug(void)
 			print_obj(addr);
 			printf("\n");
 		}
+		else if(strcmp(cmd,"t") == 0)
+			full_output = !full_output;
 		else if(strcmp(cmd,"s") == 0)
 			dump_memory(ds_bot,ds);
 		else if(strcmp(cmd,"r") == 0)
diff --git a/vm/layouts.h b/vm/layouts.h
index 7ebfe50dd4..6dc29efdae 100755
--- a/vm/layouts.h
+++ b/vm/layouts.h
@@ -52,13 +52,12 @@ typedef signed long long s64;
 #define BYTE_ARRAY_TYPE 10
 #define CALLSTACK_TYPE 11
 #define STRING_TYPE 12
-#define TUPLE_LAYOUT_TYPE 13
+#define WORD_TYPE 13
 #define QUOTATION_TYPE 14
 #define DLL_TYPE 15
 #define ALIEN_TYPE 16
-#define WORD_TYPE 17
 
-#define TYPE_COUNT 20
+#define TYPE_COUNT 17
 
 INLINE bool immediate_p(CELL obj)
 {
@@ -154,7 +153,8 @@ typedef struct {
 
 /* Assembly code makes assumptions about the layout of this struct */
 typedef struct {
-/* C sucks. */
+/* We use a union here to force the float value to be aligned on an
+8-byte boundary. */
 	union {
 		CELL header;
 		long long padding;
@@ -222,17 +222,17 @@ typedef struct
 	CELL size;
 } F_STACK_FRAME;
 
+/* These are really just arrays, but certain elements have special
+significance */
 typedef struct
 {
 	CELL header;
-	/* tagged fixnum */
-	CELL hashcode;
+	/* tagged */
+	CELL capacity;
 	/* tagged */
 	CELL class;
 	/* tagged fixnum */
 	CELL size;
-	/* tagged array */
-	CELL superclasses;
 	/* tagged fixnum */
 	CELL echelon;
 } F_TUPLE_LAYOUT;
diff --git a/vm/primitives.c b/vm/primitives.c
index 84cad12326..69e77f81ed 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -127,7 +127,6 @@ void *primitives[] = {
 	primitive_array_to_quotation,
 	primitive_quotation_xt,
 	primitive_tuple,
-	primitive_tuple_layout,
 	primitive_profiling,
 	primitive_become,
 	primitive_sleep,
diff --git a/vm/types.c b/vm/types.c
index ccc7cbdba3..5e2ed4bed9 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -298,18 +298,6 @@ F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL
 	return result;
 }
 
-/* Tuple layouts */
-DEFINE_PRIMITIVE(tuple_layout)
-{
-	F_TUPLE_LAYOUT *layout = allot_object(TUPLE_LAYOUT_TYPE,sizeof(F_TUPLE_LAYOUT));
-	layout->echelon = dpop();
-	layout->superclasses = dpop();
-	layout->size = dpop();
-	layout->class = dpop();
-	layout->hashcode = untag_word(layout->class)->hashcode;
-	dpush(tag_object(layout));
-}
-
 /* Tuples */
 
 /* push a new tuple on the stack */
@@ -325,7 +313,7 @@ F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
 DEFINE_PRIMITIVE(tuple)
 {
 	F_TUPLE_LAYOUT *layout = untag_object(dpop());
-	F_FIXNUM size = to_fixnum(layout->size);
+	F_FIXNUM size = untag_fixnum_fast(layout->size);
 
 	F_TUPLE *tuple = allot_tuple(layout);
 	F_FIXNUM i;
@@ -339,7 +327,7 @@ DEFINE_PRIMITIVE(tuple)
 DEFINE_PRIMITIVE(tuple_boa)
 {
 	F_TUPLE_LAYOUT *layout = untag_object(dpop());
-	F_FIXNUM size = to_fixnum(layout->size);
+	F_FIXNUM size = untag_fixnum_fast(layout->size);
 
 	REGISTER_UNTAGGED(layout);
 	F_TUPLE *tuple = allot_tuple(layout);

From db1a69f6aa9cfd185178ad8a661d988160fbf99c Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 9 Sep 2008 12:09:23 -0400
Subject: [PATCH 150/318] Adding support for ' quote syntax in lisp.parser

---
 extra/lisp/parser/parser.factor | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index 72344fd0dc..55672af13d 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -36,4 +36,6 @@ atom         = number
               | string
 s-expression = LPAREN (list-item)* RPAREN                => [[ second seq>cons ]]
 list-item    = _ ( atom | s-expression ) _               => [[ second ]]
-;EBNF
+quoted       = squote list-item                          => [[ second nil cons "quote" <lisp-symbol> swap cons ]]
+expr         = list-item | quoted
+;EBNF
\ No newline at end of file

From 6899bb28989f2cf3080fd25d32044c8fd3b636b4 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 9 Sep 2008 12:25:14 -0400
Subject: [PATCH 151/318] Adding tests for quoted forms in lisp.parser

---
 extra/lisp/parser/parser-tests.factor | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor
index d722390f9a..68bda1780a 100644
--- a/extra/lisp/parser/parser-tests.factor
+++ b/extra/lisp/parser/parser-tests.factor
@@ -65,4 +65,12 @@ IN: lisp.parser.tests
    }
 } [
     "(1 (3 4) 2)" lisp-expr
+] unit-test
+    
+{ { T{ lisp-symbol { name "quote" } } { 1 2 3 } } } [
+    "'(1 2 3)" lisp-expr cons>seq
+] unit-test
+    
+{ { T{ lisp-symbol f "quote" } T{ lisp-symbol f "foo" } } } [
+    "'foo" lisp-expr cons>seq
 ] unit-test
\ No newline at end of file

From f82cb061f5127ec319e61980129fa1b1db6145c7 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sun, 14 Sep 2008 20:23:40 -0400
Subject: [PATCH 152/318] Fixing bug with quoted expressions for lisp.parser

---
 extra/lisp/parser/parser-tests.factor | 4 ++++
 extra/lisp/parser/parser.factor       | 4 ++--
 2 files changed, 6 insertions(+), 2 deletions(-)

diff --git a/extra/lisp/parser/parser-tests.factor b/extra/lisp/parser/parser-tests.factor
index 68bda1780a..911a8d3440 100644
--- a/extra/lisp/parser/parser-tests.factor
+++ b/extra/lisp/parser/parser-tests.factor
@@ -73,4 +73,8 @@ IN: lisp.parser.tests
     
 { { T{ lisp-symbol f "quote" } T{ lisp-symbol f "foo" } } } [
     "'foo" lisp-expr cons>seq
+] unit-test
+    
+{ { 1 2 { T{ lisp-symbol { name "quote" } } { 3 4 } } 5 } } [
+    "(1 2 '(3 4) 5)" lisp-expr cons>seq
 ] unit-test
\ No newline at end of file
diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor
index 55672af13d..50f58692d5 100644
--- a/extra/lisp/parser/parser.factor
+++ b/extra/lisp/parser/parser.factor
@@ -35,7 +35,7 @@ atom         = number
               | identifier
               | string
 s-expression = LPAREN (list-item)* RPAREN                => [[ second seq>cons ]]
-list-item    = _ ( atom | s-expression ) _               => [[ second ]]
+list-item    = _ ( atom | s-expression | quoted ) _      => [[ second ]]
 quoted       = squote list-item                          => [[ second nil cons "quote" <lisp-symbol> swap cons ]]
-expr         = list-item | quoted
+expr         = list-item
 ;EBNF
\ No newline at end of file

From d2d3e1e4f24d95d9f8bf6f0fd2e68708a9ed4656 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sun, 14 Sep 2008 20:24:06 -0400
Subject: [PATCH 153/318] Adding more tests to extra/lisp

---
 extra/lisp/lisp-tests.factor | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor
index 48f6419d30..6e586bc657 100644
--- a/extra/lisp/lisp-tests.factor
+++ b/extra/lisp/lisp-tests.factor
@@ -84,4 +84,12 @@ IN: lisp.test
         <LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
     ] unit-test
     
+    {  { 3 3 4 } } [
+        <LISP (setq foo (lambda (x y &rest z)
+                            (cons (+ x y) z)))
+
+              (foo 1 2 3 4)
+        LISP> cons>seq
+    ] unit-test
+    
 ] with-interactive-vocabs

From 0e18200b16ea8c1bb1aa234cef3aeb8a5018b193 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sun, 14 Sep 2008 21:28:36 -0400
Subject: [PATCH 154/318] Fixing defun, adding test for it

---
 extra/lisp/lisp-tests.factor |  5 ++---
 extra/lisp/lisp.factor       | 21 ++++++++-------------
 2 files changed, 10 insertions(+), 16 deletions(-)

diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor
index 6e586bc657..9ddd31cde0 100644
--- a/extra/lisp/lisp-tests.factor
+++ b/extra/lisp/lisp-tests.factor
@@ -85,9 +85,8 @@ IN: lisp.test
     ] unit-test
     
     {  { 3 3 4 } } [
-        <LISP (setq foo (lambda (x y &rest z)
-                            (cons (+ x y) z)))
-
+        <LISP (defun foo (x y &rest z)
+                  (cons (+ x y) z))
               (foo 1 2 3 4)
         LISP> cons>seq
     ] unit-test
diff --git a/extra/lisp/lisp.factor b/extra/lisp/lisp.factor
index e60529caab..4a933501e8 100644
--- a/extra/lisp/lisp.factor
+++ b/extra/lisp/lisp.factor
@@ -64,14 +64,9 @@ PRIVATE>
 : macro-expand ( cons -- quot )
     uncons [ list>seq >quotation ] [ lookup-macro ] bi* call call ;
 
-<PRIVATE
-: (expand-macros) ( cons -- cons )
-    [ dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ] lmap ;
-PRIVATE>
-
 : expand-macros ( cons -- cons )
-    dup list? [ (expand-macros) dup car lisp-macro? [ macro-expand ] when ] when ;
-
+    dup list? [ [ expand-macros ] lmap dup car lisp-macro? [ macro-expand expand-macros ] when ] when ;
+    
 : convert-begin ( cons -- quot )
     cdr [ convert-form ] [ ] lmap-as [ 1 tail* ] [ but-last ] bi
     [ '[ { } _ with-datastack drop ] ] map prepend '[ _ [ call ] each ] ;
@@ -169,15 +164,15 @@ M: no-such-var summary drop "No such variable" ;
 
    "set" "lisp" "define-lisp-var" define-primitive
     
-   "(lambda (&rest xs) xs)" lisp-string>factor first "list" lisp-define
-   "(defmacro setq (var val) (list (quote set) (list (quote quote) var) val))" lisp-eval
+   "(set 'list (lambda (&rest xs) xs))" lisp-eval
+   "(defmacro setq (var val) (list 'set (list 'quote var) val))" lisp-eval
     
    <" (defmacro defun (name vars &rest body)
-        (list (quote setq) name (list (quote lambda) vars body))) "> lisp-eval
+        (list 'setq name (cons 'lambda (cons vars body)))) "> lisp-eval
     
-   "(defmacro if (pred tr fl) (list (quote cond) (list pred tr) (list (quote #t) fl)))" lisp-eval
+   "(defmacro if (pred tr fl) (list 'cond (list pred tr) (list (quote #t) fl)))" lisp-eval
    ;
 
 : <LISP 
-    "LISP>" parse-multiline-string define-lisp-builtins
-    lisp-string>factor parsed \ call parsed ; parsing
+    "LISP>" parse-multiline-string "(begin " prepend ")" append define-lisp-builtins
+    lisp-string>factor parsed \ call parsed ; parsing
\ No newline at end of file

From b250a62f8711c246e88c49db16941be664abf732 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 16 Sep 2008 19:40:30 -0400
Subject: [PATCH 155/318] Fixing spacing

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

diff --git a/extra/lisp/lisp-tests.factor b/extra/lisp/lisp-tests.factor
index 9ddd31cde0..5f849c4416 100644
--- a/extra/lisp/lisp-tests.factor
+++ b/extra/lisp/lisp-tests.factor
@@ -84,7 +84,7 @@ IN: lisp.test
         <LISP ((lambda (x y) (if x (+ 1 y) (+ 2 y))) #t 3) LISP>
     ] unit-test
     
-    {  { 3 3 4 } } [
+    { { 3 3 4 } } [
         <LISP (defun foo (x y &rest z)
                   (cons (+ x y) z))
               (foo 1 2 3 4)

From 27d216cf1e6d65c79c174cc766cc00d9b6208dcf Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Wed, 22 Oct 2008 23:57:14 -0400
Subject: [PATCH 156/318] Making work director symlink to ~/Programming/factor

---
 work/README.txt | 1 -
 1 file changed, 1 deletion(-)
 delete mode 100644 work/README.txt

diff --git a/work/README.txt b/work/README.txt
deleted file mode 100644
index fd1af07408..0000000000
--- a/work/README.txt
+++ /dev/null
@@ -1 +0,0 @@
-The 'work' directory is for your own personal vocabularies.

From 560399a2b60c96ac5a8d4330c1b4174480d44ded Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 30 Oct 2008 20:28:55 -0400
Subject: [PATCH 157/318] Adding some more documentation to extra/lisp

---
 extra/lisp/lisp-docs.factor | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/extra/lisp/lisp-docs.factor b/extra/lisp/lisp-docs.factor
index 149f22864e..a4b0372f16 100644
--- a/extra/lisp/lisp-docs.factor
+++ b/extra/lisp/lisp-docs.factor
@@ -1,5 +1,12 @@
 IN: lisp
 USING: help.markup help.syntax ;
+HELP: <LISP
+{ $description "parsing word which converts the lisp code between <LISP and LISP> into factor quotations and calls it" }
+{ $ see-also lisp-string>factor }
+
+HELP: lisp-string>factor
+{ $values { "str"  "a string of lisp code" } { "quot" "the quotation the lisp compiles into" } }
+{ $description "Turns a string of lisp into a factor quotation" }
 
 ARTICLE: "lisp" "Lisp in Factor"
 "This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl

From f5db48e3b7fbdd5ae5d3148bc2e3541e3ff40e87 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Mon, 3 Nov 2008 10:24:13 -0500
Subject: [PATCH 158/318] Fixing typo in lisp-docs

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

diff --git a/extra/lisp/lisp-docs.factor b/extra/lisp/lisp-docs.factor
index a4b0372f16..cdeafe3e02 100644
--- a/extra/lisp/lisp-docs.factor
+++ b/extra/lisp/lisp-docs.factor
@@ -2,7 +2,7 @@ IN: lisp
 USING: help.markup help.syntax ;
 HELP: <LISP
 { $description "parsing word which converts the lisp code between <LISP and LISP> into factor quotations and calls it" }
-{ $ see-also lisp-string>factor }
+{ $see-also lisp-string>factor }
 
 HELP: lisp-string>factor
 { $values { "str"  "a string of lisp code" } { "quot" "the quotation the lisp compiles into" } }

From f8da0cd23fd30db2dbd14ed027f3deac02113bf7 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Wed, 5 Nov 2008 09:19:59 -0500
Subject: [PATCH 159/318] Starting work on advice vocab

---
 extra/advice/advice-docs.factor  |  0
 extra/advice/advice-tests.factor |  5 +++++
 extra/advice/advice.factor       | 29 +++++++++++++++++++++++++++++
 extra/advice/authors.txt         |  1 +
 extra/advice/tags.txt            |  3 +++
 5 files changed, 38 insertions(+)
 create mode 100644 extra/advice/advice-docs.factor
 create mode 100644 extra/advice/advice-tests.factor
 create mode 100644 extra/advice/advice.factor
 create mode 100644 extra/advice/authors.txt
 create mode 100644 extra/advice/tags.txt

diff --git a/extra/advice/advice-docs.factor b/extra/advice/advice-docs.factor
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor
new file mode 100644
index 0000000000..0d71ef2220
--- /dev/null
+++ b/extra/advice/advice-tests.factor
@@ -0,0 +1,5 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences tools.tests advice ;
+IN: advice.tests
+
diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor
new file mode 100644
index 0000000000..12874be1f1
--- /dev/null
+++ b/extra/advice/advice.factor
@@ -0,0 +1,29 @@
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences symbols fry words assocs tools.annotations ;
+IN: advice
+
+SYMBOLS: before after around ;
+
+: get-advice ( word type -- seq )
+    word-prop values ;
+
+: call-before ( word --  )
+    before get-advice [ call ] each ;
+
+: call-after ( word --  )
+    after get-advice [ call ] each ;
+    
+: advise-before ( quot name word --  )
+    before word-prop set-at ;
+    
+: advise-after ( quot name word --  )
+    after word-prop set-at ;
+
+: remove-advice ( name word loc --  )
+    word-prop delete-at ;
+    
+: make-advised ( word -- )
+    [ dup [ over '[ _ call-before @  _ call-after ] ] annotate ]
+    [ { before after around } [ H{ } clone swap set-word-prop ] with each ] bi ;
+    
\ No newline at end of file
diff --git a/extra/advice/authors.txt b/extra/advice/authors.txt
new file mode 100644
index 0000000000..4b7af4aac0
--- /dev/null
+++ b/extra/advice/authors.txt
@@ -0,0 +1 @@
+James Cash
diff --git a/extra/advice/tags.txt b/extra/advice/tags.txt
new file mode 100644
index 0000000000..a87b65d938
--- /dev/null
+++ b/extra/advice/tags.txt
@@ -0,0 +1,3 @@
+advice
+aspect
+annotations

From 2904f35f12107dd476e924f71f2eae3658f6555a Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Wed, 5 Nov 2008 23:49:21 -0500
Subject: [PATCH 160/318] Adding summary for extra/advice

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

diff --git a/extra/advice/summary.txt b/extra/advice/summary.txt
new file mode 100644
index 0000000000..a6f9c06526
--- /dev/null
+++ b/extra/advice/summary.txt
@@ -0,0 +1 @@
+Implmentation of advice/aspects

From 585afbf24e329ff7e30b378c10a381cde49f2f6a Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Wed, 5 Nov 2008 23:49:57 -0500
Subject: [PATCH 161/318] Adding tests for advice

---
 extra/advice/advice-tests.factor | 19 ++++++++++++++++++-
 1 file changed, 18 insertions(+), 1 deletion(-)

diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor
index 0d71ef2220..868f81cbe8 100644
--- a/extra/advice/advice-tests.factor
+++ b/extra/advice/advice-tests.factor
@@ -1,5 +1,22 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences tools.tests advice ;
+USING: kernel sequences tools.test advice parser ;
 IN: advice.tests
 
+[
+: foo "foo" ; 
+\ foo make-advised
+ 
+ { "bar" "foo" } [
+     [ "bar" ] "barify" \ foo advise-before
+     foo ] unit-test
+ 
+ { "bar" "foo" "baz" } [
+      [ "baz" ] "bazify" \ foo advise-after
+      foo ] unit-test
+ 
+ { "foo" "baz" } [
+     "barify" \ foo before remove-advice
+     foo ] unit-test
+ 
+ ] with-interactive-vocabs
\ No newline at end of file

From 0f9ccaa35275c005fcb101612ab93e18a4693809 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Wed, 5 Nov 2008 23:50:33 -0500
Subject: [PATCH 162/318] Working on implementation of 'around' advice

---
 extra/advice/advice.factor | 31 +++++++++++++++++++++++--------
 1 file changed, 23 insertions(+), 8 deletions(-)

diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor
index 12874be1f1..3fb6941854 100644
--- a/extra/advice/advice.factor
+++ b/extra/advice/advice.factor
@@ -1,10 +1,23 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences symbols fry words assocs tools.annotations ;
+USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
 IN: advice
 
 SYMBOLS: before after around ;
 
+: advise ( quot name word loc --  )
+    word-prop set-at ;
+    
+: advise-before ( quot name word --  )
+    before advise ;
+    
+: advise-after ( quot name word --  )
+    after advise ;
+
+: advise-around ( quot name word --  )
+    [ \ coterminate suffix cocreate ] 2dip
+    around advise ;
+
 : get-advice ( word type -- seq )
     word-prop values ;
 
@@ -13,17 +26,19 @@ SYMBOLS: before after around ;
 
 : call-after ( word --  )
     after get-advice [ call ] each ;
-    
-: advise-before ( quot name word --  )
-    before word-prop set-at ;
-    
-: advise-after ( quot name word --  )
-    after word-prop set-at ;
+
+: call-around ( main word --  )
+    around get-advice [ [ coresume ] each ] dip call
+    around get-advice reverse [ coresume ] each ;
 
 : remove-advice ( name word loc --  )
     word-prop delete-at ;
+
+: ad-do-it ( input -- result )
+    coyield ;
+    
     
 : make-advised ( word -- )
-    [ dup [ over '[ _ call-before @  _ call-after ] ] annotate ]
+    [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
     [ { before after around } [ H{ } clone swap set-word-prop ] with each ] bi ;
     
\ No newline at end of file

From 718b29798ab3bca25907f1febef57abb65cfb485 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 6 Nov 2008 00:08:39 -0500
Subject: [PATCH 163/318] Adding missing semicolon to lisp-docs.factor

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

diff --git a/extra/lisp/lisp-docs.factor b/extra/lisp/lisp-docs.factor
index cdeafe3e02..c970a1e0b7 100644
--- a/extra/lisp/lisp-docs.factor
+++ b/extra/lisp/lisp-docs.factor
@@ -2,11 +2,11 @@ IN: lisp
 USING: help.markup help.syntax ;
 HELP: <LISP
 { $description "parsing word which converts the lisp code between <LISP and LISP> into factor quotations and calls it" }
-{ $see-also lisp-string>factor }
+{ $see-also lisp-string>factor } ;
 
 HELP: lisp-string>factor
 { $values { "str"  "a string of lisp code" } { "quot" "the quotation the lisp compiles into" } }
-{ $description "Turns a string of lisp into a factor quotation" }
+{ $description "Turns a string of lisp into a factor quotation" } ;
 
 ARTICLE: "lisp" "Lisp in Factor"
 "This is a simple implementation of a Lisp dialect, which somewhat resembles Scheme." $nl

From d2224ec9353d25a6c596e4c8afce68de4a9c6bd3 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 6 Nov 2008 00:16:58 -0500
Subject: [PATCH 164/318] Adding documentation for advice

---
 extra/advice/advice-docs.factor | 22 ++++++++++++++++++++++
 1 file changed, 22 insertions(+)

diff --git a/extra/advice/advice-docs.factor b/extra/advice/advice-docs.factor
index e69de29bb2..2b33378b99 100644
--- a/extra/advice/advice-docs.factor
+++ b/extra/advice/advice-docs.factor
@@ -0,0 +1,22 @@
+IN: advice
+USING: help.markup help.syntax tools.annotations words ;
+
+HELP: make-advised
+{ $values { "word" "a word to annotate in preparation of advising" } }
+{ $description "Prepares a word for being advised.  This is done by: "
+    { $list
+        { "Annotating it to call the appropriate words before, around, and after the original body " }
+        { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
+        { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
+    }
+}
+{ $see-also advised? annotate } ;
+
+HELP: advised?
+{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet word } " is advised" } }
+{ $description "Determines whether or not the given word has any advice on it." } ;
+
+ARTICLE: "advice" "Advice"
+"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
+
+ABOUT: "advice"
\ No newline at end of file

From d530ec6bd5c2593b84c0b1fa60efd4657e96fdc1 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 6 Nov 2008 00:20:15 -0500
Subject: [PATCH 165/318] More work on around-advice

---
 extra/advice/advice.factor | 13 ++++++++-----
 1 file changed, 8 insertions(+), 5 deletions(-)

diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor
index 3fb6941854..a71b9590f1 100644
--- a/extra/advice/advice.factor
+++ b/extra/advice/advice.factor
@@ -3,7 +3,7 @@
 USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
 IN: advice
 
-SYMBOLS: before after around ;
+SYMBOLS: before after around advised ;
 
 : advise ( quot name word loc --  )
     word-prop set-at ;
@@ -28,17 +28,20 @@ SYMBOLS: before after around ;
     after get-advice [ call ] each ;
 
 : call-around ( main word --  )
-    around get-advice [ [ coresume ] each ] dip call
-    around get-advice reverse [ coresume ] each ;
+    around get-advice tuck 
+    [ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
 
 : remove-advice ( name word loc --  )
     word-prop delete-at ;
 
 : ad-do-it ( input -- result )
     coyield ;
-    
+
+: advised? ( word -- ? )
+    advised word-prop ;
     
 : make-advised ( word -- )
     [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
-    [ { before after around } [ H{ } clone swap set-word-prop ] with each ] bi ;
+    [ { before after around } [ H{ } clone swap set-word-prop ] with each ] 
+    [ t advised set-word-prop ] tri ;
     
\ No newline at end of file

From 894d9a67c9696ef3fd045de1340e14f02b481538 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 6 Nov 2008 00:44:11 -0500
Subject: [PATCH 166/318] Naive around-advice working

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

diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor
index a71b9590f1..6a7d46f935 100644
--- a/extra/advice/advice.factor
+++ b/extra/advice/advice.factor
@@ -5,8 +5,10 @@ IN: advice
 
 SYMBOLS: before after around advised ;
 
+<PRIVATE
 : advise ( quot name word loc --  )
     word-prop set-at ;
+PRIVATE>
     
 : advise-before ( quot name word --  )
     before advise ;
@@ -15,7 +17,7 @@ SYMBOLS: before after around advised ;
     after advise ;
 
 : advise-around ( quot name word --  )
-    [ \ coterminate suffix cocreate ] 2dip
+    [ \ coterminate suffix ] 2dip
     around advise ;
 
 : get-advice ( word type -- seq )
@@ -28,7 +30,7 @@ SYMBOLS: before after around advised ;
     after get-advice [ call ] each ;
 
 : call-around ( main word --  )
-    around get-advice tuck 
+    around get-advice [ cocreate ] map tuck 
     [ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
 
 : remove-advice ( name word loc --  )

From 6035bb31308b8997dece7ac1002c3be1c3bc91d0 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 6 Nov 2008 00:44:25 -0500
Subject: [PATCH 167/318] Tests of around-advice

---
 extra/advice/advice-tests.factor | 28 +++++++++++++++++++++++-----
 1 file changed, 23 insertions(+), 5 deletions(-)

diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor
index 868f81cbe8..17b60c8fb1 100644
--- a/extra/advice/advice-tests.factor
+++ b/extra/advice/advice-tests.factor
@@ -1,22 +1,40 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences tools.test advice parser ;
+USING: kernel sequences math tools.test advice parser namespaces ;
 IN: advice.tests
 
 [
 : foo "foo" ; 
 \ foo make-advised
  
- { "bar" "foo" } [
+  { "bar" "foo" } [
      [ "bar" ] "barify" \ foo advise-before
      foo ] unit-test
  
- { "bar" "foo" "baz" } [
+  { "bar" "foo" "baz" } [
       [ "baz" ] "bazify" \ foo advise-after
       foo ] unit-test
  
- { "foo" "baz" } [
+  { "foo" "baz" } [
      "barify" \ foo before remove-advice
      foo ] unit-test
  
- ] with-interactive-vocabs
\ No newline at end of file
+: bar ( a -- b ) 1+ ;
+\ bar make-advised
+
+  { 11 } [
+     [ 2 * ] "double" \ bar advise-before
+     5 bar
+  ] unit-test 
+
+  { 11/3 } [
+      [ 3 / ] "third" \ bar advise-after
+      5 bar
+  ] unit-test
+
+  { -2 } [
+      [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+      5 bar
+  ] unit-test
+ 
+ ] with-scope
\ No newline at end of file

From be798dd5e9229e20e84535f46b0b58fb30f65b2a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 00:01:50 -0600
Subject: [PATCH 168/318] We need to internalize tuple layouts in bootstrap,
 but since they're arrays we have to use a predicate class to detect them

---
 basis/bootstrap/image/image.factor | 13 +++++++++++++
 1 file changed, 13 insertions(+)

diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index fdc8451173..80571d20b1 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -378,6 +378,19 @@ M: array '
     [ ' ] map array type-number object tag-number
     [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 
+! This is a hack. We need to detect arrays which are tuple
+! layout arrays so that they can be internalized, but making
+! them a built-in type is not worth it.
+PREDICATE: tuple-layout-array < array
+    dup length 5 >= [
+        [ first tuple-class? ]
+        [ second fixnum? ]
+        [ third fixnum? ]
+        tri and and
+    ] [ drop f ] if ;
+
+M: tuple-layout-array ' [ call-next-method ] cache-object ;
+
 ! Quotations
 
 M: quotation '

From aac256324fad3c63b06fbf8b912d5449b0365af2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 00:02:10 -0600
Subject: [PATCH 169/318] lo-tag-dispatch-engine now sorts tags, this ensures
 that >fixnum compiles more efficiently

---
 core/generic/standard/engines/tag/tag.factor | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index 2043c99741..c65726260c 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -3,7 +3,7 @@
 USING: classes.private generic.standard.engines namespaces make
 arrays assocs sequences.private quotations kernel.private
 math slots.private math.private kernel accessors words
-layouts ;
+layouts sorting sequences ;
 IN: generic.standard.engines.tag
 
 TUPLE: lo-tag-dispatch-engine methods ;
@@ -23,9 +23,11 @@ C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
     ] if ;
 
 M: lo-tag-dispatch-engine engine>quot
-    methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
+    methods>> engines>quots*
+    [ >r lo-tag-number r> ] assoc-map
     [
         picker % [ tag ] % [
+            ! >alist sort-keys reverse
             linear-dispatch-quot
         ] [
             num-tags get direct-dispatch-quot

From bfd119e3b51b0a0f588161304fd331550c892eca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 00:02:44 -0600
Subject: [PATCH 170/318] I/O ricing: various hints added so that UTF8 and
 ASCII fastpaths compile with less dispatch. 25% improvement on
 reverse-complement

---
 .../tree/propagation/inlining/inlining.factor       |  2 +-
 basis/hints/hints.factor                            |  4 +++-
 basis/io/buffers/buffers.factor                     | 13 +++++--------
 basis/io/encodings/ascii/ascii.factor               |  2 +-
 basis/io/ports/ports.factor                         |  4 ++--
 core/io/encodings/encodings.factor                  |  4 ++--
 6 files changed, 14 insertions(+), 15 deletions(-)

diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 130b94cf6b..8397a5fdbb 100644
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -131,7 +131,7 @@ DEFER: (flat-length)
     ] bi* + + + + + ;
 
 : should-inline? ( #call word -- ? )
-    inlining-rank 5 >= ;
+    dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
 
 SYMBOL: history
 
diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index a10588d730..06ca209cae 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -64,10 +64,12 @@ IN: hints
 { first first2 first3 first4 }
 [ { array } "specializer" set-word-prop ] each
 
-{ peek pop* pop push } [
+{ peek pop* pop } [
     { vector } "specializer" set-word-prop
 ] each
 
+\ push { { vector } { sbuf } } "specializer" set-word-prop
+
 \ push-all
 { { string sbuf } { array vector } { byte-array byte-vector } }
 "specializer" set-word-prop
diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor
index e6a0070ee0..4df081b17d 100644
--- a/basis/io/buffers/buffers.factor
+++ b/basis/io/buffers/buffers.factor
@@ -36,9 +36,7 @@ M: buffer dispose* ptr>> free ;
     [ ptr>> ] [ pos>> ] bi alien-unsigned-1 ; inline
 
 : buffer-pop ( buffer -- byte )
-    [ buffer-peek ] [ 1 swap buffer-consume ] bi ;
-
-HINTS: buffer-pop buffer ;
+    [ buffer-peek ] [ 1 swap buffer-consume ] bi ; inline
 
 : buffer-length ( buffer -- n )
     [ fill>> ] [ pos>> ] bi - ; inline
@@ -69,14 +67,13 @@ HINTS: n>buffer fixnum buffer ;
 HINTS: >buffer byte-array buffer ;
 
 : byte>buffer ( byte buffer -- )
+    [ >fixnum ] dip
     [ [ ptr>> ] [ fill>> ] bi set-alien-unsigned-1 ]
     [ 1 swap n>buffer ]
-    bi ;
-
-HINTS: byte>buffer fixnum buffer ;
+    bi ; inline
 
 : search-buffer-until ( pos fill ptr separators -- n )
-    [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ;
+    [ [ swap alien-unsigned-1 ] dip memq? ] 2curry find-from drop ; inline
 
 : finish-buffer-until ( buffer n -- byte-array separator )
     [
@@ -86,7 +83,7 @@ HINTS: byte>buffer fixnum buffer ;
     ] [
         [ buffer-length ] keep
         buffer-read f
-    ] if* ;
+    ] if* ; inline
 
 : buffer-until ( separators buffer -- byte-array separator )
     swap [ { [ ] [ pos>> ] [ fill>> ] [ ptr>> ] } cleave ] dip
diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor
index 08dc8d07d9..0803ba3871 100644
--- a/basis/io/encodings/ascii/ascii.factor
+++ b/basis/io/encodings/ascii/ascii.factor
@@ -9,7 +9,7 @@ IN: io.encodings.ascii
 
 : decode-if< ( stream encoding max -- character )
     nip swap stream-read1 dup
-    [ tuck > [ drop replacement-char ] unless ] [ 2drop f ] if ; inline
+    [ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline
 PRIVATE>
 
 SINGLETON: ascii
diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor
index 909b2dcf3b..6ee982fcda 100644
--- a/basis/io/ports/ports.factor
+++ b/basis/io/ports/ports.factor
@@ -100,7 +100,7 @@ TUPLE: output-port < buffered-port ;
 
 : wait-to-write ( len port -- )
     tuck buffer>> buffer-capacity <=
-    [ drop ] [ stream-flush ] if ;
+    [ drop ] [ stream-flush ] if ; inline
 
 M: output-port stream-write1
     dup check-disposed
@@ -161,4 +161,4 @@ HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii }
 
 HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
 
-HINTS: decoder-write { string output-port utf8 } { string output-port ascii } ;
+HINTS: encoder-write { string output-port utf8 } { string output-port ascii } ;
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 36cec298bd..48a428d36e 100644
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -124,11 +124,11 @@ M: object <encoder> encoder boa ;
 M: encoder stream-write1
     >encoder< encode-char ;
 
-: decoder-write ( string stream encoding -- )
+: encoder-write ( string stream encoding -- )
     [ encode-char ] 2curry each ;
 
 M: encoder stream-write
-    >encoder< decoder-write ;
+    >encoder< encoder-write ;
 
 M: encoder dispose stream>> dispose ;
 

From 636c344eb0615ca3b1a52c99083712d729802c2f Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 6 Nov 2008 01:20:08 -0500
Subject: [PATCH 171/318] Cleanup of math.analysis

---
 extra/math/analysis/analysis.factor | 34 ++++++++++++++---------------
 1 file changed, 17 insertions(+), 17 deletions(-)

diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor
index 7da1c96b61..b5f6a547ba 100755
--- a/extra/math/analysis/analysis.factor
+++ b/extra/math/analysis/analysis.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2008 Doug Coleman, Slava Pestov.
+! Copyright (C) 2008 Doug Coleman, Slava Pestov, Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.constants math.functions math.intervals
-math.vectors namespaces sequences combinators.short-circuit ;
+USING: combinators.short-circuit kernel math math.constants math.functions
+    math.vectors sequences ;
 IN: math.analysis
 
 <PRIVATE
@@ -14,7 +14,7 @@ IN: math.analysis
 : gamma-p6
     {
         2.50662827563479526904 225.525584619175212544 -268.295973841304927459
-        80.9030806934622512966 -5.00757863970517583837 0.0114684895434781459556 
+        80.9030806934622512966 -5.00757863970517583837 0.0114684895434781459556
     } ; inline
 
 : gamma-z ( x n -- seq )
@@ -22,16 +22,16 @@ IN: math.analysis
 
 : (gamma-lanczos6) ( x -- log[gamma[x+1]] )
     #! log(gamma(x+1)
-    [ 0.5 + dup gamma-g6 + dup [ log * ] dip - ]
+    [ 0.5 + dup gamma-g6 + [ log * ] keep - ]
     [ 6 gamma-z gamma-p6 v. log ] bi + ;
 
 : gamma-lanczos6 ( x -- gamma[x] )
     #! gamma(x) = gamma(x+1) / x
-    dup (gamma-lanczos6) exp swap / ;
+    [ (gamma-lanczos6) exp ] keep / ;
 
 : gammaln-lanczos6 ( x -- gammaln[x] )
     #! log(gamma(x)) = log(gamma(x+1)) - log(x)
-    dup (gamma-lanczos6) swap log - ;
+    [ (gamma-lanczos6) ] keep log - ;
 
 : gamma-neg ( gamma[abs[x]] x -- gamma[x] )
     dup pi * sin * * pi neg swap / ; inline
@@ -42,22 +42,22 @@ PRIVATE>
     #! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
     #! gamma(n+1) = n! for n > 0
     dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
-            drop 1./0.
-        ] [
-            dup abs gamma-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if
+        drop 1./0.
+    ] [
+        [ abs gamma-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
     ] if ;
 
 : gammaln ( x -- gamma[x] )
     #! gammaln(x) is an alternative when gamma(x)'s range
     #! varies too widely
     dup 0 < [
-            drop 1./0.
-        ] [
-            dup abs gammaln-lanczos6 swap dup 0 > [ drop ] [ gamma-neg ] if
+        drop 1./0.
+    ] [
+        [ abs gammaln-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
     ] if ;
 
 : nth-root ( n x -- y )
-    [ recip ] dip swap ^ ;
+    swap recip ^ ;
 
 ! Forth Scientific Library Algorithm #1
 !
@@ -116,6 +116,6 @@ PRIVATE>
 
 : stirling-fact ( n -- fact )
     [ pi 2 * * sqrt ]
-    [ dup e / swap ^ ]
-    [ 12 * recip 1 + ]
-    tri * * ;
+    [ [ e / ] keep ^ ]
+    [ 12 * recip 1+ ] tri * * ;
+

From 4d1d9b2087b9fb94f8db755f3b1cdf0325dfee55 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 6 Nov 2008 01:41:24 -0500
Subject: [PATCH 172/318] Fix short circuit usage in Project Euler solutions

---
 extra/project-euler/014/014.factor |  2 +-
 extra/project-euler/021/021.factor |  2 +-
 extra/project-euler/036/036.factor |  3 +--
 extra/project-euler/043/043.factor | 16 ++++++++--------
 extra/project-euler/052/052.factor |  2 +-
 5 files changed, 12 insertions(+), 13 deletions(-)

diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor
index 93ed0c7754..3b812cf242 100644
--- a/extra/project-euler/014/014.factor
+++ b/extra/project-euler/014/014.factor
@@ -58,7 +58,7 @@ PRIVATE>
 <PRIVATE
 
 : worth-calculating? ( n -- ? )
-    { [ dup 1- 3 mod zero? ] [ dup 1- 3 / even? ] } 0&& nip ;
+    1- 3 { [ mod zero? ] [ / even? ] } 2&& ;
 
 PRIVATE>
 
diff --git a/extra/project-euler/021/021.factor b/extra/project-euler/021/021.factor
index 2e2f6a6453..55060a7c71 100644
--- a/extra/project-euler/021/021.factor
+++ b/extra/project-euler/021/021.factor
@@ -27,7 +27,7 @@ IN: project-euler.021
 
 : amicable? ( n -- ? )
     dup sum-proper-divisors
-    { [ 2dup = not ] [ 2dup sum-proper-divisors = ] } 0&& 2nip ;
+    { [ = not ] [ sum-proper-divisors = ] } 2&& ;
 
 : euler021 ( -- answer )
     10000 [1,b] [ dup amicable? [ drop 0 ] unless ] sigma ;
diff --git a/extra/project-euler/036/036.factor b/extra/project-euler/036/036.factor
index 02d9372a8b..f5afeceb21 100644
--- a/extra/project-euler/036/036.factor
+++ b/extra/project-euler/036/036.factor
@@ -26,8 +26,7 @@ IN: project-euler.036
 <PRIVATE
 
 : both-bases? ( n -- ? )
-    { [ dup palindrome? ]
-      [ dup >bin dup reverse = ] } 0&& nip ;
+    { [ palindrome? ] [ >bin dup reverse = ] } 1&& ;
 
 PRIVATE>
 
diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index 28dc0b8bd6..268a6becfb 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -40,14 +40,14 @@ IN: project-euler.043
 
 : interesting? ( seq -- ? )
     {
-        [ 17 8 pick subseq-divisible? ]
-        [ 13 7 pick subseq-divisible? ]
-        [ 11 6 pick subseq-divisible? ]
-        [ 7 5 pick subseq-divisible? ]
-        [ 5 4 pick subseq-divisible? ]
-        [ 3 3 pick subseq-divisible? ]
-        [ 2 2 pick subseq-divisible? ]
-    } 0&& nip ;
+        [ 17 8 rot subseq-divisible? ]
+        [ 13 7 rot subseq-divisible? ]
+        [ 11 6 rot subseq-divisible? ]
+        [ 7  5 rot subseq-divisible? ]
+        [ 5  4 rot subseq-divisible? ]
+        [ 3  3 rot subseq-divisible? ]
+        [ 2  2 rot subseq-divisible? ]
+    } 1&& ;
 
 PRIVATE>
 
diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor
index cfbb718200..5362a6e9b0 100644
--- a/extra/project-euler/052/052.factor
+++ b/extra/project-euler/052/052.factor
@@ -30,7 +30,7 @@ IN: project-euler.052
     [ number>digits natural-sort ] map all-equal? ;
 
 : candidate? ( n -- ? )
-    { [ dup odd? ] [ dup 3 mod zero? ] } 0&& nip ;
+    { [ odd? ] [ 3 mod zero? ] } 1&& ;
 
 : next-all-same ( x n -- n )
     dup candidate? [

From 9160e667a705ab8be4253ebbb3460b177e35167f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 01:10:56 -0600
Subject: [PATCH 173/318] Fix tuple>array and tuple reshaping

---
 core/classes/tuple/tuple-tests.factor | 6 ------
 core/classes/tuple/tuple.factor       | 6 +++---
 2 files changed, 3 insertions(+), 9 deletions(-)

diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index dc078f5ac3..8261e713a5 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -238,12 +238,6 @@ C: <laptop> laptop
 
 test-laptop-slot-values
 
-[ laptop ] [
-    "laptop" get 1 slot
-    dup echelon>> swap
-    superclasses>> nth
-] unit-test
-
 [ "TUPLE: laptop < computer battery ;" ] [
     [ \ laptop see ] with-string-writer string-lines second
 ] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index e9c560bd90..c2f93ead3e 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -59,7 +59,7 @@ PRIVATE>
 : tuple>array ( tuple -- array )
     prepare-tuple>array
     >r copy-tuple-slots r>
-    class>> prefix ;
+    first prefix ;
 
 : tuple-slots ( tuple -- seq )
     prepare-tuple>array drop copy-tuple-slots ;
@@ -177,13 +177,13 @@ ERROR: bad-superclass class ;
     [ first3 update-slot ] with map ;
 
 : permute-slots ( old-values layout -- new-values )
-    [ class>> all-slots ] [ outdated-tuples get at ] bi
+    [ first all-slots ] [ outdated-tuples get at ] bi
     compute-slot-permutation
     apply-slot-permutation ;
 
 : update-tuple ( tuple -- newtuple )
     [ tuple-slots ] [ layout-of ] bi
-    [ permute-slots ] [ class>> ] bi
+    [ permute-slots ] [ first ] bi
     slots>tuple ;
 
 : outdated-tuple? ( tuple assoc -- ? )

From 53cd75b06c3009fc795a563be234bb530e4dd7e9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 01:11:28 -0600
Subject: [PATCH 174/318] Add string-nth intrinsic

---
 basis/bootstrap/compiler/compiler.factor      | 10 ++++
 basis/compiler/cfg/def-use/def-use.factor     |  2 +
 basis/compiler/cfg/hats/hats.factor           |  1 +
 .../cfg/instructions/instructions.factor      |  3 ++
 .../compiler/cfg/intrinsics/intrinsics.factor |  3 ++
 .../cfg/intrinsics/slots/slots.factor         |  3 ++
 .../propagate/propagate.factor                |  4 ++
 basis/compiler/codegen/codegen.factor         |  8 +++
 basis/cpu/architecture/architecture.factor    |  2 +
 basis/cpu/x86/x86.factor                      | 50 +++++++++++++------
 10 files changed, 72 insertions(+), 14 deletions(-)

diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor
index cbd2f0f41e..dabdeea741 100644
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@@ -89,14 +89,24 @@ nl
     . malloc calloc free memcpy
 } compile-uncompiled
 
+"." write flush
+
 { build-tree } compile-uncompiled
 
+"." write flush
+
 { optimize-tree } compile-uncompiled
 
+"." write flush
+
 { optimize-cfg } compile-uncompiled
 
+"." write flush
+
 { (compile) } compile-uncompiled
 
+"." write flush
+
 vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 2cbd7e54cb..7553407e00 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -14,6 +14,7 @@ M: ##allot defs-vregs dst/tmp-vregs ;
 M: ##dispatch defs-vregs temp>> 1array ;
 M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
 M: ##set-slot defs-vregs temp>> 1array ;
+M: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
 M: insn defs-vregs drop f ;
 
 M: ##unary uses-vregs src>> 1array ;
@@ -24,6 +25,7 @@ M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
 M: ##slot-imm uses-vregs obj>> 1array ;
 M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
 M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
+M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
 M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: ##compare-imm-branch uses-vregs src1>> 1array ;
 M: ##dispatch uses-vregs src>> 1array ;
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index 1c6480048c..e6e05abbd5 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -22,6 +22,7 @@ IN: compiler.cfg.hats
 : ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
 : ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
 : ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
+: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; inline
 : ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
 : ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
 : ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 5ea74e97ec..c39f517671 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -71,6 +71,9 @@ INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
 INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
 INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
 
+! String element access
+INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
+
 ! Integer arithmetic
 INSN: ##add < ##commutative ;
 INSN: ##add-imm < ##commutative-imm ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 3fd54d2e07..ef1cde337a 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -14,6 +14,7 @@ QUALIFIED: arrays
 QUALIFIED: byte-arrays
 QUALIFIED: kernel.private
 QUALIFIED: slots.private
+QUALIFIED: strings.private
 QUALIFIED: classes.tuple.private
 QUALIFIED: math.private
 QUALIFIED: alien.accessors
@@ -38,6 +39,7 @@ IN: compiler.cfg.intrinsics
     kernel:eq?
     slots.private:slot
     slots.private:set-slot
+    strings.private:string-nth
     classes.tuple.private:<tuple-boa>
     arrays:<array>
     byte-arrays:<byte-array>
@@ -114,6 +116,7 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
         { \ slots.private:slot [ emit-slot ] }
         { \ slots.private:set-slot [ emit-set-slot ] }
+        { \ strings.private:string-nth [ drop emit-string-nth ] }
         { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
         { \ arrays:<array> [ emit-<array> ] }
         { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index cbc5d04c0b..22fb4e747b 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -51,3 +51,6 @@ IN: compiler.cfg.intrinsics.slots
         ] [ first class>> immediate class<= ] bi
         [ drop ] [ i i ##write-barrier ] if
     ] [ drop emit-primitive ] if ;
+
+: emit-string-nth ( -- )
+    2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;
diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
index d08f233995..a3c9725838 100644
--- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor
+++ b/basis/compiler/cfg/value-numbering/propagate/propagate.factor
@@ -36,6 +36,10 @@ M: ##set-slot propagate
     [ resolve ] change-obj
     [ resolve ] change-slot ;
 
+M: ##string-nth propagate
+    [ resolve ] change-obj
+    [ resolve ] change-index ;
+
 M: ##set-slot-imm propagate
     call-next-method
     [ resolve ] change-obj ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 0d36a88b45..cab86dcb54 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -123,6 +123,14 @@ M: ##set-slot generate-insn
 M: ##set-slot-imm generate-insn
     >set-slot< %set-slot-imm ;
 
+M: ##string-nth generate-insn
+    {
+        [ dst>> register ]
+        [ obj>> register ]
+        [ index>> register ]
+        [ temp>> register ]
+    } cleave %string-nth ;
+
 : dst/src ( insn -- dst src )
     [ dst>> register ] [ src>> register ] bi ; inline
 
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index c86f236976..e4fa9419f0 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -58,6 +58,8 @@ HOOK: %slot-imm cpu ( dst obj slot tag -- )
 HOOK: %set-slot cpu ( src obj slot tag temp -- )
 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/x86/x86.factor b/basis/cpu/x86/x86.factor
index 83c9ee7f0d..0e00ce60ee 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs alien alien.c-types arrays
+USING: accessors assocs alien alien.c-types arrays strings
 cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
 kernel kernel.private math memory namespaces make sequences
 words system layouts combinators math.order fry locals
@@ -278,27 +278,49 @@ M:: x86 %box-alien ( dst src temp -- )
 : small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
 
 : small-reg-that-isn't ( exclude -- reg' )
-    small-reg-4 small-regs [ eq? not ] with find nip ;
+    small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ;
 
 : with-save/restore ( reg quot -- )
     [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
 
-:: with-small-register ( dst src quot: ( dst src -- ) -- )
+:: with-small-register ( dst exclude quot: ( new-dst -- ) -- )
     #! If the destination register overlaps a small register, we
     #! call the quot with that. Otherwise, we find a small
-    #! register that is not equal to src, and call quot, saving
+    #! register that is not in exclude, and call quot, saving
     #! and restoring the small register.
-    dst small-reg-4 small-regs memq? [ dst src quot call ] [
-        src small-reg-that-isn't
-        [| new-dst |
-            new-dst src quot call
-            dst new-dst MOV
-        ] with-save/restore
+    dst small-reg-4 small-regs memq? [ dst quot call ] [
+        exclude small-reg-that-isn't
+        [ quot call ] with-save/restore
     ] if ; inline
 
-: %alien-integer-getter ( dst src size quot -- )
-    '[ [ dup _ small-reg dup ] [ [] ] bi* MOV @ ]
-    with-small-register ; inline
+: aux-offset 2 cells string tag-number - ; inline
+
+M:: x86 %string-nth ( dst src index temp -- )
+    "end" define-label
+    dst { src index temp } [| new-dst |
+        temp src index [+] LEA
+        new-dst 1 small-reg temp string-offset [+] MOV
+        new-dst new-dst 1 small-reg MOVZX
+        temp src aux-offset [+] MOV
+        temp \ f tag-number CMP
+        "end" get JE
+        new-dst temp XCHG
+        new-dst index ADD
+        new-dst index ADD
+        new-dst 2 small-reg new-dst byte-array-offset [+] MOV
+        new-dst new-dst 2 small-reg MOVZX
+        new-dst 8 SHL
+        new-dst temp OR
+        "end" resolve-label
+        dst new-dst ?MOV
+    ] with-small-register ;
+
+:: %alien-integer-getter ( dst src size quot -- )
+    dst { src } [| new-dst |
+        new-dst dup size small-reg dup src [] MOV
+        quot call
+        dst new-dst ?MOV
+    ] with-small-register ; inline
 
 : %alien-unsigned-getter ( dst src size -- )
     [ MOVZX ] %alien-integer-getter ; inline
@@ -320,7 +342,7 @@ M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
 M: x86 %alien-double [] MOVSD ;
 
 :: %alien-integer-setter ( ptr value size -- )
-    value ptr [| new-value ptr |
+    value { ptr } [| new-value |
         new-value value ?MOV
         ptr [] new-value size small-reg MOV
     ] with-small-register ; inline

From 5def7c5dea9fc62fe03bc1cb9490cde9eb16ec55 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 01:30:59 -0600
Subject: [PATCH 175/318] Don't load random number generator on bootstrap

---
 basis/bootstrap/random/random.factor             | 16 ----------------
 basis/bootstrap/stage2.factor                    |  2 +-
 basis/concurrency/mailboxes/mailboxes.factor     |  2 +-
 basis/concurrency/messaging/messaging.factor     |  4 ++--
 basis/help/handbook/handbook.factor              |  3 ---
 .../mersenne-twister/mersenne-twister.factor     |  7 +++++++
 basis/random/random.factor                       |  9 +++++++++
 basis/tools/deploy/backend/backend.factor        |  2 +-
 basis/tools/deploy/config/config-docs.factor     |  8 ++++----
 basis/tools/deploy/config/config.factor          |  4 ++--
 basis/tools/deploy/test/1/deploy.factor          |  1 -
 basis/tools/deploy/test/2/deploy.factor          |  1 -
 basis/tools/deploy/test/3/deploy.factor          |  1 -
 basis/tools/deploy/test/4/deploy.factor          |  1 -
 basis/tools/deploy/test/5/deploy.factor          |  1 -
 basis/tools/deploy/test/6/deploy.factor          |  1 -
 basis/ui/tools/deploy/deploy.factor              |  2 +-
 extra/bunny/deploy.factor                        |  1 -
 18 files changed, 28 insertions(+), 38 deletions(-)
 delete mode 100644 basis/bootstrap/random/random.factor

diff --git a/basis/bootstrap/random/random.factor b/basis/bootstrap/random/random.factor
deleted file mode 100644
index f6527cdda1..0000000000
--- a/basis/bootstrap/random/random.factor
+++ /dev/null
@@ -1,16 +0,0 @@
-USING: vocabs.loader sequences system
-random random.mersenne-twister combinators init
-namespaces random ;
-IN: bootstrap.random
-
-"random.mersenne-twister" require
-
-{
-    { [ os windows? ] [ "random.windows" require ] }
-    { [ os unix? ] [ "random.unix" require ] }
-} cond
-
-[
-    [ 32 random-bits ] with-system-random
-    <mersenne-twister> random-generator set-global
-] "bootstrap.random" add-init-hook
diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
index 58ea725d1e..3b6c04329c 100644
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@@ -50,7 +50,7 @@ SYMBOL: bootstrap-time
 
     default-image-name "output-image" set-global
 
-    "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
+    "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
     "" "exclude" set-global
 
     parse-command-line
diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor
index 6de546ca60..39b21e0943 100644
--- a/basis/concurrency/mailboxes/mailboxes.factor
+++ b/basis/concurrency/mailboxes/mailboxes.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: concurrency.mailboxes
 USING: dlists deques threads sequences continuations
-destructors namespaces random math quotations words kernel
+destructors namespaces math quotations words kernel
 arrays assocs init system concurrency.conditions accessors
 debugger debugger.threads locals ;
 
diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor
index 03d1304527..9aeb24ed72 100644
--- a/basis/concurrency/messaging/messaging.factor
+++ b/basis/concurrency/messaging/messaging.factor
@@ -4,7 +4,7 @@
 ! Concurrency library for Factor, based on Erlang/Termite style
 ! concurrency.
 USING: kernel threads concurrency.mailboxes continuations
-namespaces assocs random accessors summary ;
+namespaces assocs accessors summary ;
 IN: concurrency.messaging
 
 GENERIC: send ( message thread -- )
@@ -40,7 +40,7 @@ M: thread send ( message thread -- )
 TUPLE: synchronous data sender tag ;
 
 : <synchronous> ( data -- sync )
-    self 256 random-bits synchronous boa ;
+    self synchronous counter synchronous boa ;
 
 TUPLE: reply data tag ;
 
diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor
index 6aa19d43d5..5b60102e46 100644
--- a/basis/help/handbook/handbook.factor
+++ b/basis/help/handbook/handbook.factor
@@ -86,14 +86,11 @@ ARTICLE: "objects" "Objects"
 { $subsection "slots" }
 { $subsection "mirrors" } ;
 
-USE: random
-
 ARTICLE: "numbers" "Numbers"
 { $subsection "arithmetic" }
 { $subsection "math-constants" }
 { $subsection "math-functions" }
 { $subsection "number-strings" }
-{ $subsection "random" }
 "Number implementations:"
 { $subsection "integers" }
 { $subsection "rationals" }
diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor
index 0a730190c2..712883e4b8 100644
--- a/basis/random/mersenne-twister/mersenne-twister.factor
+++ b/basis/random/mersenne-twister/mersenne-twister.factor
@@ -68,3 +68,10 @@ M: mersenne-twister random-32* ( mt -- r )
     [ next-index ]
     [ seq>> nth mt-temper ]
     [ [ 1+ ] change-i drop ] tri ;
+
+USE: init
+
+[
+    [ 32 random-bits ] with-system-random
+    <mersenne-twister> random-generator set-global
+] "bootstrap.random" add-init-hook
diff --git a/basis/random/random.factor b/basis/random/random.factor
index 845f8e004f..a0b62cf7de 100755
--- a/basis/random/random.factor
+++ b/basis/random/random.factor
@@ -60,3 +60,12 @@ PRIVATE>
 
 : with-secure-random ( quot -- )
     secure-random-generator get swap with-random ; inline
+
+USE: vocabs.loader
+
+{
+    { [ os windows? ] [ "random.windows" require ] }
+    { [ os unix? ] [ "random.unix" require ] }
+} cond
+
+"random.mersenne-twister" require
diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor
index a0565c6bab..9431cb2c19 100644
--- a/basis/tools/deploy/backend/backend.factor
+++ b/basis/tools/deploy/backend/backend.factor
@@ -42,7 +42,7 @@ IN: tools.deploy.backend
         { "compiler" deploy-compiler? }
         { "threads"  deploy-threads?  }
         { "ui"       deploy-ui?       }
-        { "random"   deploy-random?   }
+        { "unicode"  deploy-unicode?  }
     } [ nip get ] assoc-filter keys
     native-io? [ "io" suffix ] when ;
 
diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor
index 2960cf452d..e8dcd2b90e 100644
--- a/basis/tools/deploy/config/config-docs.factor
+++ b/basis/tools/deploy/config/config-docs.factor
@@ -16,7 +16,7 @@ ARTICLE: "deploy-flags" "Deployment flags"
 "There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
 { $subsection deploy-math?     }
 { $subsection deploy-compiler? }
-{ $subsection deploy-random?   }
+{ $subsection deploy-unicode?   }
 { $subsection deploy-threads?  }
 { $subsection deploy-ui?       }
 "The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
@@ -73,10 +73,10 @@ HELP: deploy-compiler?
 $nl
 "On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
 
-HELP: deploy-random?
-{ $description "Deploy flag. If set, the random number generator protocol is included, together with two implementations: a native OS-specific random number generator, and the Mersenne Twister."
+HELP: deploy-unicode?
+{ $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included."
 $nl
-"On by default. If your program does not generate random numbers you can disable this to save some space." } ;
+"Off by default. If your program needs to use " { $link POSTPONE: CHAR: } " with named characters, enable this flag." } ;
 
 HELP: deploy-threads?
 { $description "Deploy flag. If set, thread support will be included in the final image."
diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor
index 0ebda89b15..c78e0a32ba 100644
--- a/basis/tools/deploy/config/config.factor
+++ b/basis/tools/deploy/config/config.factor
@@ -10,7 +10,7 @@ SYMBOL: deploy-name
 SYMBOL: deploy-ui?
 SYMBOL: deploy-compiler?
 SYMBOL: deploy-math?
-SYMBOL: deploy-random?
+SYMBOL: deploy-unicode?
 SYMBOL: deploy-threads?
 
 SYMBOL: deploy-io
@@ -58,7 +58,7 @@ SYMBOL: deploy-image
         { deploy-reflection         1 }
         { deploy-compiler?          t }
         { deploy-threads?           t }
-        { deploy-random?            t }
+        { deploy-unicode?           f }
         { deploy-math?              t }
         { deploy-word-props?        f }
         { deploy-word-defs?         f }
diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor
index 6846b3b53e..6d6a1c1bd3 100644
--- a/basis/tools/deploy/test/1/deploy.factor
+++ b/basis/tools/deploy/test/1/deploy.factor
@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-ui? f }
     { deploy-word-props? f }
diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor
index 4c34a77b66..1457769ce1 100644
--- a/basis/tools/deploy/test/2/deploy.factor
+++ b/basis/tools/deploy/test/2/deploy.factor
@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-ui? f }
     { deploy-word-props? f }
diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor
index 84347164b6..b38c5da676 100644
--- a/basis/tools/deploy/test/3/deploy.factor
+++ b/basis/tools/deploy/test/3/deploy.factor
@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-ui? f }
     { deploy-word-props? f }
diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor
index b1a6736bde..981bbcf982 100644
--- a/basis/tools/deploy/test/4/deploy.factor
+++ b/basis/tools/deploy/test/4/deploy.factor
@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-ui? f }
     { deploy-word-props? f }
diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor
index f5f8bc0352..22f5021497 100644
--- a/basis/tools/deploy/test/5/deploy.factor
+++ b/basis/tools/deploy/test/5/deploy.factor
@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-ui? f }
     { deploy-word-props? f }
diff --git a/basis/tools/deploy/test/6/deploy.factor b/basis/tools/deploy/test/6/deploy.factor
index e7d3764d39..c474fcdadf 100644
--- a/basis/tools/deploy/test/6/deploy.factor
+++ b/basis/tools/deploy/test/6/deploy.factor
@@ -5,7 +5,6 @@ H{
     { deploy-io 1 }
     { deploy-name "tools.deploy.test.6" }
     { deploy-math? t }
-    { deploy-random? f }
     { deploy-compiler? t }
     { deploy-ui? f }
     { deploy-c-types? f }
diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor
index e6180e9982..0ac89e122f 100644
--- a/basis/ui/tools/deploy/deploy.factor
+++ b/basis/ui/tools/deploy/deploy.factor
@@ -36,7 +36,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
     deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
     deploy-math? get "Rational and complex number support" <checkbox> add-gadget
     deploy-threads? get "Threading support" <checkbox> add-gadget
-    deploy-random? get "Random number generator support" <checkbox> add-gadget
+    deploy-unicode? get "Unicode character literal support" <checkbox> add-gadget
     deploy-word-props? get "Retain all word properties" <checkbox> add-gadget
     deploy-word-defs? get "Retain all word definitions" <checkbox> add-gadget
     deploy-c-types? get "Retain all C types" <checkbox> add-gadget ;
diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor
index 55ac991df1..0954c9ad41 100755
--- a/extra/bunny/deploy.factor
+++ b/extra/bunny/deploy.factor
@@ -4,7 +4,6 @@ H{
     { deploy-word-defs? f }
     { deploy-reflection 1 }
     { deploy-compiler? t }
-    { deploy-random? f }
     { deploy-c-types? f }
     { deploy-name "Bunny" }
     { deploy-word-props? f }

From ce91c9dcbab7d293046145829c98af9de7685784 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 01:40:54 -0600
Subject: [PATCH 176/318] Update deployment descriptors for deploy-random?
 removal

---
 extra/hello-ui/deploy.factor      | 1 -
 extra/hello-world/deploy.factor   | 1 -
 extra/joystick-demo/deploy.factor | 1 -
 extra/maze/deploy.factor          | 1 -
 extra/spheres/deploy.factor       | 1 -
 extra/sudoku/deploy.factor        | 1 -
 extra/tetris/deploy.factor        | 1 -
 extra/webkit-demo/deploy.factor   | 1 -
 8 files changed, 8 deletions(-)
 mode change 100755 => 100644 extra/hello-ui/deploy.factor

diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor
old mode 100755
new mode 100644
index b21fd77967..28ce8f519d
--- a/extra/hello-ui/deploy.factor
+++ b/extra/hello-ui/deploy.factor
@@ -8,7 +8,6 @@ H{
     { deploy-io 2 }
     { deploy-ui? t }
     { "stop-after-last-window?" t }
-    { deploy-random? f }
     { deploy-word-defs? f }
     { deploy-compiler? t }
     { deploy-reflection 1 }
diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor
index c683ef6e06..219fe0ca05 100755
--- a/extra/hello-world/deploy.factor
+++ b/extra/hello-world/deploy.factor
@@ -5,7 +5,6 @@ H{
     { deploy-threads? f }
     { deploy-word-props? f }
     { deploy-reflection 2 }
-    { deploy-random? f }
     { deploy-io 2 }
     { deploy-math? f }
     { deploy-ui? f }
diff --git a/extra/joystick-demo/deploy.factor b/extra/joystick-demo/deploy.factor
index 8843ae66f3..8f25662f9e 100644
--- a/extra/joystick-demo/deploy.factor
+++ b/extra/joystick-demo/deploy.factor
@@ -4,7 +4,6 @@ H{
     { deploy-io 2 }
     { deploy-word-defs? f }
     { deploy-c-types? t }
-    { deploy-random? t }
     { deploy-word-props? f }
     { deploy-reflection 1 }
     { deploy-threads? t }
diff --git a/extra/maze/deploy.factor b/extra/maze/deploy.factor
index c00d32f676..1eda315617 100755
--- a/extra/maze/deploy.factor
+++ b/extra/maze/deploy.factor
@@ -8,7 +8,6 @@ H{
     { deploy-io 2 }
     { deploy-ui? t }
     { "stop-after-last-window?" t }
-    { deploy-random? t }
     { deploy-word-defs? f }
     { deploy-compiler? t }
     { deploy-reflection 1 }
diff --git a/extra/spheres/deploy.factor b/extra/spheres/deploy.factor
index 0eeef1e3b7..d6591a1a26 100644
--- a/extra/spheres/deploy.factor
+++ b/extra/spheres/deploy.factor
@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-reflection 1 }
-    { deploy-random? t }
     { deploy-word-defs? f }
     { deploy-word-props? f }
     { deploy-name "Spheres" }
diff --git a/extra/sudoku/deploy.factor b/extra/sudoku/deploy.factor
index 3d9101b19e..92c4395dec 100755
--- a/extra/sudoku/deploy.factor
+++ b/extra/sudoku/deploy.factor
@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-word-defs? f }
-    { deploy-random? f }
     { deploy-name "Sudoku" }
     { deploy-threads? f }
     { deploy-compiler? t }
diff --git a/extra/tetris/deploy.factor b/extra/tetris/deploy.factor
index a21e592cc8..03ec5d4e64 100755
--- a/extra/tetris/deploy.factor
+++ b/extra/tetris/deploy.factor
@@ -6,7 +6,6 @@ H{
     { deploy-word-props? f }
     { deploy-reflection 1 }
     { "stop-after-last-window?" t }
-    { deploy-random? t }
     { deploy-io 2 }
     { deploy-math? t }
     { deploy-word-defs? f }
diff --git a/extra/webkit-demo/deploy.factor b/extra/webkit-demo/deploy.factor
index 684bbc57b5..8c0b1beb83 100644
--- a/extra/webkit-demo/deploy.factor
+++ b/extra/webkit-demo/deploy.factor
@@ -4,7 +4,6 @@ H{
     { deploy-compiler? t }
     { deploy-c-types? f }
     { deploy-reflection 1 }
-    { deploy-random? f }
     { deploy-name "WebKit demo" }
     { deploy-io 1 }
     { deploy-math? f }

From 5bbaa006b8576c74f753f4b6995095c38be9acf6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 01:58:00 -0600
Subject: [PATCH 177/318] roll back accidental deletion

---
 work/README.txt | 1 +
 1 file changed, 1 insertion(+)
 create mode 100644 work/README.txt

diff --git a/work/README.txt b/work/README.txt
new file mode 100644
index 0000000000..fd1af07408
--- /dev/null
+++ b/work/README.txt
@@ -0,0 +1 @@
+The 'work' directory is for your own personal vocabularies.

From 29279f305e98b74d48f4c79ce9d9b348cbb51b33 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 01:58:07 -0600
Subject: [PATCH 178/318] Fix 32-bit bootstrap

---
 basis/bootstrap/image/image.factor | 10 ++++++++--
 1 file changed, 8 insertions(+), 2 deletions(-)

diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index 80571d20b1..3816b930e0 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -374,10 +374,12 @@ M: tombstone '
     [ emit-tuple ] cache-object ;
 
 ! Arrays
-M: array '
+: emit-array ( array -- offset )
     [ ' ] map array type-number object tag-number
     [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 
+M: array ' emit-array ;
+
 ! This is a hack. We need to detect arrays which are tuple
 ! layout arrays so that they can be internalized, but making
 ! them a built-in type is not worth it.
@@ -389,7 +391,11 @@ PREDICATE: tuple-layout-array < array
         tri and and
     ] [ drop f ] if ;
 
-M: tuple-layout-array ' [ call-next-method ] cache-object ;
+M: tuple-layout-array '
+    [
+        [ dup integer? [ <fake-bignum> ] when ] map
+        emit-array
+    ] cache-object ;
 
 ! Quotations
 

From 6f432811f5492d33033b4d571df7dedc8e3d950e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 02:52:54 -0600
Subject: [PATCH 179/318] Fix mirrors

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

diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor
index ce99314ce6..d3d6dbdb04 100644
--- a/basis/mirrors/mirrors.factor
+++ b/basis/mirrors/mirrors.factor
@@ -44,7 +44,7 @@ M: mirror >alist ( mirror -- alist )
     [ object>> [ swap slot ] curry ] bi
     map zip ;
 
-M: mirror assoc-size object>> layout-of size>> ;
+M: mirror assoc-size object>> layout-of second ;
 
 INSTANCE: mirror assoc
 

From 7741096bffb376f771b0d1e62d39171f8c1edc28 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 03:36:46 -0600
Subject: [PATCH 180/318] Tweak PPC register usage; gcc doesn't like it when
 you mess with r31 for some reason

---
 basis/cpu/ppc/bootstrap.factor |  4 ++--
 basis/cpu/ppc/ppc.factor       | 16 ++++++++--------
 vm/cpu-ppc.S                   | 16 +++++-----------
 vm/cpu-ppc.h                   |  4 ++--
 4 files changed, 17 insertions(+), 23 deletions(-)

diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index 7d5e359a80..9bf88185c5 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -11,8 +11,8 @@ big-endian on
 
 4 jit-code-format set
 
-: ds-reg 30 ;
-: rs-reg 31 ;
+: ds-reg 29 ;
+: rs-reg 30 ;
 
 : factor-area-size ( -- n ) 4 bootstrap-cells ;
 
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 0857c4405c..77c4320f0c 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -19,10 +19,10 @@ namespaces compiler.codegen.fixup ;
 IN: cpu.ppc
 
 ! PowerPC register assignments:
-! r2-r28: integer vregs
-! r29: integer scratch
-! r30: data stack
-! r31: retain stack
+! r2-r27: integer vregs
+! r28: integer scratch
+! r29: data stack
+! r30: retain stack
 ! f0-f29: float vregs
 ! f30, f31: float scratch
 
@@ -40,13 +40,13 @@ IN: cpu.ppc
 
 M: ppc machine-registers
     {
-        { int-regs T{ range f 2 27 1 } }
+        { int-regs T{ range f 2 26 1 } }
         { double-float-regs T{ range f 0 28 1 } }
     } ;
 
-: scratch-reg 29 ; inline
-: fp-scratch-reg-1 30 ; inline
-: fp-scratch-reg-2 31 ; inline
+: scratch-reg 28 ; inline
+: fp-scratch-reg-1 29 ; inline
+: fp-scratch-reg-2 30 ; inline
 
 M: ppc two-operand? f ;
 
diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S
index 9fadc5df4a..620bc9e991 100755
--- a/vm/cpu-ppc.S
+++ b/vm/cpu-ppc.S
@@ -60,8 +60,8 @@ DEF(void,c_to_factor,(CELL quot)):
 	PROLOGUE
 
 	SAVE_INT(r13,0)	   /* save GPRs */
-			   /* don't save ds pointer */
-			   /* don't save rs pointer */
+	SAVE_INT(r14,1)
+	SAVE_INT(r15,2)
 	SAVE_INT(r16,3)
 	SAVE_INT(r17,4)
 	SAVE_INT(r18,5)
@@ -75,9 +75,6 @@ DEF(void,c_to_factor,(CELL quot)):
 	SAVE_INT(r26,13)
 	SAVE_INT(r27,14)
 	SAVE_INT(r28,15)
-	SAVE_INT(r29,16)
-	SAVE_INT(r30,17)
-	SAVE_INT(r31,18)
 
 	SAVE_FP(f14,20)    /* save FPRs */
 	SAVE_FP(f15,22)
@@ -125,10 +122,7 @@ DEF(void,c_to_factor,(CELL quot)):
 	RESTORE_FP(f15,22)
 	RESTORE_FP(f14,20)    /* save FPRs */
 
-	RESTORE_INT(r31,18)    /* restore GPRs */
-	RESTORE_INT(r30,17)
-	RESTORE_INT(r29,16)
-	RESTORE_INT(r28,15)
+	RESTORE_INT(r28,15)   /* restore GPRs */
 	RESTORE_INT(r27,14)
 	RESTORE_INT(r26,13)
 	RESTORE_INT(r25,12)
@@ -141,8 +135,8 @@ DEF(void,c_to_factor,(CELL quot)):
 	RESTORE_INT(r18,5)
 	RESTORE_INT(r17,4)
 	RESTORE_INT(r16,3)
-			   /* don't restore rs pointer */
-			   /* don't restore ds pointer */
+	RESTORE_INT(r15,2)
+	RESTORE_INT(r14,1)
 	RESTORE_INT(r13,0)
 
 	EPILOGUE
diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h
index 0f10aa34aa..298e21aa7d 100755
--- a/vm/cpu-ppc.h
+++ b/vm/cpu-ppc.h
@@ -1,8 +1,8 @@
 #define FACTOR_CPU_STRING "ppc"
 #define F_FASTCALL
 
-register CELL ds asm("r30");
-register CELL rs asm("r31");
+register CELL ds asm("r29");
+register CELL rs asm("r30");
 
 void c_to_factor(CELL quot);
 void undefined(CELL word);

From c2117d40462e8ba9f68c97ae835d8926b4726d8a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 03:37:10 -0600
Subject: [PATCH 181/318] make macosx-ppc now compiles a ppc binary on intel
 mac os; it doesn't work properly in rosetta though

---
 vm/Config.macosx.ppc | 1 +
 1 file changed, 1 insertion(+)

diff --git a/vm/Config.macosx.ppc b/vm/Config.macosx.ppc
index d31bb54f00..ed3c0d5a19 100644
--- a/vm/Config.macosx.ppc
+++ b/vm/Config.macosx.ppc
@@ -1,2 +1,3 @@
 include vm/Config.macosx
 include vm/Config.ppc
+CFLAGS += -arch ppc

From 765d36d08236f3205d2c50170617619a69b5f0ae Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 06:12:39 -0600
Subject: [PATCH 182/318] Fix markup problem detected by help-lint

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

diff --git a/extra/advice/advice-docs.factor b/extra/advice/advice-docs.factor
index 2b33378b99..7b523e9a8c 100644
--- a/extra/advice/advice-docs.factor
+++ b/extra/advice/advice-docs.factor
@@ -13,7 +13,7 @@ HELP: make-advised
 { $see-also advised? annotate } ;
 
 HELP: advised?
-{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet word } " is advised" } }
+{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
 { $description "Determines whether or not the given word has any advice on it." } ;
 
 ARTICLE: "advice" "Advice"

From d2ec46e38ffc31844b423906be9749146be75615 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@oberon.local>
Date: Thu, 6 Nov 2008 06:27:27 -0600
Subject: [PATCH 183/318] PowerPC backend almost functional; some new compiler
 unit tests added, better compilation of 'f eq?'; f becomes an immediate
 operand move aux-offset to compiler.constants

---
 .../cfg/intrinsics/alien/alien.factor         |   2 +-
 .../cfg/intrinsics/fixnum/fixnum.factor       |   9 +-
 .../cfg/intrinsics/slots/slots.factor         |   4 +-
 basis/compiler/cfg/utilities/utilities.factor |  16 +-
 basis/compiler/constants/constants.factor     |  71 +++++----
 basis/compiler/tests/intrinsics.factor        |  32 +++-
 basis/cpu/ppc/ppc.factor                      | 149 +++++++++---------
 basis/cpu/x86/x86.factor                      |   4 +-
 8 files changed, 161 insertions(+), 126 deletions(-)

diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor
index 6b9bc9fcce..42e23c29c9 100644
--- a/basis/compiler/cfg/intrinsics/alien/alien.factor
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@@ -15,7 +15,7 @@ IN: compiler.cfg.intrinsics.alien
 
 : prepare-alien-accessor ( infos -- offset-vreg )
     <reversed> [ second class>> ] [ first ] bi
-    dup value-info-small-tagged? [
+    dup value-info-small-fixnum? [
         literal>> (prepare-alien-accessor-imm)
     ] [ drop (prepare-alien-accessor) ] if ;
 
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index 12a3ef8597..04c9097725 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -9,7 +9,10 @@ IN: compiler.cfg.intrinsics.fixnum
 
 : (emit-fixnum-imm-op) ( infos insn -- dst )
     ds-drop
-    [ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
+    [ ds-pop ]
+    [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
+    [ ]
+    tri*
     call ; inline
 
 : (emit-fixnum-op) ( insn -- dst )
@@ -25,7 +28,7 @@ IN: compiler.cfg.intrinsics.fixnum
     ] ; inline
 
 : emit-fixnum-shift-fast ( node -- )
-    dup node-input-infos dup second value-info-small-tagged? [
+    dup node-input-infos dup second value-info-small-fixnum? [
         nip
         [ ds-drop ds-pop ] dip
         second literal>> dup sgn {
@@ -48,7 +51,7 @@ IN: compiler.cfg.intrinsics.fixnum
 
 : emit-fixnum*fast ( node -- )
     node-input-infos
-    dup second value-info-small-tagged?
+    dup second value-info-small-fixnum?
     [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
     ds-push ;
 
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index 22fb4e747b..fec234a576 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -25,7 +25,7 @@ IN: compiler.cfg.intrinsics.slots
     dup node-input-infos
     dup first value-tag [
         nip
-        dup second value-info-small-tagged?
+        dup second value-info-small-fixnum?
         [ (emit-slot-imm) ] [ (emit-slot) ] if
         ds-push
     ] [ drop emit-primitive ] if ;
@@ -46,7 +46,7 @@ IN: compiler.cfg.intrinsics.slots
     dup second value-tag [
         nip
         [
-            dup third value-info-small-tagged?
+            dup third value-info-small-fixnum?
             [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
         ] [ first class>> immediate class<= ] bi
         [ drop ] [ i i ##write-barrier ] if
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index b00fd0ed3d..cef14d06e4 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -1,12 +1,24 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math layouts make sequences
+USING: accessors kernel math layouts make sequences combinators
 cpu.architecture namespaces compiler.cfg
 compiler.cfg.instructions ;
 IN: compiler.cfg.utilities
 
+: value-info-small-fixnum? ( value-info -- ? )
+    literal>> {
+        { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+        [ drop f ]
+    } cond ;
+
 : value-info-small-tagged? ( value-info -- ? )
-    literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
+    dup literal?>> [
+        literal>> {
+            { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+            { [ dup not ] [ drop t ] }
+            [ drop f ]
+        } cond
+    ] [ drop f ] if ;
 
 : set-basic-block ( basic-block -- )
     [ basic-block set ] [ instructions>> building set ] bi ;
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index b5b2be5095..cd68602768 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -1,49 +1,50 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel layouts system ;
+USING: math kernel layouts system strings ;
 IN: compiler.constants
 
 ! These constants must match vm/memory.h
-: card-bits 8 ;
-: deck-bits 18 ;
-: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
+: card-bits 8 ; inline
+: deck-bits 18 ; inline
+: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
 
 ! These constants must match vm/layouts.h
-: header-offset ( -- n ) object tag-number neg ;
-: float-offset ( -- n ) 8 float tag-number - ;
-: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
-: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
-: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
-: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
-: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
-: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
-: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
-: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
-: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
-: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
-: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
-: compiled-header-size ( -- n ) 4 bootstrap-cells ;
+: header-offset ( -- n ) object tag-number neg ; inline
+: float-offset ( -- n ) 8 float tag-number - ; inline
+: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
+: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
+: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
+: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
+: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
+: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
+: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
+: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
+: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
 
 ! Relocation classes
-: rc-absolute-cell    0 ;
-: rc-absolute         1 ;
-: rc-relative         2 ;
-: rc-absolute-ppc-2/2 3 ;
-: rc-relative-ppc-2   4 ;
-: rc-relative-ppc-3   5 ;
-: rc-relative-arm-3   6 ;
-: rc-indirect-arm     7 ;
-: rc-indirect-arm-pc  8 ;
+: rc-absolute-cell    0 ; inline
+: rc-absolute         1 ; inline
+: rc-relative         2 ; inline
+: rc-absolute-ppc-2/2 3 ; inline
+: rc-relative-ppc-2   4 ; inline
+: rc-relative-ppc-3   5 ; inline
+: rc-relative-arm-3   6 ; inline
+: rc-indirect-arm     7 ; inline
+: rc-indirect-arm-pc  8 ; inline
 
 ! Relocation types
-: rt-primitive 0 ;
-: rt-dlsym     1 ;
-: rt-literal   2 ;
-: rt-dispatch  3 ;
-: rt-xt        4 ;
-: rt-here      5 ;
-: rt-label     6 ;
-: rt-immediate 7 ;
+: rt-primitive 0 ; inline
+: rt-dlsym     1 ; inline
+: rt-literal   2 ; inline
+: rt-dispatch  3 ; inline
+: rt-xt        4 ; inline
+: rt-here      5 ; inline
+: rt-label     6 ; inline
+: rt-immediate 7 ; inline
 
 : rc-absolute? ( n -- ? )
     [ rc-absolute-ppc-2/2 = ]
diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor
index e012a42cc0..c90a31fc61 100644
--- a/basis/compiler/tests/intrinsics.factor
+++ b/basis/compiler/tests/intrinsics.factor
@@ -4,7 +4,8 @@ continuations sequences.private hashtables.private byte-arrays
 strings.private system random layouts vectors
 sbufs strings.private slots.private alien math.order
 alien.accessors alien.c-types alien.syntax alien.strings
-namespaces libc sequences.private io.encodings.ascii ;
+namespaces libc sequences.private io.encodings.ascii
+classes ;
 IN: compiler.tests
 
 ! Make sure that intrinsic ops compile to correct code.
@@ -27,6 +28,9 @@ IN: compiler.tests
 
 [ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
 [ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
+
+[ { f f } ] [ 2 f <array> ] unit-test
+
 [ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
 [ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
 [ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
@@ -37,13 +41,19 @@ IN: compiler.tests
 ! Write barrier hits on the wrong value were causing segfaults
 [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
 
-! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
-! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
-! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
-! 
-! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
+[ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
+[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
+[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
+[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
+[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
+[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
+
+[ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
 
 [ ] [ [ 0 getenv ] compile-call drop ] unit-test
 [ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
@@ -158,6 +168,10 @@ IN: compiler.tests
 [ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
 [ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
 
+[ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
+[ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
+[ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
+
 [ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
 
 [ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
@@ -263,6 +277,8 @@ cell 8 = [
 
 : compiled-fixnum>bignum fixnum>bignum ;
 
+[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
+
 [ ] [
     10000 [
         32 random-bits >fixnum
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 77c4320f0c..ad6c63b8c9 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -1,21 +1,10 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types
-accessors
-cpu.architecture
-compiler.cfg.registers
-cpu.ppc.assembler
-kernel
-locals
-layouts
-combinators
-make
-compiler.cfg.instructions
-math.order
-system
-math
-compiler.constants
-namespaces compiler.codegen.fixup ;
+USING: accessors assocs sequences kernel combinators make math
+math.order math.ranges system namespaces locals layouts words
+alien alien.c-types cpu.architecture cpu.ppc.assembler
+compiler.cfg.registers compiler.cfg.instructions
+compiler.constants compiler.codegen compiler.codegen.fixup ;
 IN: cpu.ppc
 
 ! PowerPC register assignments:
@@ -57,13 +46,13 @@ M:: ppc %load-indirect ( reg obj -- )
     obj rc-absolute-ppc-2/2 rel-literal
     reg reg 0 LWZ ;
 
-: ds-reg 30 ; inline
-: rs-reg 31 ; inline
+: ds-reg 29 ; inline
+: rs-reg 30 ; inline
 
 GENERIC: loc-reg ( loc -- reg )
 
-M: ds-loc log-reg drop ds-reg ;
-M: rs-loc log-reg drop rs-reg ;
+M: ds-loc loc-reg drop ds-reg ;
+M: rs-loc loc-reg drop rs-reg ;
 
 : loc>operand ( loc -- reg n )
     [ loc-reg ] [ n>> cells neg ] bi ; inline
@@ -137,9 +126,25 @@ M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ;
 M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
 M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
 
+M:: ppc %string-nth ( dst src index temp -- )
+    [
+        "end" define-label
+        temp src index ADD
+        dst temp string-offset LBZ
+        temp src string-aux-offset LWZ
+        0 temp \ f tag-number CMPI
+        "end" get BEQ
+        temp temp index ADD
+        temp temp index ADD
+        temp temp byte-array-offset LHZ
+        temp temp 8 SLWI
+        dst dst temp OR
+        "end" resolve-label
+    ] with-scope ;
+
 M: ppc %add     ADD ;
 M: ppc %add-imm ADDI ;
-M: ppc %sub     swapd SUBF ;
+M: ppc %sub     swap SUBF ;
 M: ppc %sub-imm SUBI ;
 M: ppc %mul     MULLW ;
 M: ppc %mul-imm MULLI ;
@@ -156,44 +161,42 @@ M: ppc %not     NOT ;
 
 : bignum@ ( n -- offset ) cells bignum tag-number - ; inline
 
-M: ppc %integer>bignum ( dst src temp -- )
+M:: ppc %integer>bignum ( dst src temp -- )
     [
-        { "end" "non-zero" "pos" "store" } [ define-label ] each
-        dst 0 >bignum %load-immediate
+        "end" define-label
+        dst 0 >bignum %load-indirect
         ! Is it zero? Then just go to the end and return this zero
         0 src 0 CMPI
         "end" get BEQ
         ! Allocate a bignum
         dst 4 cells bignum temp %allot
         ! Write length
-        2 temp LI
-        dst 1 bignum@ temp STW
-        ! Store value
-        dst 3 bignum@ src STW
+        2 tag-fixnum temp LI
+        temp dst 1 bignum@ STW
         ! Compute sign
         temp src MR
-        temp cell-bits 1- SRAWI
+        temp temp cell-bits 1- SRAWI
         temp temp 1 ANDI
         ! Store sign
-        dst 2 bignum@ temp STW
+        temp dst 2 bignum@ STW
         ! Make negative value positive
         temp temp temp ADD
         temp temp NEG
         temp temp 1 ADDI
         temp src temp MULLW
         ! Store the bignum
-        dst 3 bignum@ temp STW
+        temp dst 3 bignum@ STW
         "end" resolve-label
     ] with-scope ;
 
-M:: %bignum>integer ( dst src temp -- )
+M:: ppc %bignum>integer ( dst src temp -- )
     [
         "end" define-label
         temp src 1 bignum@ LWZ
         ! if the length is 1, its just the sign and nothing else,
         ! so output 0
         0 dst LI
-        0 temp 1 v>operand CMPI
+        0 temp 1 tag-fixnum CMPI
         "end" get BEQ
         ! load the value
         dst src 3 bignum@ LWZ
@@ -203,6 +206,7 @@ M:: %bignum>integer ( dst src temp -- )
         ! and 1 into -1
         temp temp temp ADD
         temp temp 1 SUBI
+        temp temp NEG
         ! multiply value by sign
         dst dst temp MULLW
         "end" resolve-label
@@ -213,14 +217,14 @@ M: ppc %sub-float FSUB ;
 M: ppc %mul-float FMUL ;
 M: ppc %div-float FDIV ;
 
-M: ppc %integer>float ( dst src -- )
+M:: ppc %integer>float ( dst src -- )
     HEX: 4330 scratch-reg LIS
     scratch-reg 1 0 param@ STW
     scratch-reg src MR
     scratch-reg dup HEX: 8000 XORIS
     scratch-reg 1 cell param@ STW
     fp-scratch-reg-2 1 0 param@ LFD
-    4503601774854144.0 scratch-reg load-indirect
+    scratch-reg 4503601774854144.0 %load-indirect
     fp-scratch-reg-2 scratch-reg float-offset LFD
     fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
 
@@ -231,7 +235,7 @@ M:: ppc %float>integer ( dst src -- )
 
 M: ppc %copy ( dst src -- ) MR ;
 
-M: ppc %copy-float ( dst src -- ) MFR ;
+M: ppc %copy-float ( dst src -- ) FMR ;
 
 M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
 
@@ -277,9 +281,9 @@ M:: ppc %box-alien ( dst src temp -- )
         "f" get BEQ
         dst 4 cells alien temp %allot
         ! Store offset
-        dst src 3 alien@ STW
-        temp \ f tag-number %load-immediate
+        src dst 3 alien@ STW
         ! Store expired slot
+        temp \ f tag-number %load-immediate
         temp dst 1 alien@ STW
         ! Store underlying-alien slot
         temp dst 2 alien@ STW
@@ -289,7 +293,7 @@ M:: ppc %box-alien ( dst src temp -- )
 M: ppc %alien-unsigned-1 0 LBZ ;
 M: ppc %alien-unsigned-2 0 LHZ ;
 
-M: ppc %alien-signed-1 dupd 0 LBZ EXTSB ;
+M: ppc %alien-signed-1 dupd 0 LBZ dup EXTSB ;
 M: ppc %alien-signed-2 0 LHA ;
 
 M: ppc %alien-cell 0 LWZ ;
@@ -297,45 +301,47 @@ M: ppc %alien-cell 0 LWZ ;
 M: ppc %alien-float 0 LFS ;
 M: ppc %alien-double 0 LFD ;
 
-M: ppc %set-alien-integer-1 0 STB ;
-M: ppc %set-alien-integer-2 0 STH ;
+M: ppc %set-alien-integer-1 swap 0 STB ;
+M: ppc %set-alien-integer-2 swap 0 STH ;
 
-M: ppc %set-alien-cell 0 STW ;
+M: ppc %set-alien-cell swap 0 STW ;
 
-M: ppc %set-alien-float 0 STFS ;
-M: ppc %set-alien-double 0 STFD ;
+M: ppc %set-alien-float swap 0 STFS ;
+M: ppc %set-alien-double swap 0 STFD ;
+
+: %load-dlsym ( symbol dll register -- )
+    0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
 
 : load-zone-ptr ( reg -- )
     [ "nursery" f ] dip %load-dlsym ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
-    [ drop load-zone-ptr ] [ swap cell LWZ ] 2bi ;
+    [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
 
-:: inc-allot-ptr ( nursery-ptr n -- )
-    scratch-reg inc-allot-ptr 4 LWZ
-    scratch-reg scratch-reg n 8 align ADD
-    scratch-reg inc-allot-ptr 4 STW ;
+:: inc-allot-ptr ( nursery-ptr allot-ptr n -- )
+    scratch-reg allot-ptr n 8 align ADDI
+    scratch-reg nursery-ptr 4 STW ;
 
-:: store-header ( temp class -- )
+:: store-header ( dst class -- )
     class type-number tag-fixnum scratch-reg LI
-    temp scratch-reg 0 STW ;
+    scratch-reg dst 0 STW ;
 
 : store-tagged ( dst tag -- )
     dupd tag-number ORI ;
 
 M:: ppc %allot ( dst size class nursery-ptr -- )
     nursery-ptr dst load-allot-ptr
+    nursery-ptr dst size inc-allot-ptr
     dst class store-header
-    dst class store-tagged
-    nursery-ptr size inc-allot-ptr ;
+    dst class store-tagged ;
 
-: %alien-global ( dest name -- )
-    [ f swap %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
+: %alien-global ( dst name -- )
+    [ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
 
-: load-cards-offset ( dest -- )
+: load-cards-offset ( dst -- )
     "cards_offset" %alien-global ;
 
-: load-decks-offset ( dest -- )
+: load-decks-offset ( dst -- )
     "decks_offset" %alien-global ;
 
 M:: ppc %write-barrier ( src card# table -- )
@@ -359,18 +365,17 @@ M: ppc %gc
     11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
     11 0 12 CMP ! is here >= end?
     "end" get BLE
-    0 frame-required
     %prepare-alien-invoke
     "minor_gc" f %alien-invoke
     "end" resolve-label ;
 
 M: ppc %prologue ( n -- )
-    0 scrach-reg LOAD32 rc-absolute-ppc-2/2 rel-this
+    0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this
     0 MFLR
     1 1 pick neg ADDI
-    scrach-reg 1 pick xt-save STW
-    dup scrach-reg LI
-    scrach-reg 1 pick next-save STW
+    scratch-reg 1 pick xt-save STW
+    dup scratch-reg LI
+    scratch-reg 1 pick next-save STW
     0 1 rot lr-save + STW ;
 
 M: ppc %epilogue ( n -- )
@@ -384,19 +389,19 @@ M: ppc %epilogue ( n -- )
 
 :: (%boolean) ( dst word -- )
     "end" define-label
-    \ f tag-number %load-immediate
+    dst \ f tag-number %load-immediate
     "end" get word execute
     dst \ t %load-indirect
     "end" get resolve-label ; inline
 
 : %boolean ( dst cc -- )
     negate-cc {
-        { cc< [ \ BLT %boolean ] }
-        { cc<= [ \ BLE %boolean ] }
-        { cc> [ \ BGT %boolean ] }
-        { cc>= [ \ BGE %boolean ] }
-        { cc= [ \ BEQ %boolean ] }
-        { cc/= [ \ BNE %boolean ] }
+        { cc< [ \ BLT (%boolean) ] }
+        { cc<= [ \ BLE (%boolean) ] }
+        { cc> [ \ BGT (%boolean) ] }
+        { cc>= [ \ BGE (%boolean) ] }
+        { cc= [ \ BEQ (%boolean) ] }
+        { cc/= [ \ BNE (%boolean) ] }
     } case ;
 
 : (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
@@ -426,7 +431,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ;
 
 : stack@ 1 swap ; inline
 
-: spill-integer@ ( n -- op )
+: spill-integer@ ( n -- reg offset )
     cells
     stack-frame get spill-integer-base
     + stack@ ;
@@ -437,7 +442,7 @@ M: ppc %compare-float-branch (%compare-float) %branch ;
     [ return>> ]
     tri + + ;
 
-: spill-float@ ( n -- op )
+: spill-float@ ( n -- reg offset )
     double-float-regs reg-size *
     stack-frame get spill-float-base
     + stack@ ;
@@ -560,7 +565,7 @@ M: ppc %alien-invoke ( symbol dll -- )
     11 %load-dlsym 11 MTLR BLRL ;
 
 M: ppc %alien-callback ( quot -- )
-    3 load-indirect "c_to_factor" f %alien-invoke ;
+    3 swap %load-indirect "c_to_factor" f %alien-invoke ;
 
 M: ppc %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 0e00ce60ee..8ae3bddfaa 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -293,15 +293,13 @@ M:: x86 %box-alien ( dst src temp -- )
         [ quot call ] with-save/restore
     ] if ; inline
 
-: aux-offset 2 cells string tag-number - ; inline
-
 M:: x86 %string-nth ( dst src index temp -- )
     "end" define-label
     dst { src index temp } [| new-dst |
         temp src index [+] LEA
         new-dst 1 small-reg temp string-offset [+] MOV
         new-dst new-dst 1 small-reg MOVZX
-        temp src aux-offset [+] MOV
+        temp src string-aux-offset [+] MOV
         temp \ f tag-number CMP
         "end" get JE
         new-dst temp XCHG

From a95bb533b5d40e65a91b1ffe30182edbf752b308 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 09:08:17 -0600
Subject: [PATCH 184/318] Remove more redundant branches from tuple type
 predicates and generic words with methods on tuple classes

---
 core/classes/tuple/tuple.factor               | 21 ++++++++++----
 .../standard/engines/tuple/tuple.factor       | 29 ++++++++++++++-----
 2 files changed, 37 insertions(+), 13 deletions(-)

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index c2f93ead3e..a56a4df029 100644
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -90,20 +90,29 @@ ERROR: bad-superclass class ;
         2drop f
     ] if ; inline
 
+: tuple-instance-1? ( object class -- ? )
+    swap dup tuple? [
+        layout-of 7 slot eq?
+    ] [ 2drop f ] if ; inline
+
 : tuple-instance? ( object class offset -- ? )
-    #! 4 slot == superclasses>>
     rot dup tuple? [
         layout-of
         2dup 1 slot fixnum<=
         [ swap slot eq? ] [ 3drop f ] if
     ] [ 3drop f ] if ; inline
 
-: layout-class-offset ( class -- n )
-    tuple-layout third 2 * 5 + ;
+: layout-class-offset ( echelon -- n )
+    2 * 5 + ;
+
+: echelon-of ( class -- n )
+    tuple-layout third ;
 
 : define-tuple-predicate ( class -- )
-    dup dup layout-class-offset
-    [ tuple-instance? ] 2curry define-predicate ;
+    dup dup echelon-of {
+        { 1 [ [ tuple-instance-1? ] curry ] }
+        [ layout-class-offset [ tuple-instance? ] 2curry ]
+    } case define-predicate ;
 
 : class-size ( class -- n )
     superclasses [ "slots" word-prop length ] sigma ;
@@ -292,7 +301,7 @@ M: tuple-class reset-class
 M: tuple-class rank-class drop 0 ;
 
 M: tuple-class instance?
-    dup layout-class-offset tuple-instance? ;
+    dup echelon-of layout-class-offset tuple-instance? ;
 
 M: tuple-class (flatten-class) dup set ;
 
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
index 34447fb92d..04368099fb 100644
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ b/core/generic/standard/engines/tuple/tuple.factor
@@ -48,10 +48,14 @@ TUPLE: tuple-dispatch-engine echelons ;
     \ <tuple-dispatch-engine> convert-methods ;
 
 M: trivial-tuple-dispatch-engine engine>quot
-    [
-        [ n>> nth-superclass% ]
-        [ methods>> engines>quots* linear-dispatch-quot % ] bi
-    ] [ ] make ;
+    [ n>> ] [ methods>> ] bi dup assoc-empty? [
+        2drop default get [ drop ] prepend
+    ] [
+        [
+            [ nth-superclass% ]
+            [ engines>quots* linear-dispatch-quot % ] bi*
+        ] [ ] make
+    ] if ;
 
 : hash-methods ( n methods -- buckets )
     >alist V{ } clone [ hashcode 1array ] distribute-buckets
@@ -119,11 +123,19 @@ M: echelon-dispatch-engine engine>quot
     ] assoc-map
     alist>quot ;
 
+: simplify-echelon-alist ( default alist -- default' alist' )
+    dup empty? [
+        dup first first 1 <= [
+            nip unclip second swap
+            simplify-echelon-alist
+        ] when
+    ] unless ;
+
 : echelon-case-quot ( alist -- quot )
     #! We don't have to test for echelon 1 since all tuple
     #! classes are at least at depth 1 in the inheritance
     #! hierarchy.
-    dup first first 1 = [ unclip second ] [ default get ] if swap
+    default get swap simplify-echelon-alist
     [
         [
             picker %
@@ -140,8 +152,11 @@ M: tuple-dispatch-engine engine>quot
             echelons>> unclip-last
             [
                 [
-                    engine>quot define-engine-word
-                    [ remember-engine ] [ 1quotation ] bi
+                    engine>quot
+                    over 0 = [
+                        define-engine-word
+                        [ remember-engine ] [ 1quotation ] bi
+                    ] unless
                     dup default set
                 ] assoc-map
             ]

From 1c1333fbe99441834639e6275c8da678f0df6bf0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 09:09:21 -0600
Subject: [PATCH 185/318] Compile not and >boolean as branchless intrinsics by
 having the CFG builder detect certain code patterns

---
 basis/compiler/cfg/builder/builder.factor | 29 ++++++++++++++++++++++-
 core/kernel/kernel.factor                 |  4 ++--
 2 files changed, 30 insertions(+), 3 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index a59ceff5b9..5b9f2e068b 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -125,8 +125,35 @@ M: #recursive emit-node
 : ##branch-t ( vreg -- )
     \ f tag-number cc/= ##compare-imm-branch ;
 
+: trivial-branch? ( nodes -- value ? )
+    dup length 1 = [
+        first dup #push? [ literal>> t ] [ drop f f ] if
+    ] [ drop f f ] if ;
+
+: trivial-if? ( #if -- ? )
+    children>> first2
+    [ trivial-branch? [ t eq? ] when ]
+    [ trivial-branch? [ f eq? ] when ] bi*
+    and ;
+
+: emit-trivial-if ( -- )
+    ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
+
+: trivial-not-if? ( #if -- ? )
+    children>> first2
+    [ trivial-branch? [ f eq? ] when ]
+    [ trivial-branch? [ t eq? ] when ] bi*
+    and ;
+
+: emit-trivial-not-if ( -- )
+    ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
+
 M: #if emit-node
-    ds-pop ##branch-t emit-if iterate-next ;
+    {
+        { [ dup trivial-if? ] [ drop emit-trivial-if ] }
+        { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
+        [ ds-pop ##branch-t emit-if ]
+    } cond iterate-next ;
 
 ! #dispatch
 : dispatch-branch ( nodes word -- label )
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index fae1922d29..62e37ef301 100644
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -167,11 +167,11 @@ GENERIC: boa ( ... class -- tuple )
     compose compose ; inline
 
 ! Booleans
-: not ( obj -- ? ) f t ? ; inline
+: not ( obj -- ? ) [ f ] [ t ] if ; inline
 
 : and ( obj1 obj2 -- ? ) over ? ; inline
 
-: >boolean ( obj -- ? ) t f ? ; inline
+: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
 
 : or ( obj1 obj2 -- ? ) dupd ? ; inline
 

From 64cbf619a9a2c3cee098d51eec3accb66a5211a1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 09:27:52 -0600
Subject: [PATCH 186/318] Add more algebraic simplifications: comparison of a
 comparison, comparison where first is immediate

---
 .../value-numbering/rewrite/rewrite.factor    | 70 ++++++++++++++---
 .../value-numbering-tests.factor              | 76 ++++++++++++++++++-
 2 files changed, 135 insertions(+), 11 deletions(-)

diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 16a3b57829..94c3f0d6f9 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -42,25 +42,75 @@ M: ##mul-imm rewrite
 
 : tag-fixnum-expr? ( expr -- ? )
     dup op>> \ ##shl-imm eq?
-    [ in2>> vn>expr value>> tag-bits get = ] [ drop f ] if ;
+    [ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
 
 : rewrite-tagged-comparison? ( insn -- ? )
     #! Are we comparing two tagged fixnums? Then untag them.
-    dup ##compare-imm-branch? [
-        [ src1>> vreg>expr tag-fixnum-expr? ]
-        [ src2>> tag-mask get bitand 0 = ]
-        bi and
-    ] [ drop f ] if ; inline
+    [ src1>> vreg>expr tag-fixnum-expr? ]
+    [ src2>> tag-mask get bitand 0 = ]
+    bi and ; inline
 
-: rewrite-tagged-comparison ( insn -- insn' )
+: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
     [ src1>> vreg>expr in1>> vn>vreg ]
     [ src2>> tag-bits get neg shift ]
     [ cc>> ]
-    tri
-    f \ ##compare-imm-branch boa ;
+    tri ; inline
+
+GENERIC: rewrite-tagged-comparison ( insn -- insn' )
+
+M: ##compare-imm-branch rewrite-tagged-comparison
+    (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
+
+M: ##compare-imm rewrite-tagged-comparison
+    [ dst>> ] [ (rewrite-tagged-comparison) ] bi
+    f \ ##compare-imm boa ;
 
 M: ##compare-imm-branch rewrite
     dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
-    dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when ;
+    dup ##compare-imm-branch? [
+        dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
+    ] when ;
+
+: flip-comparison? ( insn -- ? )
+    dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
+
+: flip-comparison ( insn -- insn' )
+    [ dst>> ]
+    [ src2>> ]
+    [ src1>> vreg>vn vn>constant ] tri
+    cc= f \ ##compare-imm boa ;
+
+M: ##compare rewrite
+    dup flip-comparison? [
+        flip-comparison
+        dup number-values
+        rewrite
+    ] when ;
+
+: rewrite-redundant-comparison? ( insn -- ? )
+    [ src1>> vreg>expr compare-expr? ]
+    [ src2>> \ f tag-number = ]
+    [ cc>> { cc= cc/= } memq? ]
+    tri and and ; inline
+
+: rewrite-redundant-comparison ( insn -- insn' )
+    [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
+        { \ ##compare [ >compare-expr< f \ ##compare boa ] }
+        { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
+        { \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
+    } case
+    swap cc= eq? [ [ negate-cc ] change-cc ] when ;
+
+M: ##compare-imm rewrite
+    dup rewrite-redundant-comparison? [
+        rewrite-redundant-comparison
+        dup number-values rewrite
+    ] when
+    dup ##compare-imm? [
+        dup rewrite-tagged-comparison? [
+            rewrite-tagged-comparison
+            dup number-values rewrite
+        ] when
+    ] when ;
 
 M: insn rewrite ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index a33c2f28c4..d3be68c3c9 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -1,6 +1,6 @@
 IN: compiler.cfg.value-numbering.tests
 USING: compiler.cfg.value-numbering compiler.cfg.instructions
-compiler.cfg.registers cpu.architecture tools.test kernel ;
+compiler.cfg.registers cpu.architecture tools.test kernel math ;
 [
     {
         T{ ##peek f V int-regs 45 D 1 }
@@ -66,3 +66,77 @@ compiler.cfg.registers cpu.architecture tools.test kernel ;
         T{ ##replace f V int-regs 3 D 0 }
     } value-numbering
 ] unit-test
+
+[
+    {
+        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##peek f V int-regs 2 D 0 }
+        T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
+        T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
+        T{ ##replace f V int-regs 4 D 0 }
+    }
+] [
+    {
+        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##peek f V int-regs 2 D 0 }
+        T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
+        T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
+        T{ ##replace f V int-regs 6 D 0 }
+    } value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##peek f V int-regs 2 D 0 }
+        T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
+        T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
+        T{ ##replace f V int-regs 6 D 0 }
+    }
+] [
+    {
+        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##peek f V int-regs 2 D 0 }
+        T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
+        T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
+        T{ ##replace f V int-regs 6 D 0 }
+    } value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 8 D 0 }
+        T{ ##peek f V int-regs 9 D -1 }
+        T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
+        T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
+        T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
+        T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= }
+        T{ ##replace f V int-regs 14 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 8 D 0 }
+        T{ ##peek f V int-regs 9 D -1 }
+        T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
+        T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
+        T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
+        T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
+        T{ ##replace f V int-regs 14 D 0 }
+    } value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 29 D -1 }
+        T{ ##peek f V int-regs 30 D -2 }
+        T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
+        T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 29 D -1 }
+        T{ ##peek f V int-regs 30 D -2 }
+        T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
+        T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
+    } value-numbering
+] unit-test

From 9366ad650d736c51f2aaa1ebbcb3e1e3527950b3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 09:29:21 -0600
Subject: [PATCH 187/318] Add unportable tag

---
 basis/cpu/x86/tags.txt | 2 ++
 1 file changed, 2 insertions(+)
 create mode 100644 basis/cpu/x86/tags.txt

diff --git a/basis/cpu/x86/tags.txt b/basis/cpu/x86/tags.txt
new file mode 100644
index 0000000000..8e66660f70
--- /dev/null
+++ b/basis/cpu/x86/tags.txt
@@ -0,0 +1,2 @@
+unportable
+compiler

From d2b2cda596e542c6c23cde8557a4c982005ef29e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 10:44:06 -0600
Subject: [PATCH 188/318] Sort methods by tag, this speeds up >fixnum in the
 common case where the input is a fixnum

---
 core/generic/standard/engines/tag/tag.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
index c65726260c..87e2f1c9b1 100644
--- a/core/generic/standard/engines/tag/tag.factor
+++ b/core/generic/standard/engines/tag/tag.factor
@@ -27,7 +27,7 @@ M: lo-tag-dispatch-engine engine>quot
     [ >r lo-tag-number r> ] assoc-map
     [
         picker % [ tag ] % [
-            ! >alist sort-keys reverse
+            >alist sort-keys reverse
             linear-dispatch-quot
         ] [
             num-tags get direct-dispatch-quot

From 666100a07bc47a9542f45e179eacb8f731cec898 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 11:07:19 -0600
Subject: [PATCH 189/318] Tweak euler043 to run in constant space, add new
 each-permutation and reduce-permutations combinators to math.combinatorics

---
 extra/math/combinatorics/combinatorics.factor | 7 +++++++
 extra/project-euler/043/043.factor            | 7 +++++--
 2 files changed, 12 insertions(+), 2 deletions(-)

diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor
index b1c49b8ab5..00a104b381 100644
--- a/extra/math/combinatorics/combinatorics.factor
+++ b/extra/math/combinatorics/combinatorics.factor
@@ -44,5 +44,12 @@ PRIVATE>
 : all-permutations ( seq -- seq )
     [ length factorial ] keep '[ _ permutation ] map ;
 
+: each-permutation ( seq quot -- )
+    [ [ length factorial ] keep ] dip
+    '[ _ permutation @ ] each ; inline
+
+: reduce-permutations ( seq initial quot -- result )
+    swapd each-permutation ; inline
+
 : inverse-permutation ( seq -- permutation )
     <enum> >alist sort-values keys ;
diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index 268a6becfb..37118b88a3 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -52,8 +52,11 @@ IN: project-euler.043
 PRIVATE>
 
 : euler043 ( -- answer )
-    1234567890 number>digits all-permutations
-    [ interesting? ] filter [ 10 digits>integer ] map sum ;
+    1234567890 number>digits 0 [
+        dup interesting? [
+            10 digits>integer +
+        ] [ drop ] if
+    ] reduce-permutations ;
 
 ! [ euler043 ] time
 ! 104526 ms run / 42735 ms GC time

From 4e55cd973bbcc08154c6e6d6ccd2ae2d4d4199ff Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 11:48:55 -0600
Subject: [PATCH 190/318] If a #dispatch branch is a call to another word which
 is not an intrinsic, we avoid generating the dispatch branch and just jump to
 the word directly

---
 basis/compiler/cfg/builder/builder.factor | 35 +++++++++++++++--------
 1 file changed, 23 insertions(+), 12 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 5b9f2e068b..93daa601fe 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -156,19 +156,30 @@ M: #if emit-node
     } cond iterate-next ;
 
 ! #dispatch
+: trivial-dispatch-branch? ( nodes -- ? )
+    dup length 1 = [
+        first dup #call? [
+            word>> "intrinsic" word-prop not
+        ] [ drop f ] if
+    ] [ drop f ] if ;
+
 : dispatch-branch ( nodes word -- label )
-    gensym [
-        [
-            V{ } clone node-stack set
-            ##prologue
-            emit-nodes
-            basic-block get [
-                ##epilogue
-                ##return
-                end-basic-block
-            ] when
-        ] with-cfg-builder
-    ] keep ;
+    over trivial-dispatch-branch? [
+        drop first word>>
+    ] [
+        gensym [
+            [
+                V{ } clone node-stack set
+                ##prologue
+                emit-nodes
+                basic-block get [
+                    ##epilogue
+                    ##return
+                    end-basic-block
+                ] when
+            ] with-cfg-builder
+        ] keep
+    ] if ;
 
 : dispatch-branches ( node -- )
     children>> [

From 751426f28358252e537691a7893b0d9debb3cf0f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 11:57:31 -0600
Subject: [PATCH 191/318] Remove dead code from math.intervals; we no longer
 need the operations to support f anymore

---
 basis/math/intervals/intervals-tests.factor |  2 --
 basis/math/intervals/intervals.factor       | 21 +++++----------------
 2 files changed, 5 insertions(+), 18 deletions(-)

diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor
index ad2fb53dc4..0fdcb51291 100644
--- a/basis/math/intervals/intervals-tests.factor
+++ b/basis/math/intervals/intervals-tests.factor
@@ -83,8 +83,6 @@ IN: math.intervals.tests
     0 1 (a,b) 1 2 [a,b] interval-union 0 2 (a,b] =
 ] unit-test
 
-[ f ] [ 0 1 (a,b) f interval-union ] unit-test
-
 [ t ] [
     0 1 (a,b) 0 1 [a,b] interval-intersect 0 1 (a,b) =
 ] unit-test
diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor
index 213bfce354..33430e83c3 100644
--- a/basis/math/intervals/intervals.factor
+++ b/basis/math/intervals/intervals.factor
@@ -115,14 +115,10 @@ TUPLE: interval { from read-only } { to read-only } ;
         { [ dup empty-interval eq? ] [ nip ] }
         { [ over empty-interval eq? ] [ drop ] }
         [
-            2dup and [
-                [ interval>points ] bi@ swapd
-                [ [ swap endpoint< ] most ]
-                [ [ swap endpoint> ] most ] 2bi*
-                <interval>
-            ] [
-                or
-            ] if
+            [ interval>points ] bi@ swapd
+            [ [ swap endpoint< ] most ]
+            [ [ swap endpoint> ] most ] 2bi*
+            <interval>
         ]
     } cond ;
 
@@ -133,13 +129,7 @@ TUPLE: interval { from read-only } { to read-only } ;
     {
         { [ dup empty-interval eq? ] [ drop ] }
         { [ over empty-interval eq? ] [ nip ] }
-        [
-            2dup and [
-                [ interval>points 2array ] bi@ append points>interval
-            ] [
-                2drop f
-            ] if
-        ]
+        [ [ interval>points 2array ] bi@ append points>interval ]
     } cond ;
 
 : interval-subset? ( i1 i2 -- ? )
@@ -183,7 +173,6 @@ TUPLE: interval { from read-only } { to read-only } ;
 : interval-length ( int -- n )
     {
         { [ dup empty-interval eq? ] [ drop 0 ] }
-        { [ dup not ] [ drop 0 ] }
         [ interval>points [ first ] bi@ swap - ]
     } cond ;
 

From 63a9975a0eb3064177de6b1496be36e32cadc329 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 13:13:37 -0600
Subject: [PATCH 192/318] Support inline, foldable, flushable on methods; add
 declarations in a couple of places for ricing purposes

---
 basis/io/ports/ports.factor       |  4 ++--
 core/generic/parser/parser.factor | 12 ++++++------
 core/words/words.factor           |  2 +-
 3 files changed, 9 insertions(+), 9 deletions(-)

diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor
index 6ee982fcda..9fb9755d4b 100644
--- a/basis/io/ports/ports.factor
+++ b/basis/io/ports/ports.factor
@@ -39,7 +39,7 @@ HOOK: (wait-to-read) io-backend ( port -- )
 
 M: input-port stream-read1
     dup check-disposed
-    dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ;
+    dup wait-to-read [ drop f ] [ buffer>> buffer-pop ] if ; inline
 
 : read-step ( count port -- byte-array/f )
     dup wait-to-read [ 2drop f ] [ buffer>> buffer-read ] if ;
@@ -105,7 +105,7 @@ TUPLE: output-port < buffered-port ;
 M: output-port stream-write1
     dup check-disposed
     1 over wait-to-write
-    buffer>> byte>buffer ;
+    buffer>> byte>buffer ; inline
 
 M: output-port stream-write
     dup check-disposed
diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor
index 70f57f85e3..7380399b5c 100644
--- a/core/generic/parser/parser.factor
+++ b/core/generic/parser/parser.factor
@@ -8,7 +8,7 @@ ERROR: not-in-a-method-error ;
 : CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
 
 : create-method-in ( class generic -- method )
-    create-method f set-word dup save-location ;
+    create-method dup set-word dup save-location ;
 
 : CREATE-METHOD ( -- method )
     scan-word bootstrap-word scan-word create-method-in ;
@@ -18,11 +18,11 @@ SYMBOL: current-generic
 
 : with-method-definition ( quot -- parsed )
     [
-        >r
-        [ "method-class" word-prop current-class set ]
-        [ "method-generic" word-prop current-generic set ]
-        [ ] tri
-        r> call
+        [
+            [ "method-class" word-prop current-class set ]
+            [ "method-generic" word-prop current-generic set ]
+            [ ] tri
+        ] dip call
     ] with-scope ; inline
 
 : (M:) ( method def -- )
diff --git a/core/words/words.factor b/core/words/words.factor
index ce1fdf194b..8a4f7e7bd2 100644
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -262,7 +262,7 @@ M: word forget*
     ] if ;
 
 M: word hashcode*
-    nip 1 slot { fixnum } declare ;
+    nip 1 slot { fixnum } declare ; foldable
 
 M: word literalize <wrapper> ;
 

From 55902df52916ae14a6b84b543d9727b8ff900289 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 13:13:47 -0600
Subject: [PATCH 193/318] Fix indentation

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

diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor
index c00087fc9f..5a8e7595b5 100755
--- a/extra/benchmark/benchmark.factor
+++ b/extra/benchmark/benchmark.factor
@@ -6,12 +6,12 @@ continuations debugger ;
 IN: benchmark
 
 : run-benchmark ( vocab -- result )
-  [ [ require ] [ [ run ] benchmark ] bi ] curry
-  [ error. f ] recover ;
+    [ [ require ] [ [ run ] benchmark ] bi ] curry
+    [ error. f ] recover ;
 
 : run-benchmarks ( -- assoc )
-  "benchmark" all-child-vocabs-seq
-  [ dup run-benchmark ] { } map>assoc ;
+    "benchmark" all-child-vocabs-seq
+    [ dup run-benchmark ] { } map>assoc ;
 
 : benchmarks. ( assoc -- )
     standard-table-style [

From 811026ce4d7b61863e51144b284ec99e59c5e6cd Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 6 Nov 2008 13:16:33 -0600
Subject: [PATCH 194/318] removing some uses of at* in favor of at, simplifying
 code

---
 basis/regexp/regexp-tests.factor        |  1 -
 basis/regexp/regexp.factor              |  2 --
 basis/regexp/traversal/traversal.factor | 11 +++++------
 3 files changed, 5 insertions(+), 9 deletions(-)

diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor
index 46696c8c0f..2339628801 100644
--- a/basis/regexp/regexp-tests.factor
+++ b/basis/regexp/regexp-tests.factor
@@ -331,4 +331,3 @@ IN: regexp-tests
 [ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
 
 [ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
-
diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor
index 73555fe953..083a48a470 100644
--- a/basis/regexp/regexp.factor
+++ b/basis/regexp/regexp.factor
@@ -92,7 +92,6 @@ IN: regexp
     reversed-regexp initial-option
     construct-regexp ;
 
-
 : parsing-regexp ( accum end -- accum )
     lexer get dup skip-blank
     [ [ index-from dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
@@ -112,7 +111,6 @@ IN: regexp
 : R{ CHAR: } parsing-regexp ; parsing
 : R| CHAR: | parsing-regexp ; parsing
 
-
 : find-regexp-syntax ( string -- prefix suffix )
     {
         { "R/ "  "/"  }
diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor
index 346d77e918..91c7ce16dc 100644
--- a/basis/regexp/traversal/traversal.factor
+++ b/basis/regexp/traversal/traversal.factor
@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators kernel math math.ranges
 quotations sequences regexp.parser regexp.classes fry arrays
-combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
+combinators.short-circuit regexp.utils prettyprint regexp.nfa
+shuffle ;
 IN: regexp.traversal
 
 TUPLE: dfa-traverser
@@ -23,8 +24,7 @@ TUPLE: dfa-traverser
     [ dfa-table>> ] [ dfa-traversal-flags>> ] bi
     dfa-traverser new
         swap >>traversal-flags
-        swap [ start-state>> >>current-state ] keep
-        >>dfa-table
+        swap [ start-state>> >>current-state ] [ >>dfa-table ] bi
         swap >>text
         t >>traverse-forward
         0 >>start-index
@@ -116,7 +116,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
     V{ } clone >>matches ;
 
 : match-literal ( transition from-state table -- to-state/f )
-    transitions>> at* [ at ] [ 2drop f ] if ;
+    transitions>> at at ;
 
 : match-class ( transition from-state table -- to-state/f )
     transitions>> at* [
@@ -124,8 +124,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
     ] [ drop ] if ;
 
 : match-default ( transition from-state table -- to-state/f )
-    [ nip ] dip transitions>> at*
-    [ t swap at* [ ] [ drop f ] if ] [ drop f ] if ;
+    nipd transitions>> at t swap at ;
 
 : match-transition ( obj from-state dfa -- to-state/f )
     { [ match-literal ] [ match-class ] [ match-default ] } 3|| ;

From 5a50046791aa36a76a3a835d26e17d6e55eb76b2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 13:20:27 -0600
Subject: [PATCH 195/318] Change to definition of >boolean broke unit test, so
 define an inverse for >boolean and not explicitly

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

diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor
index 7f55b609e3..dfef23b56a 100755
--- a/extra/inverse/inverse.factor
+++ b/extra/inverse/inverse.factor
@@ -131,6 +131,9 @@ MACRO: undo ( quot -- ) [undo] ;
 \ pick [ >r pick r> =/fail ] define-inverse
 \ tuck [ swapd [ =/fail ] keep ] define-inverse
 
+\ not [ not ] define-inverse
+\ >boolean [ { t f } memq? assure ] define-inverse
+
 \ >r [ r> ] define-inverse
 \ r> [ >r ] define-inverse
 

From b7dc7296dbe591acf682609d3ab797b68e261c9b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 6 Nov 2008 13:42:53 -0600
Subject: [PATCH 196/318] Implement stream-read on memory-streams. This allows
 alien>string to work with utf16 encoding

---
 basis/alien/strings/strings-tests.factor | 6 +++++-
 basis/io/streams/memory/memory.factor    | 8 +++++++-
 2 files changed, 12 insertions(+), 2 deletions(-)

diff --git a/basis/alien/strings/strings-tests.factor b/basis/alien/strings/strings-tests.factor
index 484809469f..c1a509041e 100644
--- a/basis/alien/strings/strings-tests.factor
+++ b/basis/alien/strings/strings-tests.factor
@@ -1,6 +1,6 @@
 USING: alien.strings tools.test kernel libc
 io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
-io.encodings.ascii alien ;
+io.encodings.ascii alien io.encodings.string ;
 IN: alien.strings.tests
 
 [ "\u0000ff" ]
@@ -28,3 +28,7 @@ unit-test
 ] unit-test
 
 [ f ] [ f utf8 alien>string ] unit-test
+
+[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
+
+[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test
diff --git a/basis/io/streams/memory/memory.factor b/basis/io/streams/memory/memory.factor
index daadbb0e81..20d9f4eb0c 100644
--- a/basis/io/streams/memory/memory.factor
+++ b/basis/io/streams/memory/memory.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors alien.accessors math io ;
+USING: kernel accessors alien alien.c-types alien.accessors math io ;
 IN: io.streams.memory
 
 TUPLE: memory-stream alien index ;
@@ -11,3 +11,9 @@ TUPLE: memory-stream alien index ;
 M: memory-stream stream-read1
     [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
     [ [ 1+ ] change-index drop ] bi ;
+
+M: memory-stream stream-read
+    [
+        [ index>> ] [ alien>> ] bi <displaced-alien>
+        swap memory>byte-array
+    ] [ [ + ] change-index drop ] 2bi ;

From 73f6691f759357a63171fcd40584bcdd350027a4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 6 Nov 2008 15:48:08 -0600
Subject: [PATCH 197/318] print out clickable pathnames in project euler

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

diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index 5192e23a27..d85e7e206d 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: definitions io io.files kernel math math.parser project-euler.ave-time
-    sequences vocabs vocabs.loader
+    sequences vocabs vocabs.loader prettyprint
     project-euler.001 project-euler.002 project-euler.003 project-euler.004
     project-euler.005 project-euler.006 project-euler.007 project-euler.008
     project-euler.009 project-euler.010 project-euler.011 project-euler.012
@@ -33,7 +33,7 @@ IN: project-euler
 
 : solution-path ( n -- str/f )
     number>euler "project-euler." prepend
-    vocab where dup [ first ] when ;
+    vocab where dup [ first <pathname> ] when ;
 
 PRIVATE>
 
@@ -43,8 +43,8 @@ PRIVATE>
 : run-project-euler ( -- )
     problem-prompt dup problem-solved? [
         dup number>euler "project-euler." prepend run
-        "Answer: " swap dup number? [ number>string ] when append print
-        "Source: " swap solution-path append print
+        "Answer: " write dup number? [ number>string ] when print
+        "Source: " write solution-path .
     ] [
         drop "That problem has not been solved yet..." print
     ] if ;

From 46aa56730b4a5c79cc326813026862b5a6e69649 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Thu, 6 Nov 2008 16:53:00 -0600
Subject: [PATCH 198/318] better parsing for anchors

---
 basis/regexp/parser/parser.factor | 44 ++++++++++++++++++++-----------
 1 file changed, 29 insertions(+), 15 deletions(-)

diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor
index d2ed346bf2..d04016b93a 100644
--- a/basis/regexp/parser/parser.factor
+++ b/basis/regexp/parser/parser.factor
@@ -233,15 +233,22 @@ ERROR: invalid-range a b ;
 SINGLETON: beginning-of-input
 SINGLETON: end-of-input
 
-! : beginning-of-input ( -- obj ) 
-: handle-front-anchor ( -- ) front-anchor push-stack ;
-: end-of-line ( -- obj )
-    end-of-input
+: newlines ( -- obj1 obj2 obj3 )
     CHAR: \r <constant>
     CHAR: \n <constant>
-    2dup 2array <concatenation> 4array <alternation> lookahead boa ;
+    2dup 2array <concatenation> ;
 
-: handle-back-anchor ( -- ) end-of-line push-stack ;
+: beginning-of-line ( -- obj )
+    beginning-of-input newlines 4array <alternation> lookbehind boa ;
+
+: end-of-line ( -- obj )
+    end-of-input newlines 4array <alternation> lookahead boa ;
+
+: handle-front-anchor ( -- )
+    get-multiline beginning-of-line beginning-of-input ? push-stack ;
+
+: handle-back-anchor ( -- )
+    get-multiline end-of-line end-of-input ? push-stack ;
 
 ERROR: bad-character-class obj ;
 ERROR: expected-posix-class ;
@@ -412,16 +419,11 @@ DEFER: handle-left-bracket
     [ [ push ] keep current-regexp get (>>stack) ]
     [ finish-regexp-parse push-stack ] bi* ;
 
-
 : parse-regexp-token ( token -- ? )
     {
-! todo: only match these at beginning/end of regexp
-        { CHAR: ^ [ handle-front-anchor t ] }
-        { CHAR: $ [ handle-back-anchor t ] }
-
-        { CHAR: . [ handle-dot t ] }
-        { CHAR: ( [ handle-left-parenthesis t ] }
+        { CHAR: ( [ handle-left-parenthesis t ] } ! handle (?..) at beginning?
         { CHAR: ) [ handle-right-parenthesis f ] }
+        { CHAR: . [ handle-dot t ] }
         { CHAR: | [ handle-pipe t ] }
         { CHAR: ? [ handle-question t ] }
         { CHAR: * [ handle-star t ] }
@@ -429,16 +431,28 @@ DEFER: handle-left-bracket
         { CHAR: { [ handle-left-brace t ] }
         { CHAR: [ [ handle-left-bracket t ] }
         { CHAR: \ [ handle-escape t ] }
-        [ <constant> push-stack t ]
+        [
+            dup CHAR: $ = peek1 f = and [
+                drop
+                handle-back-anchor f
+            ] [
+                <constant> push-stack t
+            ] if
+        ]
     } case ;
 
 : (parse-regexp) ( -- )
     read1 [ parse-regexp-token [ (parse-regexp) ] when ] when* ;
 
+: parse-regexp-beginning ( -- )
+    peek1 CHAR: ^ = [ drop1 handle-front-anchor ] when ;
+
 : parse-regexp ( regexp -- )
     dup current-regexp [
         raw>> [
-            <string-reader> [ (parse-regexp) ] with-input-stream
+            <string-reader> [
+                parse-regexp-beginning (parse-regexp)
+            ] with-input-stream
         ] unless-empty
         current-regexp get
         stack finish-regexp-parse

From d1f248dac67db2e6a6a68aa08301f1d384f039db Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@oberon.local>
Date: Thu, 6 Nov 2008 19:00:56 -0600
Subject: [PATCH 199/318] Fixing PowerPC backend: prolog register clobberage,
 spilling, and general stack frame usage. Add some lame tests for spilling

---
 .../cfg/stack-frame/stack-frame.factor        |  18 +-
 basis/compiler/tests/spilling.factor          | 343 ++++++++++++++++++
 basis/compiler/tests/templates.factor         | 163 +--------
 basis/cpu/ppc/ppc.factor                      | 112 +++---
 4 files changed, 414 insertions(+), 222 deletions(-)
 create mode 100644 basis/compiler/tests/spilling.factor

diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index 8d79a85b8f..ec9ffaba49 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math.order assocs kernel sequences
-combinators make cpu.architecture compiler.cfg.instructions
-compiler.cfg.registers ;
+combinators make classes words cpu.architecture
+compiler.cfg.instructions compiler.cfg.registers ;
 IN: compiler.cfg.stack-frame
 
 SYMBOL: frame-required?
@@ -24,16 +24,16 @@ M: ##stack-frame compute-stack-frame*
 M: ##call compute-stack-frame*
     word>> sub-primitive>> [ frame-required? on ] unless ;
 
-M: _gc compute-stack-frame*
-    drop frame-required? on ;
-
-M: _spill compute-stack-frame*
-    drop frame-required? on ;
-
 M: _spill-counts compute-stack-frame*
     counts>> stack-frame get (>>spill-counts) ;
 
-M: insn compute-stack-frame* drop ;
+M: insn compute-stack-frame*
+    class frame-required? word-prop [
+        frame-required? on
+    ] when ;
+
+\ _gc t frame-required? set-word-prop
+\ _spill t frame-required? set-word-prop
 
 : compute-stack-frame ( insns -- )
     frame-required? off
diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor
new file mode 100644
index 0000000000..156fdfff02
--- /dev/null
+++ b/basis/compiler/tests/spilling.factor
@@ -0,0 +1,343 @@
+USING: math.private kernel combinators accessors arrays
+generalizations float-arrays tools.test ;
+IN: compiler.tests
+
+: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
+    {
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+    } cleave ;
+
+[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
+[ 1.0 float-spill-bug ] unit-test
+
+[ t ] [ \ float-spill-bug compiled>> ] unit-test
+
+: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
+    {
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+    } cleave ;
+
+[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
+[ 1.0 float-fixnum-spill-bug ] unit-test
+
+[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
+
+: resolve-spill-bug ( a b -- c )
+    [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
+        nip 2 fixnum+fast
+    ] [
+        drop {
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+        } cleave
+        16 narray
+    ] if ;
+
+[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+
+[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
+
+! The above don't really test spilling...
+: spill-test-1 ( a -- b )
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast fixnum>float
+    3array
+    3array [ 8 narray ] dip 2array
+    [ 8 narray [ 8 narray ] dip 2array ] dip 2array
+    2array ;
+
+[
+    {
+        1
+        {
+            { { 2 3 4 5 6 7 8 9 } { 10 11 12 13 14 15 16 17 } }
+            {
+                { 18 19 20 21 22 23 24 25 }
+                { 26 27 { 28 29 30.0 } }
+            }
+        }
+    }
+] [ 1 spill-test-1 ] unit-test
+
+: spill-test-2 ( a -- b )
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float* ;
+
+[ t ] [ 1.0 spill-test-2 1.0 \ spill-test-2 def>> call = ] unit-test
diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/templates.factor
index 675e0cbc0f..de87ad8c00 100644
--- a/basis/compiler/tests/templates.factor
+++ b/basis/compiler/tests/templates.factor
@@ -3,7 +3,7 @@ kernel.private math hashtables.private math.private namespaces
 sequences sequences.private tools.test namespaces.private
 slots.private sequences.private byte-arrays alien
 alien.accessors layouts words definitions compiler.units io
-combinators vectors ;
+combinators vectors float-arrays ;
 IN: compiler.tests
 
 ! Originally, this file did black box testing of templating
@@ -206,167 +206,6 @@ TUPLE: my-tuple ;
     ] compile-call
 ] unit-test
 
-: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
-    {
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-    } cleave ;
-
-[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
-[ 1.0 float-spill-bug ] unit-test
-
-[ t ] [ \ float-spill-bug compiled>> ] unit-test
-
-: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
-    {
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-        [ dup float+ ]
-        [ float>fixnum dup fixnum+fast ]
-    } cleave ;
-
-[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
-[ 1.0 float-fixnum-spill-bug ] unit-test
-
-[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
-
-: resolve-spill-bug ( a b -- c )
-    [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
-        nip 2 fixnum+fast
-    ] [
-        drop {
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-            [ dup fixnum+fast ]
-        } cleave
-        16 narray
-    ] if ;
-
-[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
-
-[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
-
 ! Regression
 : dispatch-alignment-regression ( -- c )
     { tuple vector } 3 slot { word } declare
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index ad6c63b8c9..b60fd47b89 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -4,7 +4,8 @@ USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
 alien alien.c-types cpu.architecture cpu.ppc.assembler
 compiler.cfg.registers compiler.cfg.instructions
-compiler.constants compiler.codegen compiler.codegen.fixup ;
+compiler.constants compiler.codegen compiler.codegen.fixup
+compiler.cfg.intrinsics compiler.cfg.stack-frame ;
 IN: cpu.ppc
 
 ! PowerPC register assignments:
@@ -25,17 +26,21 @@ IN: cpu.ppc
         t "longlong" c-type (>>stack-align?)
         t "ulonglong" c-type (>>stack-align?)
     ] }
-} cond >>
+} cond
+
+enable-float-intrinsics
+
+\ ##integer>float t frame-required? set-word-prop
+\ ##float>integer t frame-required? set-word-prop >>
 
 M: ppc machine-registers
     {
         { int-regs T{ range f 2 26 1 } }
-        { double-float-regs T{ range f 0 28 1 } }
+        { double-float-regs T{ range f 0 29 1 } }
     } ;
 
 : scratch-reg 28 ; inline
-: fp-scratch-reg-1 29 ; inline
-: fp-scratch-reg-2 30 ; inline
+: fp-scratch-reg 30 ; inline
 
 M: ppc two-operand? f ;
 
@@ -71,12 +76,15 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
         { macosx [ 6 ] }
     } case cells ; foldable
 
-: lr-save ( -- n )
-    os {
-        { linux [ 1 ] }
-        { macosx [ 2 ] }
-    } case cells ; foldable
+! The start of the stack frame contains the size of this frame
+! as well as the currently executing XT
+: factor-area-size ( -- n ) 2 cells ; foldable
+: next-save ( n -- i ) cell - ;
+: xt-save ( n -- i ) 2 cells - ;
 
+! Next, we have the spill area as well as the FFI parameter area.
+! They overlap, since basic blocks with FFI calls will never
+! spill.
 : param@ ( n -- x ) reserved-area-size + ; inline
 
 : param-save-size ( -- n ) 8 cells ; foldable
@@ -84,19 +92,38 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
 : local@ ( n -- x )
     reserved-area-size param-save-size + + ; inline
 
-: factor-area-size ( -- n ) 2 cells ; foldable
+: spill-integer-base ( -- n )
+    stack-frame get spill-counts>> double-float-regs swap at
+    double-float-regs reg-size * ;
 
-: next-save ( n -- i ) cell - ;
+: spill-integer@ ( n -- offset )
+    cells spill-integer-base + param@ ;
 
-: xt-save ( n -- i ) 2 cells - ;
+: spill-float@ ( n -- offset )
+    double-float-regs reg-size * param@ ;
+
+! Some FP intrinsics need a temporary scratch area in the stack
+! frame, 8 bytes in size
+: scratch@ ( n -- offset )
+   stack-frame get total-size>>
+   factor-area-size -
+   param-save-size -
+   + ;
+
+! Finally we have the linkage area
+: lr-save ( -- n )
+    os {
+        { linux [ 1 ] }
+        { macosx [ 2 ] }
+    } case cells ; foldable
 
 M: ppc stack-frame-size ( stack-frame -- i )
     [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
     [ params>> ]
     [ return>> ]
     tri + +
-    reserved-area-size +
     param-save-size +
+    reserved-area-size +
     factor-area-size +
     4 cells align ;
 
@@ -219,19 +246,19 @@ M: ppc %div-float FDIV ;
 
 M:: ppc %integer>float ( dst src -- )
     HEX: 4330 scratch-reg LIS
-    scratch-reg 1 0 param@ STW
+    scratch-reg 1 0 scratch@ STW
     scratch-reg src MR
     scratch-reg dup HEX: 8000 XORIS
-    scratch-reg 1 cell param@ STW
-    fp-scratch-reg-2 1 0 param@ LFD
+    scratch-reg 1 4 scratch@ STW
+    dst 1 0 scratch@ LFD
     scratch-reg 4503601774854144.0 %load-indirect
-    fp-scratch-reg-2 scratch-reg float-offset LFD
-    fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
+    fp-scratch-reg scratch-reg float-offset LFD
+    dst dst fp-scratch-reg FSUB ;
 
 M:: ppc %float>integer ( dst src -- )
-    fp-scratch-reg-1 src FCTIWZ
-    fp-scratch-reg-2 1 0 param@ STFD
-    dst 1 4 param@ LWZ ;
+    fp-scratch-reg src FCTIWZ
+    fp-scratch-reg 1 0 scratch@ STFD
+    dst 1 4 scratch@ LWZ ;
 
 M: ppc %copy ( dst src -- ) MR ;
 
@@ -239,6 +266,10 @@ M: ppc %copy-float ( dst src -- ) FMR ;
 
 M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
 
+M:: ppc %box-float ( dst src temp -- )
+    dst 16 float temp %allot
+    src dst float-offset STFD ;
+
 M:: ppc %unbox-any-c-ptr ( dst src temp -- )
     [
         { "is-byte-array" "end" "start" } [ define-label ] each
@@ -370,12 +401,12 @@ M: ppc %gc
     "end" resolve-label ;
 
 M: ppc %prologue ( n -- )
-    0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this
+    0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
     0 MFLR
     1 1 pick neg ADDI
-    scratch-reg 1 pick xt-save STW
-    dup scratch-reg LI
-    scratch-reg 1 pick next-save STW
+    11 1 pick xt-save STW
+    dup 11 LI
+    11 1 pick next-save STW
     0 1 rot lr-save + STW ;
 
 M: ppc %epilogue ( n -- )
@@ -426,32 +457,11 @@ M: ppc %compare-branch (%compare) %branch ;
 M: ppc %compare-imm-branch (%compare-imm) %branch ;
 M: ppc %compare-float-branch (%compare-float) %branch ;
 
-: spill-integer-base ( stack-frame -- n )
-    [ params>> ] [ return>> ] bi + ;
+M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ;
+M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ;
 
-: stack@ 1 swap ; inline
-
-: spill-integer@ ( n -- reg offset )
-    cells
-    stack-frame get spill-integer-base
-    + stack@ ;
-
-: spill-float-base ( stack-frame -- n )
-    [ spill-counts>> int-regs swap at int-regs reg-size * ]
-    [ params>> ]
-    [ return>> ]
-    tri + + ;
-
-: spill-float@ ( n -- reg offset )
-    double-float-regs reg-size *
-    stack-frame get spill-float-base
-    + stack@ ;
-
-M: ppc %spill-integer ( src n -- ) spill-integer@ STW ;
-M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ;
-
-M: ppc %spill-float ( src n -- ) spill-float@ STFD ;
-M: ppc %reload-float ( dst n -- ) spill-float@ LFD ;
+M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ;
+M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ;
 
 M: ppc %loop-entry ;
 

From 8ec695332a69dd193754394e2ddd774add9962c6 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 6 Nov 2008 23:21:19 -0500
Subject: [PATCH 200/318] Add reverse haar wavelet transform and tests

---
 extra/math/haar/authors.txt       |  2 ++
 extra/math/haar/haar-tests.factor |  5 +++++
 extra/math/haar/haar.factor       | 23 +++++++++++++++++++----
 3 files changed, 26 insertions(+), 4 deletions(-)
 create mode 100644 extra/math/haar/authors.txt
 create mode 100644 extra/math/haar/haar-tests.factor

diff --git a/extra/math/haar/authors.txt b/extra/math/haar/authors.txt
new file mode 100644
index 0000000000..cf46c0ea5e
--- /dev/null
+++ b/extra/math/haar/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+Aaron Schaefer
diff --git a/extra/math/haar/haar-tests.factor b/extra/math/haar/haar-tests.factor
new file mode 100644
index 0000000000..9c9124bf17
--- /dev/null
+++ b/extra/math/haar/haar-tests.factor
@@ -0,0 +1,5 @@
+USING: math.haar tools.test ;
+IN: math.haar.tests
+
+[ { 3 2 -1 -2 3 0 4 1 } ] [ { 7 1 6 6 3 -5 4 2 } haar ] unit-test
+[ { 7 1 6 6 3 -5 4 2 } ] [ { 3 2 -1 -2 3 0 4 1 } rev-haar ] unit-test
diff --git a/extra/math/haar/haar.factor b/extra/math/haar/haar.factor
index f1bf87161c..f745721124 100644
--- a/extra/math/haar/haar.factor
+++ b/extra/math/haar/haar.factor
@@ -1,15 +1,30 @@
-! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/
-USING: sequences math kernel splitting grouping columns ;
+! Copyright (c) 2008 Slava Pestov, Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs columns grouping kernel math math.statistics math.vectors
+    sequences ;
 IN: math.haar
 
+! Haar Wavelet Transform -- http://dmr.ath.cx/gfx/haar/
+
+<PRIVATE
+
 : averages ( seq -- seq )
-    [ first2 + 2 / ] map ;
+    [ mean ] map ;
 
 : differences ( seq averages -- differences )
-    >r 0 <column> r> [ - ] 2map ;
+    [ 0 <column> ] dip v- ;
 
 : haar-step ( seq -- differences averages )
     2 group dup averages [ differences ] keep ;
 
+: rev-haar-step ( seq -- seq )
+    halves [ v+ ] [ v- ] 2bi zip concat ;
+
+PRIVATE>
+
 : haar ( seq -- seq )
     dup length 1 <= [ haar-step haar prepend ] unless ;
+
+: rev-haar ( seq -- seq )
+    dup length 2 > [ halves swap rev-haar prepend ] when rev-haar-step ;
+

From 67ce49dc594b234c8f7fc96c5814190009698380 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Fri, 7 Nov 2008 01:24:32 -0500
Subject: [PATCH 201/318] Update syntax for extra/math vocabs

---
 extra/math/algebra/algebra.factor             |   5 +-
 extra/math/combinatorics/combinatorics.factor |   2 +-
 extra/math/compare/compare.factor             |  24 ++--
 extra/math/derivatives/derivatives.factor     | 111 ++++++++----------
 extra/math/erato/erato.factor                 |  40 +++----
 extra/math/erato/summary.txt                  |   2 +-
 .../math/function-tools/function-tools.factor |  25 ++--
 .../matrices/elimination/elimination.factor   |  18 +--
 extra/math/matrices/matrices.factor           |   7 +-
 extra/math/miller-rabin/miller-rabin.factor   |   2 +-
 .../math/newtons-method/newtons-method.factor |   5 +-
 extra/math/secant-method/secant-method.factor |   5 +-
 12 files changed, 121 insertions(+), 125 deletions(-)

diff --git a/extra/math/algebra/algebra.factor b/extra/math/algebra/algebra.factor
index 8cccded26a..82a2578a7f 100644
--- a/extra/math/algebra/algebra.factor
+++ b/extra/math/algebra/algebra.factor
@@ -1,10 +1,9 @@
-! Copyright (c) 2007 Samuel Tardieu
+! Copyright (c) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.functions sequences fry ;
 IN: math.algebra
 
 : chinese-remainder ( aseq nseq -- x )
-  dup product
-    [
+    dup product [
         '[ _ over / [ swap gcd drop ] keep * * ] 2map sum
     ] keep rem ; foldable
diff --git a/extra/math/combinatorics/combinatorics.factor b/extra/math/combinatorics/combinatorics.factor
index 00a104b381..1bc692ca54 100644
--- a/extra/math/combinatorics/combinatorics.factor
+++ b/extra/math/combinatorics/combinatorics.factor
@@ -19,7 +19,7 @@ IN: math.combinatorics
     0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
 
 : (>permutation) ( seq n -- seq )
-    [ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ;
+    [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
 
 : >permutation ( factoradic -- permutation )
     reverse 1 cut [ (>permutation) ] each ;
diff --git a/extra/math/compare/compare.factor b/extra/math/compare/compare.factor
index d19dac3d2b..826f0ecf16 100644
--- a/extra/math/compare/compare.factor
+++ b/extra/math/compare/compare.factor
@@ -1,21 +1,19 @@
-! Copyright (C) 2008 John Benediktsson
+! Copyright (C) 2008 John Benediktsson.
 ! See http://factorcode.org/license.txt for BSD license
-
 USING: math math.order kernel ;
+IN: math.compare
 
-IN: math.compare 
+: absmin ( a b -- x )
+    [ [ abs ] bi@ < ] 2keep ? ;
 
-: absmin ( a b -- x ) 
-   [ [ abs ] bi@ < ] 2keep ? ;
+: absmax ( a b -- x )
+    [ [ abs ] bi@ > ] 2keep ? ;
 
-: absmax ( a b -- x ) 
-   [ [ abs ] bi@ > ] 2keep ? ;
+: posmax ( a b -- x )
+    0 max max ;
 
-: posmax ( a b -- x ) 
-   0 max max ;
-
-: negmin ( a b -- x ) 
-   0 min min ;
+: negmin ( a b -- x )
+    0 min min ;
 
 : clamp ( a value b -- x )
-   min max ; 
+    min max ;
diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor
index b7612e112b..7922a48a6b 100644
--- a/extra/math/derivatives/derivatives.factor
+++ b/extra/math/derivatives/derivatives.factor
@@ -1,6 +1,7 @@
-USING: kernel continuations combinators sequences math
-      math.order math.ranges accessors float-arrays ;
-
+! Copyright (c) 2008 Reginald Keith Ford II, Eduardo Cavazos.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations combinators sequences math math.order math.ranges
+    accessors float-arrays ;
 IN: math.derivatives
 
 TUPLE: state x func h err i j errt fac hh ans a done ;
@@ -20,7 +21,8 @@ TUPLE: state x func h err i j errt fac hh ans a done ;
 : a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ;
 
 : check-h ( state -- state )
- dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
+    dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
+
 : init-a     ( state -- state ) ntab [ ntab <float-array> ] replicate >>a ;
 : init-hh    ( state -- state ) dup h>> >>hh ;
 : init-err   ( state -- state ) big >>err ;
@@ -30,75 +32,66 @@ TUPLE: state x func h err i j errt fac hh ans a done ;
 
 ! If error is decreased, save the improved answer
 : error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ;
+
 : save-improved-answer ( state -- state )
- dup err>>   >>errt
- dup a[j][i] >>ans ;
+    dup err>>   >>errt
+    dup a[j][i] >>ans ;
 
 ! If higher order is worse by a significant factor SAFE, then quit early.
 : check-safe ( state -- state )
- dup
- [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >=
-   [ t >>done ]
- when ;
+    dup [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ]
+    [ err>> safe * ] bi >= [ t >>done ] when ;
+
 : x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ;
 : x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ;
+
 : limit-approx ( state -- val )
- [
-   [ [ x+hh ] [ func>> ] bi call ]
-   [ [ x-hh ] [ func>> ] bi call ]
-   bi -
- ]
- [ hh>> 2.0 * ]
- bi / ;
+    [
+        [ [ x+hh ] [ func>> ] bi call ]
+        [ [ x-hh ] [ func>> ] bi call ] bi -
+    ] [ hh>> 2.0 * ] bi / ;
+
 : a[0][0]! ( state -- state )
- { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+    { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+
 : a[0][i]! ( state -- state )
- { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+    { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+
 : a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ;
+
 : new-a[j][i] ( state -- val )
- [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
- [ fac>> 1.0 - ]
- bi / ;
+    [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
+    [ fac>> 1.0 - ] bi / ;
+
 : a[j][i]! ( state -- state )
- { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
+    { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
 
 : update-errt ( state -- state )
- dup
-    [ [ a[j][i] ] [ a[j-1][i]   ] bi - abs ]
-    [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ]
- bi max
- >>errt ;
+    dup [ [ a[j][i] ] [ a[j-1][i] ] bi - abs ]
+    [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ] bi max >>errt ;
 
 : not-done? ( state -- state ? ) dup done>> not ;
 
 : derive ( state -- state )
- init-a
- check-h
- init-hh
- a[0][0]!
- init-err
- 1 ntab [a,b)
-  [
-     >>i
-     not-done?
-       [
-         update-hh
-         a[0][i]!
-         reset-fac
-         1 over i>> [a,b]
-           [
-             >>j
-             a[j][i]!
-             update-fac
-             update-errt
-             error-decreased? [ save-improved-answer ] when
-           ]
-         each
-         check-safe
-       ]
-     when
-   ]
- each ;
+    init-a
+    check-h
+    init-hh
+    a[0][0]!
+    init-err
+    1 ntab [a,b) [
+        >>i not-done? [
+            update-hh
+            a[0][i]!
+            reset-fac
+            1 over i>> [a,b] [
+                >>j
+                a[j][i]!
+                update-fac
+                update-errt
+                error-decreased? [ save-improved-answer ] when
+            ] each check-safe
+        ] when
+   ] each ;
 
 : derivative-state ( x func h err -- state )
     state new
@@ -112,11 +105,7 @@ TUPLE: state x func h err i j errt fac hh ans a done ;
 ! h should be small enough to give the correct sgn(f'(x))
 ! err is the max tolerance of gain in error for a single iteration-
 : (derivative) ( x func h err -- ans error )
- derivative-state
- derive
-    [ ans>> ]
-    [ errt>> ]
- bi ;
+    derivative-state derive [ ans>> ] [ errt>> ] bi ;
 
-: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ; 
+: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ;
 : derivative-func ( func -- der ) [ derivative ] curry ;
diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor
index 4c6675e8f1..894905e405 100644
--- a/extra/math/erato/erato.factor
+++ b/extra/math/erato/erato.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
-       math.ranges sequences accessors ;
+USING: accessors bit-arrays fry kernel lists.lazy math math.functions
+    math.primes.list math.ranges sequences ;
 IN: math.erato
 
 <PRIVATE
@@ -9,35 +9,35 @@ IN: math.erato
 TUPLE: erato limit bits latest ;
 
 : ind ( n -- i )
-  2/ 1- ; inline
+    2/ 1- ; inline
 
 : is-prime ( n limit -- bool )
-  [ ind ] [ bits>> ] bi* nth ; inline
+    [ ind ] [ bits>> ] bi* nth ; inline
 
 : indices ( n erato -- range )
-  limit>> ind over 3 * ind swap rot <range> ;
+    limit>> ind over 3 * ind swap rot <range> ;
 
 : mark-multiples ( n erato -- )
-  over sq over limit>> <=
-  [ [ indices ] keep bits>> [ f -rot set-nth ] curry each ] [ 2drop ] if ;
+    2dup [ sq ] [ limit>> ] bi* <= [
+        [ indices ] keep bits>> '[ _ f -rot set-nth ] each
+    ] [ 2drop ] if ;
 
 : <erato> ( n -- erato )
-  dup ind 1+ <bit-array> 1 over set-bits erato boa ;
+    dup ind 1+ <bit-array> dup set-bits 1 erato boa ;
 
 : next-prime ( erato -- prime/f )
-  [ 2 + ] change-latest [ latest>> ] keep
-  2dup limit>> <=
-  [
-    2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
-  ] [
-    2drop f
-  ] if ;
+    [ 2 + ] change-latest [ latest>> ] keep
+    2dup limit>> <= [
+        2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
+    ] [
+        2drop f
+    ] if ;
 
 PRIVATE>
 
 : lerato ( n -- lazy-list )
-  dup 1000003 < [
-    0 primes-under-million seq>list swap [ <= ] curry lwhile
-  ] [
-    <erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
-  ] if ;
+    dup 1000003 < [
+        0 primes-under-million seq>list swap '[ _ <= ] lwhile
+    ] [
+        <erato> 2 [ drop next-prime ] with lfrom-by [ ] lwhile
+    ] if ;
diff --git a/extra/math/erato/summary.txt b/extra/math/erato/summary.txt
index e8982fa3e0..ee15b7e06f 100644
--- a/extra/math/erato/summary.txt
+++ b/extra/math/erato/summary.txt
@@ -1 +1 @@
-Sieve of Eratosthene
+Sieve of Eratosthenes
diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor
index ec93a0891a..3bc785c1b6 100644
--- a/extra/math/function-tools/function-tools.factor
+++ b/extra/math/function-tools/function-tools.factor
@@ -1,9 +1,18 @@
-! Copyright © 2008 Reginald Keith Ford II
-! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions
-
+! Copyright (c) 2008 Reginald Keith Ford II.
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math arrays sequences sequences.lib ;
-IN: math.function-tools 
-: difference-func ( func func -- func ) [ bi - ] 2curry ; inline
-: eval ( x func -- pt ) dupd call 2array ; inline
-: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline
-: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline
+IN: math.function-tools
+
+! Tools for quickly comparing, transforming, and evaluating mathematical functions
+
+: difference-func ( func func -- func )
+    [ bi - ] 2curry ; inline
+
+: eval ( x func -- pt )
+    dupd call 2array ; inline
+
+: eval-inverse ( y func -- pt )
+    dupd call swap 2array ; inline
+
+: eval3d ( x y func -- pt )
+    [ 2dup ] dip call 3array ; inline
diff --git a/extra/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor
index 6e83a61eb3..0368dd5286 100755
--- a/extra/math/matrices/elimination/elimination.factor
+++ b/extra/math/matrices/elimination/elimination.factor
@@ -21,17 +21,17 @@ SYMBOL: matrix
 : cols ( -- n ) 0 nth-row length ;
 
 : skip ( i seq quot -- n )
-    over >r find-from drop r> length or ; inline
+    over [ find-from drop ] dip length or ; inline
 
 : first-col ( row# -- n )
     #! First non-zero column
     0 swap nth-row [ zero? not ] skip ;
 
 : clear-scale ( col# pivot-row i-row -- n )
-    >r over r> nth dup zero? [
+    [ over ] dip nth dup zero? [
         3drop 0
     ] [
-        >r nth dup zero? r> swap [
+        [ nth dup zero? ] dip swap [
             2drop 0
         ] [
             swap / neg
@@ -39,13 +39,13 @@ SYMBOL: matrix
     ] if ;
 
 : (clear-col) ( col# pivot-row i -- )
-    [ [ clear-scale ] 2keep >r n*v r> v+ ] change-row ;
+    [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
 
 : rows-from ( row# -- slice )
     rows dup <slice> ;
 
 : clear-col ( col# row# rows -- )
-    >r nth-row r> [ >r 2dup r> (clear-col) ] each 2drop ;
+    [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
 
 : do-row ( exchange-with row# -- )
     [ exchange-rows ] keep
@@ -53,7 +53,7 @@ SYMBOL: matrix
     dup 1+ rows-from clear-col ;
 
 : find-row ( row# quot -- i elt )
-    >r rows-from r> find ; inline
+    [ rows-from ] dip find ; inline
 
 : pivot-row ( col# row# -- n )
     [ dupd nth-row nth zero? not ] find-row 2nip ;
@@ -61,7 +61,7 @@ SYMBOL: matrix
 : (echelon) ( col# row# -- )
     over cols < over rows < and [
         2dup pivot-row [ over do-row 1+ ] when*
-        >r 1+ r> (echelon)
+        [ 1+ ] dip (echelon)
     ] [
         2drop
     ] if ;
@@ -86,10 +86,10 @@ SYMBOL: matrix
     ] with-matrix ;
 
 : basis-vector ( row col# -- )
-    >r clone r>
+    [ clone ] dip
     [ swap nth neg recip ] 2keep
     [ 0 spin set-nth ] 2keep
-    >r n*v r>
+    [ n*v ] dip
     matrix get set-nth ;
 
 : nullspace ( matrix -- seq )
diff --git a/extra/math/matrices/matrices.factor b/extra/math/matrices/matrices.factor
index 529ddb083a..0088b17372 100755
--- a/extra/math/matrices/matrices.factor
+++ b/extra/math/matrices/matrices.factor
@@ -1,7 +1,6 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences math math.functions
-math.vectors math.order ;
+USING: arrays kernel math math.order math.vectors sequences ;
 IN: math.matrices
 
 ! Matrices
@@ -29,8 +28,8 @@ IN: math.matrices
 : m.v ( m v -- v ) [ v. ] curry map ;
 : m.  ( m m -- m ) flip [ swap m.v ] curry map ;
 
-: mmin ( m -- n ) >r 1/0. r> [ [ min ] each ] each ;
-: mmax ( m -- n ) >r -1/0. r> [ [ max ] each ] each ;
+: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
+: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
 : mnorm ( m -- n ) dup mmax abs m/n ;
 
 <PRIVATE
diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor
index 45665c701d..3045a35836 100755
--- a/extra/math/miller-rabin/miller-rabin.factor
+++ b/extra/math/miller-rabin/miller-rabin.factor
@@ -12,7 +12,7 @@ IN: math.miller-rabin
 TUPLE: positive-even-expected n ;
 
 : (factor-2s) ( r s -- r s )
-    dup even? [ -1 shift >r 1+ r> (factor-2s) ] when ;
+    dup even? [ -1 shift [ 1+ ] dip (factor-2s) ] when ;
 
 : factor-2s ( n -- r s )
     #! factor an integer into s * 2^r
diff --git a/extra/math/newtons-method/newtons-method.factor b/extra/math/newtons-method/newtons-method.factor
index 269eae2538..4b53b1222d 100644
--- a/extra/math/newtons-method/newtons-method.factor
+++ b/extra/math/newtons-method/newtons-method.factor
@@ -1,9 +1,10 @@
-! Copyright © 2008 Reginald Keith Ford II
+! Copyright (c) 2008 Reginald Keith Ford II.
 ! See http://factorcode.org/license.txt for BSD license.
-! Newton's Method of approximating roots
 USING: kernel math math.derivatives ;
 IN: math.newtons-method
 
+! Newton's method of approximating roots
+
 <PRIVATE
 
 : newton-step ( x function -- x2 )
diff --git a/extra/math/secant-method/secant-method.factor b/extra/math/secant-method/secant-method.factor
index ad52c0cd4a..0d32562241 100644
--- a/extra/math/secant-method/secant-method.factor
+++ b/extra/math/secant-method/secant-method.factor
@@ -1,9 +1,10 @@
-! Copyright © 2008 Reginald Keith Ford II
+! Copyright (c) 2008 Reginald Keith Ford II.
 ! See http://factorcode.org/license.txt for BSD license.
-! Secant Method of approximating roots
 USING: kernel math math.function-tools math.points math.vectors ;
 IN: math.secant-method
 
+! Secant method of approximating roots
+
 <PRIVATE
 
 : secant-solution ( x1 x2 function -- solution )

From 2bd1723cc1206f14073624e0ea1b824506a5423b Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Fri, 7 Nov 2008 01:25:18 -0500
Subject: [PATCH 202/318] Rerun ave-time of PE #43 after constant space change

---
 extra/project-euler/043/043.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index 37118b88a3..3b330dbe4b 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -59,7 +59,7 @@ PRIVATE>
     ] reduce-permutations ;
 
 ! [ euler043 ] time
-! 104526 ms run / 42735 ms GC time
+! 60280 ms run / 59 ms GC time
 
 
 ! ALTERNATE SOLUTIONS

From 2fafae50132d4682ada799a9314b59a100272572 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Fri, 7 Nov 2008 01:35:17 -0500
Subject: [PATCH 203/318] Refactor and clean up of math.fft

---
 extra/math/fft/fft.factor | 43 ++++++++++++++++++++++++++++++---------
 1 file changed, 33 insertions(+), 10 deletions(-)

diff --git a/extra/math/fft/fft.factor b/extra/math/fft/fft.factor
index b82ecb6b2c..7dfdc0bcfc 100644
--- a/extra/math/fft/fft.factor
+++ b/extra/math/fft/fft.factor
@@ -1,15 +1,38 @@
-! Fast Fourier Transform, copyright (C) 2007 Hans Schmid
-! http://dressguardmeister.blogspot.com/2007/01/fft.html
-USING: arrays sequences math math.vectors math.constants
-math.functions kernel splitting grouping columns ;
+! Copyright (c) 2007 Hans Schmid.
+! See http://factorcode.org/license.txt for BSD license.
+USING: columns grouping kernel math math.constants math.functions math.vectors
+    sequences ;
 IN: math.fft
 
+! Fast Fourier Transform
+
+<PRIVATE
+
 : n^v ( n v -- w ) [ ^ ] with map ;
+
+: omega ( n -- n' )
+    recip -2 pi i* * * exp ;
+
+: twiddle ( seq -- seq )
+    dup length [ omega ] [ n^v ] bi v* ;
+
+PRIVATE>
+
+DEFER: fft
+
+: two ( seq -- seq )
+    fft 2 v/n dup append ;
+
+<PRIVATE
+
 : even ( seq -- seq ) 2 group 0 <column> ;
 : odd ( seq -- seq ) 2 group 1 <column> ;
-DEFER: fft
-: two ( seq -- seq ) fft 2 v/n dup append ;
-: omega ( n -- n' ) recip -2 pi i* * * exp ;
-: twiddle ( seq -- seq ) dup length dup omega swap n^v v* ;
-: (fft) ( seq -- seq ) dup odd two twiddle swap even two v+ ;
-: fft ( seq -- seq ) dup length 1 = [ (fft) ] unless ;
+
+: (fft) ( seq -- seq )
+    [ odd two twiddle ] [ even two ] bi v+ ;
+
+PRIVATE>
+
+: fft ( seq -- seq )
+    dup length 1 = [ (fft) ] unless ;
+

From 380cd2d3b061e2e378713215b894ae2156da04cd Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Fri, 7 Nov 2008 01:36:02 -0500
Subject: [PATCH 204/318] Clean up of math.finance

---
 extra/math/finance/finance.factor | 15 ++++++---------
 1 file changed, 6 insertions(+), 9 deletions(-)

diff --git a/extra/math/finance/finance.factor b/extra/math/finance/finance.factor
index db300a3b70..f006e6aee7 100644
--- a/extra/math/finance/finance.factor
+++ b/extra/math/finance/finance.factor
@@ -1,18 +1,16 @@
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
+! Copyright (C) 2008 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs kernel grouping sequences shuffle
 math math.functions math.statistics math.vectors ;
-
 IN: math.finance
 
 <PRIVATE
 
-: weighted ( x y a -- z ) 
+: weighted ( x y a -- z )
     tuck [ * ] [ 1 swap - * ] 2bi* + ;
 
-: a ( n -- a ) 
-    1 + 2 swap / ;
+: a ( n -- a )
+    1+ 2 swap / ;
 
 PRIVATE>
 
@@ -26,6 +24,5 @@ PRIVATE>
     rot dup ema [ swap ema ] dip v- ;
 
 : momentum ( seq n -- newseq )
-    2dup tail-slice -rot swap [ length ] keep
-    [ - neg ] dip swap head-slice v- ;
+    [ tail-slice ] 2keep [ dup length ] dip - head-slice v- ;
 

From e45df2e89c006669e59bb7362c46556b46b2a5a0 Mon Sep 17 00:00:00 2001
From: unknown <Administrator@.(none)>
Date: Fri, 7 Nov 2008 20:25:31 -0600
Subject: [PATCH 205/318] Fix bignums for Win64

---
 vm/bignum.c | 27 ++++++++++-----------------
 vm/bignum.h |  8 ++------
 2 files changed, 12 insertions(+), 23 deletions(-)

diff --git a/vm/bignum.c b/vm/bignum.c
index d92f665354..72616afbc5 100644
--- a/vm/bignum.c
+++ b/vm/bignum.c
@@ -1,7 +1,7 @@
 /* :tabSize=2:indentSize=2:noTabs=true:
 
 Copyright (C) 1989-94 Massachusetts Institute of Technology
-Portions copyright (C) 2004-2007 Slava Pestov
+Portions copyright (C) 2004-2008 Slava Pestov
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -45,6 +45,7 @@ MIT in each case. */
  *  - Remove unused functions
  *  - Add local variable GC root recording
  *  - Remove s48 prefix from function names
+ *  - Various fixes for Win64
  */
 
 #include "master.h"
@@ -366,8 +367,6 @@ bignum_remainder(bignum_type numerator, bignum_type denominator)
 /* all below allocate memory */
 FOO_TO_BIGNUM(cell,CELL,CELL)
 FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL)
-FOO_TO_BIGNUM(long,long,unsigned long)
-FOO_TO_BIGNUM(ulong,unsigned long,unsigned long)
 FOO_TO_BIGNUM(long_long,s64,u64)
 FOO_TO_BIGNUM(ulong_long,u64,u64)
 
@@ -389,8 +388,6 @@ FOO_TO_BIGNUM(ulong_long,u64,u64)
 /* all of the below allocate memory */
 BIGNUM_TO_FOO(cell,CELL,CELL);
 BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL);
-BIGNUM_TO_FOO(long,long,unsigned long)
-BIGNUM_TO_FOO(ulong,unsigned long,unsigned long)
 BIGNUM_TO_FOO(long_long,s64,u64)
 BIGNUM_TO_FOO(ulong_long,u64,u64)
 
@@ -435,7 +432,7 @@ double_to_bignum(double x)
     bignum_digit_type digit;
     int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
     if (odd_bits > 0)
-      DTB_WRITE_DIGIT (1L << odd_bits);
+      DTB_WRITE_DIGIT ((F_FIXNUM)1 << odd_bits);
     while (start < scan)
       {
         if (significand == 0)
@@ -1117,7 +1114,7 @@ bignum_destructive_normalization(bignum_type source, bignum_type target,
   bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
   bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
   int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
-  bignum_digit_type mask = ((1L << shift_right) - 1);
+  bignum_digit_type mask = (((CELL)1 << shift_right) - 1);
   while (scan_source < end_source)
     {
       digit = (*scan_source++);
@@ -1139,7 +1136,7 @@ bignum_destructive_unnormalization(bignum_type bignum, int shift_right)
   bignum_digit_type digit;
   bignum_digit_type carry = 0;
   int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
-  bignum_digit_type mask = ((1L << shift_right) - 1);
+  bignum_digit_type mask = (((F_FIXNUM)1 << shift_right) - 1);
   while (start < scan)
     {
       digit = (*--scan);
@@ -1489,7 +1486,7 @@ bignum_bitwise_not(bignum_type x)
 
 /* allocates memory */
 bignum_type
-bignum_arithmetic_shift(bignum_type arg1, long n)
+bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n)
 {
   if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
     return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
@@ -1550,14 +1547,14 @@ bignum_bitwise_xor(bignum_type arg1, bignum_type arg2)
 /* ash for the magnitude */
 /* assume arg1 is a big number, n is a long */
 bignum_type
-bignum_magnitude_ash(bignum_type arg1, long n)
+bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n)
 {
   bignum_type result = NULL;
   bignum_digit_type *scan1;
   bignum_digit_type *scanr;
   bignum_digit_type *end;
 
-  long digit_offset,bit_offset;
+  F_FIXNUM digit_offset,bit_offset;
 
   if (BIGNUM_ZERO_P (arg1)) return (arg1);
 
@@ -1642,10 +1639,6 @@ bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
   while (scanr < endr) {
     digit1 = (scan1 < end1) ? *scan1++ : 0;
     digit2 = (scan2 < end2) ? *scan2++ : 0;
-    /*
-    fprintf(stderr, "[pospos op = %d, i = %ld, d1 = %lx, d2 = %lx]\n",
-            op, endr - scanr, digit1, digit2);
-            */
     *scanr++ = (op == AND_OP) ? digit1 & digit2 :
                (op == IOR_OP) ? digit1 | digit2 :
                                 digit1 ^ digit2;
@@ -1856,8 +1849,8 @@ digit_stream_to_bignum(unsigned int n_digits,
     return (BIGNUM_ZERO ());
   if (n_digits == 1)
     {
-      long digit = ((long) ((*producer) (0)));
-      return (long_to_bignum (negative_p ? (- digit) : digit));
+      F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0)));
+      return (fixnum_to_bignum (negative_p ? (- digit) : digit));
     }
   {
     bignum_length_type length;
diff --git a/vm/bignum.h b/vm/bignum.h
index 3e6fd9f3ec..02309cad34 100644
--- a/vm/bignum.h
+++ b/vm/bignum.h
@@ -55,14 +55,10 @@ bignum_type bignum_quotient(bignum_type, bignum_type);
 bignum_type bignum_remainder(bignum_type, bignum_type);
 DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM);
 DLLEXPORT bignum_type cell_to_bignum(CELL);
-DLLEXPORT bignum_type long_to_bignum(long);
 DLLEXPORT bignum_type long_long_to_bignum(s64 n);
 DLLEXPORT bignum_type ulong_long_to_bignum(u64 n);
-DLLEXPORT bignum_type ulong_to_bignum(unsigned long);
 F_FIXNUM bignum_to_fixnum(bignum_type);
 CELL bignum_to_cell(bignum_type);
-long bignum_to_long(bignum_type);
-unsigned long bignum_to_ulong(bignum_type);
 s64 bignum_to_long_long(bignum_type);
 u64 bignum_to_ulong_long(bignum_type);
 bignum_type double_to_bignum(double);
@@ -71,7 +67,7 @@ double bignum_to_double(bignum_type);
 /* Added bitwise operators. */
 
 DLLEXPORT bignum_type bignum_bitwise_not(bignum_type),
-                   bignum_arithmetic_shift(bignum_type, long),
+                   bignum_arithmetic_shift(bignum_type, F_FIXNUM),
                    bignum_bitwise_and(bignum_type, bignum_type),
                    bignum_bitwise_ior(bignum_type, bignum_type),
                    bignum_bitwise_xor(bignum_type, bignum_type);
@@ -116,7 +112,7 @@ bignum_type bignum_maybe_new_sign(bignum_type, int);
 void bignum_destructive_copy(bignum_type, bignum_type);
 
 /* Added for bitwise operations. */
-bignum_type bignum_magnitude_ash(bignum_type arg1, long n);
+bignum_type bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n);
 bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type);
 bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type);
 bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type);

From 7365959f013ee1d9757e114283943732f6ceb5df Mon Sep 17 00:00:00 2001
From: unknown <Administrator@.(none)>
Date: Fri, 7 Nov 2008 20:33:32 -0600
Subject: [PATCH 206/318] Starting work on Win64 port

---
 Makefile                                |  2 +-
 basis/alien/c-types/c-types.factor      |  2 +-
 basis/bootstrap/image/image.factor      |  2 +-
 basis/cpu/x86/32/32.factor              |  2 +
 basis/cpu/x86/32/bootstrap.factor       |  1 +
 basis/cpu/x86/64/64.factor              | 47 ++++++++++---------
 basis/cpu/x86/64/bootstrap.factor       |  2 -
 basis/cpu/x86/64/unix/bootstrap.factor  | 12 +++++
 basis/cpu/x86/64/unix/unix.factor       | 12 +++++
 basis/cpu/x86/64/winnt/bootstrap.factor | 12 +++++
 basis/cpu/x86/64/winnt/winnt.factor     | 17 +++++++
 basis/cpu/x86/bootstrap.factor          | 14 +++---
 basis/cpu/x86/x86.factor                | 10 ++--
 vm/Config.windows.nt.x86.64             |  2 +-
 vm/callstack.c                          |  2 +
 vm/cpu-x86.32.S                         |  1 +
 vm/cpu-x86.64.S                         | 61 +++++++++++++++++++------
 vm/cpu-x86.S                            | 27 ++++++-----
 vm/data_gc.c                            |  6 +++
 vm/errors.c                             |  6 +--
 vm/factor.c                             |  1 -
 vm/factor.rs                            |  4 +-
 vm/math.c                               |  4 +-
 23 files changed, 175 insertions(+), 74 deletions(-)
 create mode 100644 basis/cpu/x86/64/unix/bootstrap.factor
 create mode 100644 basis/cpu/x86/64/unix/unix.factor
 create mode 100644 basis/cpu/x86/64/winnt/bootstrap.factor
 create mode 100644 basis/cpu/x86/64/winnt/winnt.factor

diff --git a/Makefile b/Makefile
index aa520063e3..973ba1f3d4 100644
--- a/Makefile
+++ b/Makefile
@@ -170,7 +170,7 @@ vm/resources.o:
 	$(CC) -c $(CFLAGS) -o $@ $<
 
 .S.o:
-	$(CC) -c $(CFLAGS) -o $@ $<
+	$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
 
 .m.o:
 	$(CC) -c $(CFLAGS) -o $@ $<
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 6a88441be9..a93c87611d 100644
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -435,7 +435,7 @@ M: long-long-type box-return ( type -- )
         [ >float ] >>unboxer-quot
     "double" define-primitive-type
 
-    os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
+    "long" "ptrdiff_t" typedef
 
     "ulong" "size_t" typedef
 ] with-compilation-unit
diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index 3816b930e0..ed12054bed 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -25,7 +25,7 @@ IN: bootstrap.image
 : images ( -- seq )
     {
         "x86.32"
-        "x86.64"
+        "winnt-x86.64" "unix-x86.64"
         "linux-ppc" "macosx-ppc"
     } ;
 
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 890938c6b3..82fa7a012e 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -26,6 +26,8 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 temp-reg-1 EAX ;
 M: x86.32 temp-reg-2 ECX ;
 
+M: x86.32 reserved-area-size 0 ;
+
 M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
 
 M: x86.32 %alien-invoke (CALL) rel-dlsym ;
diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor
index 37f9b3ada0..44f840e66a 100644
--- a/basis/cpu/x86/32/bootstrap.factor
+++ b/basis/cpu/x86/32/bootstrap.factor
@@ -6,6 +6,7 @@ IN: bootstrap.x86
 
 4 \ cell set
 
+: stack-frame-size ( -- n ) 4 bootstrap-cells ;
 : shift-arg ( -- reg ) ECX ;
 : div-arg ( -- reg ) EAX ;
 : mod-arg ( -- reg ) EDX ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 16e7319c03..d45dd098b8 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -24,14 +24,12 @@ M: x86.64 stack-reg RSP ;
 M: x86.64 temp-reg-1 RAX ;
 M: x86.64 temp-reg-2 RCX ;
 
+: param-reg-1 int-regs param-regs first ; inline
+: param-reg-2 int-regs param-regs second ; inline
+
 M: int-regs return-reg drop RAX ;
-M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
-
 M: float-regs return-reg drop XMM0 ;
 
-M: float-regs param-regs
-    drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-
 M: x86.64 rel-literal-x86 rc-relative rel-literal ;
 
 M: x86.64 %prologue ( n -- )
@@ -90,7 +88,7 @@ M: struct-type flatten-value-type ( type -- seq )
 
 M: x86.64 %prepare-unbox ( -- )
     ! First parameter is top of stack
-    RDI R14 [] MOV
+    param-reg-1 R14 [] MOV
     R14 cell SUB ;
 
 M: x86.64 %unbox ( n reg-class func -- )
@@ -103,27 +101,27 @@ M: x86.64 %unbox-long-long ( n func -- )
     int-regs swap %unbox ;
 
 : %unbox-struct-field ( c-type i -- )
-    ! Alien must be in RDI.
-    RDI swap cells [+] swap reg-class>> {
+    ! Alien must be in param-reg-1.
+    param-reg-1 swap cells [+] swap reg-class>> {
         { int-regs [ int-regs get pop swap MOV ] }
         { double-float-regs [ float-regs get pop swap MOVSD ] }
     } case ;
 
 M: x86.64 %unbox-small-struct ( c-type -- )
-    ! Alien must be in RDI.
+    ! Alien must be in param-reg-1.
     "alien_offset" f %alien-invoke
-    ! Move alien_offset() return value to RDI so that we don't
+    ! Move alien_offset() return value to param-reg-1 so that we don't
     ! clobber it.
-    RDI RAX MOV
+    param-reg-1 RAX MOV
     [
         flatten-small-struct [ %unbox-struct-field ] each-index
     ] with-return-regs ;
 
 M: x86.64 %unbox-large-struct ( n c-type -- )
-    ! Source is in RDI
+    ! Source is in param-reg-1
     heap-size
     ! Load destination address
-    RSI rot stack@ LEA
+    param-reg-2 rot stack@ LEA
     ! Load structure size
     RDX swap MOV
     ! Copy the struct to the C stack
@@ -160,8 +158,8 @@ M: x86.64 %box-small-struct ( c-type -- )
     [
         [ flatten-small-struct [ %box-struct-field ] each-index ]
         [ RDX swap heap-size MOV ] bi
-        RDI 0 box-struct-field@ MOV
-        RSI 1 box-struct-field@ MOV
+        param-reg-1 0 box-struct-field@ MOV
+        param-reg-2 1 box-struct-field@ MOV
         "box_small_struct" f %alien-invoke
     ] with-return-regs ;
 
@@ -170,9 +168,9 @@ M: x86.64 %box-small-struct ( c-type -- )
 
 M: x86.64 %box-large-struct ( n c-type -- )
     ! Struct size is parameter 2
-    RSI swap heap-size MOV
+    param-reg-2 swap heap-size MOV
     ! Compute destination address
-    RDI swap struct-return@ LEA
+    param-reg-1 swap struct-return@ LEA
     ! Copy the struct from the C stack
     "box_value_struct" f %alien-invoke ;
 
@@ -200,7 +198,7 @@ M: x86.64 %alien-indirect ( -- )
     RBP CALL ;
 
 M: x86.64 %alien-callback ( quot -- )
-    RDI swap %load-indirect
+    param-reg-1 swap %load-indirect
     "c_to_factor" f %alien-invoke ;
 
 M: x86.64 %callback-value ( ctype -- )
@@ -208,11 +206,11 @@ M: x86.64 %callback-value ( ctype -- )
     %prepare-unbox
     ! Save top of data stack
     RSP 8 SUB
-    RDI PUSH
+    param-reg-1 PUSH
     ! Restore data/call/retain stacks
     "unnest_stacks" f %alien-invoke
-    ! Put former top of data stack in RDI
-    RDI POP
+    ! Put former top of data stack in param-reg-1
+    param-reg-1 POP
     RSP 8 ADD
     ! Unbox former top of data stack to return registers
     unbox-return ;
@@ -223,3 +221,10 @@ enable-alien-4-intrinsics
 
 ! SSE2 is always available on x86-64.
 enable-float-intrinsics
+
+USE: vocabs.loader
+
+{
+    { [ os unix? ] [ "cpu.x86.64.unix" require ] }
+    { [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
+} cond
diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor
index c1f5156178..acac8b55bc 100644
--- a/basis/cpu/x86/64/bootstrap.factor
+++ b/basis/cpu/x86/64/bootstrap.factor
@@ -9,8 +9,6 @@ IN: bootstrap.x86
 : shift-arg ( -- reg ) RCX ;
 : div-arg ( -- reg ) RAX ;
 : mod-arg ( -- reg ) RDX ;
-: arg0 ( -- reg ) RDI ;
-: arg1 ( -- reg ) RSI ;
 : temp-reg ( -- reg ) RBX ;
 : stack-reg ( -- reg ) RSP ;
 : ds-reg ( -- reg ) R14 ;
diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor
new file mode 100644
index 0000000000..a42353fabd
--- /dev/null
+++ b/basis/cpu/x86/64/unix/bootstrap.factor
@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private kernel namespaces system
+cpu.x86.assembler layouts vocabs parser ;
+IN: bootstrap.x86
+
+: stack-frame-size ( -- n ) 4 bootstrap-cells ;
+: arg0 ( -- reg ) RDI ;
+: arg1 ( -- reg ) RSI ;
+
+<< "resource:basis/cpu/x86/64/bootstrap.factor" parsed-file parsed >>
+call
diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor
new file mode 100644
index 0000000000..9e70ada5d0
--- /dev/null
+++ b/basis/cpu/x86/64/unix/unix.factor
@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel layouts system compiler.cfg.registers
+cpu.architecture cpu.x86.assembler ;
+IN: cpu.x86.64.unix
+
+M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
+
+M: float-regs param-regs
+    drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+
+M: x86.64 reserved-area-size 0 ;
diff --git a/basis/cpu/x86/64/winnt/bootstrap.factor b/basis/cpu/x86/64/winnt/bootstrap.factor
new file mode 100644
index 0000000000..a62b946e83
--- /dev/null
+++ b/basis/cpu/x86/64/winnt/bootstrap.factor
@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private kernel namespaces system
+cpu.x86.assembler layouts vocabs parser ;
+IN: bootstrap.x86
+
+: stack-frame-size ( -- n ) 8 bootstrap-cells ;
+: arg0 ( -- reg ) RCX ;
+: arg1 ( -- reg ) RDX ;
+
+<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
+call
diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor
new file mode 100644
index 0000000000..d4c092f63d
--- /dev/null
+++ b/basis/cpu/x86/64/winnt/winnt.factor
@@ -0,0 +1,17 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel layouts system alien.c-types compiler.cfg.registers
+cpu.architecture cpu.x86.assembler cpu.x86 ;
+IN: cpu.x86.64.winnt
+
+M: int-regs param-regs drop { RCX RDX R8 R9 } ;
+
+M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
+
+M: x86.64 reserved-area-size 4 cells ;
+
+<<
+"longlong" "ptrdiff_t" typedef
+"int" "long" typedef
+"uint" "ulong" typedef
+>>
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index d2ff9a5928..6dadbc096c 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -10,8 +10,6 @@ big-endian off
 
 1 jit-code-format set
 
-: stack-frame-size ( -- n ) 4 bootstrap-cells ;
-
 [
     ! Load word
     temp-reg 0 MOV
@@ -30,7 +28,7 @@ big-endian off
     temp-reg 0 MOV                             ! load XT
     stack-frame-size PUSH                      ! save stack frame size
     temp-reg PUSH                              ! push XT
-    arg1 PUSH                                  ! alignment
+    stack-reg stack-frame-size 3 bootstrap-cells - SUB   ! alignment
 ] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
 
 [
@@ -302,14 +300,14 @@ big-endian off
     shift-arg ds-reg [] MOV                    ! load shift count
     shift-arg tag-bits get SAR                 ! untag shift count
     ds-reg bootstrap-cell SUB                  ! adjust stack pointer
-    arg0 ds-reg [] MOV                         ! load value
-    arg1 arg0 MOV                              ! make a copy
+    temp-reg ds-reg [] MOV                     ! load value
+    arg1 temp-reg MOV                          ! make a copy
     arg1 CL SHL                                ! compute positive shift value in arg1
     shift-arg NEG                              ! compute negative shift value in arg0
-    arg0 CL SAR
-    arg0 tag-mask get bitnot AND
+    temp-reg CL SAR
+    temp-reg tag-mask get bitnot AND
     shift-arg 0 CMP                            ! if shift count was negative, move arg0 to arg1
-    arg1 arg0 CMOVGE
+    arg1 temp-reg CMOVGE
     ds-reg [] arg1 MOV                         ! push to stack
 ] f f f \ fixnum-shift-fast define-sub-primitive
 
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 8ae3bddfaa..55675a5e42 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -39,12 +39,15 @@ M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
 : align-stack ( n -- n' )
     os macosx? cpu x86.64? or [ 16 align ] when ;
 
+HOOK: reserved-area-size cpu ( -- n )
+
 M: x86 stack-frame-size ( stack-frame -- i )
     [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
     [ params>> ]
     [ return>> ]
     tri + +
     3 cells +
+    reserved-area-size +
     align-stack ;
 
 M: x86 %call ( label -- ) CALL ;
@@ -465,7 +468,7 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
 : stack@ ( n -- op ) stack-reg swap [+] ;
 
 : spill-integer-base ( stack-frame -- n )
-    [ params>> ] [ return>> ] bi + ;
+    [ params>> ] [ return>> ] bi + reserved-area-size + ;
 
 : spill-integer@ ( n -- op )
     cells
@@ -473,10 +476,9 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
     + stack@ ;
 
 : spill-float-base ( stack-frame -- n )
+    [ spill-integer-base ]
     [ spill-counts>> int-regs swap at int-regs reg-size * ]
-    [ params>> ]
-    [ return>> ]
-    tri + + ;
+    bi + ;
 
 : spill-float@ ( n -- op )
     double-float-regs reg-size *
diff --git a/vm/Config.windows.nt.x86.64 b/vm/Config.windows.nt.x86.64
index 6d3865c2f4..3ede556171 100644
--- a/vm/Config.windows.nt.x86.64
+++ b/vm/Config.windows.nt.x86.64
@@ -1,5 +1,5 @@
 #WIN64_PATH=/k/MinGW/win64/bin
-WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
+#WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32
 CC=$(WIN64_PATH)-gcc.exe
 WINDRES=$(WIN64_PATH)-windres.exe
 include vm/Config.windows.nt
diff --git a/vm/callstack.c b/vm/callstack.c
index df4063d149..c9466bbbb2 100755
--- a/vm/callstack.c
+++ b/vm/callstack.c
@@ -116,6 +116,8 @@ CELL frame_executing(F_STACK_FRAME *frame)
 
 F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
 {
+	if(frame->size == 0)
+		critical_error("Stack frame has zero size",frame);
 	return (F_STACK_FRAME *)((CELL)frame - frame->size);
 }
 
diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S
index d903f8013d..e0e674a7e2 100755
--- a/vm/cpu-x86.32.S
+++ b/vm/cpu-x86.32.S
@@ -11,6 +11,7 @@ and the callstack top is passed in EDX */
 #define RETURN_REG %eax
 
 #define CELL_SIZE 4
+#define STACK_PADDING 12
 
 #define PUSH_NONVOLATILE \
 	push %ebx ; \
diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S
index 57bfcee87b..15a4eb8da3 100644
--- a/vm/cpu-x86.64.S
+++ b/vm/cpu-x86.64.S
@@ -1,24 +1,55 @@
 #include "asm.h"
 
-#define ARG0 %rdi
-#define ARG1 %rsi
 #define STACK_REG %rsp
 #define DS_REG %r14
 #define RETURN_REG %rax
 
 #define CELL_SIZE 8
+#define STACK_PADDING 56
 
-#define PUSH_NONVOLATILE \
-	push %rbx ; \
-	push %rbp ; \
-	push %r12 ; \
-	push %r13 ;
+#ifdef WINDOWS
 
-#define POP_NONVOLATILE \
-	pop %r13 ; \
-	pop %r12 ; \
-	pop %rbp ; \
-	pop %rbx
+	#define ARG0 %rcx
+	#define ARG1 %rdx
+	#define ARG2 %r8
+	#define ARG3 %r9
+
+	#define PUSH_NONVOLATILE \
+		push %r12 ; \
+		push %r13 ; \
+		push %rdi ; \
+		push %rsi ; \
+		push %rbx ; \
+		push %rbp
+
+	#define POP_NONVOLATILE \
+		pop %rbp ; \
+		pop %rbx ; \
+		pop %rsi ; \
+		pop %rdi ; \
+		pop %r13 ; \
+		pop %r12
+
+#else
+
+	#define ARG0 %rdi
+	#define ARG1 %rsi
+	#define ARG2 %rdx
+	#define ARG3 %rcx
+
+	#define PUSH_NONVOLATILE \
+		push %rbx ; \
+		push %rbp ; \
+		push %r12 ; \
+		push %r13
+
+	#define POP_NONVOLATILE \
+		pop %r13 ; \
+		pop %r12 ; \
+		pop %rbp ; \
+		pop %rbx
+
+#endif
 
 #define QUOT_XT_OFFSET 21
 
@@ -26,9 +57,9 @@
 ABI limitation which would otherwise require us to do a bizzaro PC-relative
 trampoline to retrieve the function address */
 DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy)):
-	sub %rdx,%rdi                      /* compute new stack pointer */
-	mov %rdi,%rsp
-	call *%rcx                         /* call memcpy */
+	sub ARG2,ARG0                      /* compute new stack pointer */
+	mov ARG0,%rsp
+	call *ARG3                         /* call memcpy */
 	ret                                /* return _with new stack_ */
 
 #include "cpu-x86.S"
diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S
index e8e2af7b25..3d6cacdebd 100755
--- a/vm/cpu-x86.S
+++ b/vm/cpu-x86.S
@@ -1,31 +1,34 @@
 DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
 	PUSH_NONVOLATILE
-	push ARG0                             /* Save quot */
+	push ARG0
 
-	lea -CELL_SIZE(STACK_REG),ARG0        /* Save stack pointer */
+	/* Save stack pointer */
+	lea -CELL_SIZE(STACK_REG),ARG0      
+
+	/* Create register shadow area for Win64 */
+	sub $32,STACK_REG                    
 	call MANGLE(save_callstack_bottom)
+	add $32,STACK_REG
 
-	mov (STACK_REG),ARG0                  /* Pass quot as arg 1 */
-	call *QUOT_XT_OFFSET(ARG0)            /* Call quot-xt */
+	/* Call quot-xt */
+	mov (STACK_REG),ARG0
+	call *QUOT_XT_OFFSET(ARG0)
 
-	POP ARG0
+	pop ARG0
 	POP_NONVOLATILE
 	ret
 
 DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
-	mov ARG1,STACK_REG                    /* rewind_to */
+	/* rewind_to */
+	mov ARG1,STACK_REG                    
 	jmp *QUOT_XT_OFFSET(ARG0)
 
 DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
 	mov STACK_REG,ARG1           /* Save stack pointer */
-	push ARG1                    /* Alignment */
-	push ARG1
-	push ARG1
+	sub $STACK_PADDING,STACK_REG
 	call MANGLE(primitive_jit_compile)
 	mov RETURN_REG,ARG0          /* No-op on 32-bit */
-	pop ARG1                     /* OK to clobber ARG1 here */
-	pop ARG1
-	pop ARG1
+	add $STACK_PADDING,STACK_REG
         jmp *QUOT_XT_OFFSET(ARG0)    /* Call the quotation */
 
 #ifdef WINDOWS
diff --git a/vm/data_gc.c b/vm/data_gc.c
index 9aa4f88de6..5342ff04d9 100755
--- a/vm/data_gc.c
+++ b/vm/data_gc.c
@@ -438,6 +438,8 @@ void collect_gen_cards(CELL gen)
 old->new references */
 void collect_cards(void)
 {
+	GC_PRINT("Collect cards\n");
+
 	int i;
 	for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
 		collect_gen_cards(i);
@@ -465,7 +467,10 @@ void collect_callstack(F_CONTEXT *stacks)
 	{
 		CELL top = (CELL)stacks->callstack_top;
 		CELL bottom = (CELL)stacks->callstack_bottom;
+
+		GC_PRINT("Collect callstack %ld %ld\n",top,bottom);
 		iterate_callstack(top,bottom,collect_stack_frame);
+		GC_PRINT("Done\n");
 	}
 }
 
@@ -481,6 +486,7 @@ void collect_gc_locals(void)
 the user environment and extra roots registered with REGISTER_ROOT */
 void collect_roots(void)
 {
+	GC_PRINT("Collect roots\n");
 	copy_handle(&T);
 	copy_handle(&bignum_zero);
 	copy_handle(&bignum_pos_one);
diff --git a/vm/errors.c b/vm/errors.c
index 7a23e3e53f..36072920fe 100755
--- a/vm/errors.c
+++ b/vm/errors.c
@@ -129,17 +129,17 @@ void divide_by_zero_error(F_STACK_FRAME *native_stack)
 
 void memory_signal_handler_impl(void)
 {
-    memory_protection_error(signal_fault_addr,signal_callstack_top);
+	memory_protection_error(signal_fault_addr,signal_callstack_top);
 }
 
 void divide_by_zero_signal_handler_impl(void)
 {
-    divide_by_zero_error(signal_callstack_top);
+	divide_by_zero_error(signal_callstack_top);
 }
 
 void misc_signal_handler_impl(void)
 {
-    signal_error(signal_number,signal_callstack_top);
+	signal_error(signal_number,signal_callstack_top);
 }
 
 DEFINE_PRIMITIVE(throw)
diff --git a/vm/factor.c b/vm/factor.c
index e81152bd99..c8b07cba64 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -167,7 +167,6 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
 	}
 
 	init_factor(&p);
-
 	nest_stacks();
 
 	F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
diff --git a/vm/factor.rs b/vm/factor.rs
index 5b983cacba..47f899fef6 100644
--- a/vm/factor.rs
+++ b/vm/factor.rs
@@ -1,2 +1,2 @@
-fraptor ICON "misc/icons/Factor.ico"
-
+fraptor ICON "misc/icons/Factor.ico"
+
diff --git a/vm/math.c b/vm/math.c
index c7c5dba5a4..7d3b64ed39 100644
--- a/vm/math.c
+++ b/vm/math.c
@@ -363,13 +363,13 @@ CELL unbox_array_size(void)
 	case BIGNUM_TYPE:
 		{
 			bignum_type zero = untag_object(bignum_zero);
-			bignum_type max = ulong_to_bignum(ARRAY_SIZE_MAX);
+			bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX);
 			bignum_type n = untag_object(dpeek());
 			if(bignum_compare(n,zero) != bignum_comparison_less
 				&& bignum_compare(n,max) == bignum_comparison_less)
 			{
 				dpop();
-				return bignum_to_ulong(n);
+				return bignum_to_cell(n);
 			}
 			break;
 		}

From cc7ab1188104e36f48d0119df249f0b91fa5dac6 Mon Sep 17 00:00:00 2001
From: unknown <Administrator@.(none)>
Date: Fri, 7 Nov 2008 20:34:04 -0600
Subject: [PATCH 207/318] Add more unit tests

---
 basis/math/functions/functions-tests.factor | 19 +++++++++++++++++++
 core/math/integers/integers-tests.factor    |  5 +++++
 2 files changed, 24 insertions(+)

diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor
index d5bdac761f..cbaf37daf8 100644
--- a/basis/math/functions/functions-tests.factor
+++ b/basis/math/functions/functions-tests.factor
@@ -76,6 +76,25 @@ IN: math.functions.tests
     gcd nip
 ] unit-test
 
+[ 11 ] [
+    13262642990609552931815424
+    159151715887314635181785
+    gcd nip
+] unit-test
+
+[ 3 ] [
+    13262642990609552931
+    1591517158873146351
+    gcd nip
+] unit-test
+
+[ 26525285981219 ] [
+    132626429906095
+    159151715887314
+    gcd nip
+] unit-test
+
+
 : verify-gcd ( a b -- ? )
     2dup gcd
     >r rot * swap rem r> = ; 
diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor
index f428df33ae..5a649120a0 100644
--- a/core/math/integers/integers-tests.factor
+++ b/core/math/integers/integers-tests.factor
@@ -101,8 +101,13 @@ unit-test
 [ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
 [ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
 [ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
+[ 4420880996869850977 ] [ 13262642990609552931 3 /i ] unit-test
 [ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
+[ 0 -1 ] [ -1 -268435456 >bignum /mod ] unit-test
 [ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test
+[ 8 530505719624382123 ] [ 13262642990609552931 1591517158873146351 /mod ] unit-test
+[ 8 ] [ 13262642990609552931 1591517158873146351 /i ] unit-test
+[ 530505719624382123 ] [ 13262642990609552931 1591517158873146351 mod ] unit-test
 
 [ -351382792 ] [ -43922849 3 shift ] unit-test
 

From 78eeaddcf2e6071e439833f25552a20ec47f2a3d Mon Sep 17 00:00:00 2001
From: unknown <Administrator@.(none)>
Date: Fri, 7 Nov 2008 20:34:26 -0600
Subject: [PATCH 208/318] Add winnt-x86.64 boot image name

---
 core/bootstrap/primitives.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 3accb8a9b8..24faf81662 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -20,7 +20,8 @@ H{ } clone sub-primitives set
 
 "resource:basis/cpu/" architecture get {
     { "x86.32" "x86/32" }
-    { "x86.64" "x86/64" }
+    { "winnt-x86.64" "x86/64/winnt" }
+    { "unix-x86.64" "x86/64/unix" }
     { "linux-ppc" "ppc/linux" }
     { "macosx-ppc" "ppc/macosx" }
     { "arm" "arm" }

From 639da2d33541ae7b7ac0b49e5205d61e440e00be Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 7 Nov 2008 20:45:25 -0600
Subject: [PATCH 209/318] Refactor OS-specific parts of PowerPC backend

---
 basis/cpu/ppc/linux/linux.factor   |  19 ++++
 basis/cpu/ppc/linux/tags.txt       |   1 +
 basis/cpu/ppc/macosx/macosx.factor |  20 ++++
 basis/cpu/ppc/macosx/tags.txt      |   1 +
 basis/cpu/ppc/ppc.factor           | 144 +++++++++++------------------
 5 files changed, 95 insertions(+), 90 deletions(-)
 create mode 100644 basis/cpu/ppc/linux/linux.factor
 create mode 100644 basis/cpu/ppc/linux/tags.txt
 create mode 100644 basis/cpu/ppc/macosx/macosx.factor
 create mode 100644 basis/cpu/ppc/macosx/tags.txt

diff --git a/basis/cpu/ppc/linux/linux.factor b/basis/cpu/ppc/linux/linux.factor
new file mode 100644
index 0000000000..d92709a399
--- /dev/null
+++ b/basis/cpu/ppc/linux/linux.factor
@@ -0,0 +1,19 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ;
+IN: cpu.ppc.linux
+
+<<
+t "longlong" c-type (>>stack-align?)
+t "ulonglong" c-type (>>stack-align?)
+>>
+
+M: linux reserved-area-size 2 ;
+
+M: linux lr-save 1 ;
+
+M: float-regs param-regs { 1 2 3 4 5 6 7 8 } ;
+
+M: ppc value-structs? drop f ;
+
+M: ppc fp-shadows-int? drop f ;
diff --git a/basis/cpu/ppc/linux/tags.txt b/basis/cpu/ppc/linux/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/cpu/ppc/linux/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/cpu/ppc/macosx/macosx.factor b/basis/cpu/ppc/macosx/macosx.factor
new file mode 100644
index 0000000000..1e0a6caca0
--- /dev/null
+++ b/basis/cpu/ppc/macosx/macosx.factor
@@ -0,0 +1,20 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ;
+IN: cpu.ppc.macosx
+
+<<
+4 "longlong" c-type (>>align)
+4 "ulonglong" c-type (>>align)
+4 "double" c-type (>>align)
+>>
+
+M: macosx reserved-area-size 6 ;
+
+M: macosx lr-save 2 ;
+
+M: float-regs param-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
+
+M: ppc value-structs? drop t ;
+
+M: ppc fp-shadows-int? drop t ;
diff --git a/basis/cpu/ppc/macosx/tags.txt b/basis/cpu/ppc/macosx/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/cpu/ppc/macosx/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index b60fd47b89..d2d1e26396 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -4,8 +4,7 @@ USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
 alien alien.c-types cpu.architecture cpu.ppc.assembler
 compiler.cfg.registers compiler.cfg.instructions
-compiler.constants compiler.codegen compiler.codegen.fixup
-compiler.cfg.intrinsics compiler.cfg.stack-frame ;
+compiler.constants compiler.codegen compiler.codegen.fixup ;
 IN: cpu.ppc
 
 ! PowerPC register assignments:
@@ -16,31 +15,15 @@ IN: cpu.ppc
 ! f0-f29: float vregs
 ! f30, f31: float scratch
 
-<< {
-    { [ os macosx? ] [
-        4 "longlong" c-type (>>align)
-        4 "ulonglong" c-type (>>align)
-        4 "double" c-type (>>align)
-    ] }
-    { [ os linux? ] [
-        t "longlong" c-type (>>stack-align?)
-        t "ulonglong" c-type (>>stack-align?)
-    ] }
-} cond
-
-enable-float-intrinsics
-
-\ ##integer>float t frame-required? set-word-prop
-\ ##float>integer t frame-required? set-word-prop >>
-
 M: ppc machine-registers
     {
         { int-regs T{ range f 2 26 1 } }
-        { double-float-regs T{ range f 0 29 1 } }
+        { double-float-regs T{ range f 0 28 1 } }
     } ;
 
 : scratch-reg 28 ; inline
-: fp-scratch-reg 30 ; inline
+: fp-scratch-reg-1 29 ; inline
+: fp-scratch-reg-2 30 ; inline
 
 M: ppc two-operand? f ;
 
@@ -70,21 +53,9 @@ M: ppc %replace loc>operand STW ;
 M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
 M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
 
-: reserved-area-size ( -- n )
-    os {
-        { linux [ 2 ] }
-        { macosx [ 6 ] }
-    } case cells ; foldable
+HOOK: reserved-area-size os ( -- n )
+HOOK: lr-save os ( -- n )
 
-! The start of the stack frame contains the size of this frame
-! as well as the currently executing XT
-: factor-area-size ( -- n ) 2 cells ; foldable
-: next-save ( n -- i ) cell - ;
-: xt-save ( n -- i ) 2 cells - ;
-
-! Next, we have the spill area as well as the FFI parameter area.
-! They overlap, since basic blocks with FFI calls will never
-! spill.
 : param@ ( n -- x ) reserved-area-size + ; inline
 
 : param-save-size ( -- n ) 8 cells ; foldable
@@ -92,38 +63,19 @@ M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
 : local@ ( n -- x )
     reserved-area-size param-save-size + + ; inline
 
-: spill-integer-base ( -- n )
-    stack-frame get spill-counts>> double-float-regs swap at
-    double-float-regs reg-size * ;
+: factor-area-size ( -- n ) 2 cells ; foldable
 
-: spill-integer@ ( n -- offset )
-    cells spill-integer-base + param@ ;
+: next-save ( n -- i ) cell - ;
 
-: spill-float@ ( n -- offset )
-    double-float-regs reg-size * param@ ;
-
-! Some FP intrinsics need a temporary scratch area in the stack
-! frame, 8 bytes in size
-: scratch@ ( n -- offset )
-   stack-frame get total-size>>
-   factor-area-size -
-   param-save-size -
-   + ;
-
-! Finally we have the linkage area
-: lr-save ( -- n )
-    os {
-        { linux [ 1 ] }
-        { macosx [ 2 ] }
-    } case cells ; foldable
+: xt-save ( n -- i ) 2 cells - ;
 
 M: ppc stack-frame-size ( stack-frame -- i )
     [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
     [ params>> ]
     [ return>> ]
     tri + +
-    param-save-size +
     reserved-area-size +
+    param-save-size +
     factor-area-size +
     4 cells align ;
 
@@ -246,19 +198,19 @@ M: ppc %div-float FDIV ;
 
 M:: ppc %integer>float ( dst src -- )
     HEX: 4330 scratch-reg LIS
-    scratch-reg 1 0 scratch@ STW
+    scratch-reg 1 0 param@ STW
     scratch-reg src MR
     scratch-reg dup HEX: 8000 XORIS
-    scratch-reg 1 4 scratch@ STW
-    dst 1 0 scratch@ LFD
+    scratch-reg 1 cell param@ STW
+    fp-scratch-reg-2 1 0 param@ LFD
     scratch-reg 4503601774854144.0 %load-indirect
-    fp-scratch-reg scratch-reg float-offset LFD
-    dst dst fp-scratch-reg FSUB ;
+    fp-scratch-reg-2 scratch-reg float-offset LFD
+    fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
 
 M:: ppc %float>integer ( dst src -- )
-    fp-scratch-reg src FCTIWZ
-    fp-scratch-reg 1 0 scratch@ STFD
-    dst 1 4 scratch@ LWZ ;
+    fp-scratch-reg-1 src FCTIWZ
+    fp-scratch-reg-2 1 0 param@ STFD
+    dst 1 4 param@ LWZ ;
 
 M: ppc %copy ( dst src -- ) MR ;
 
@@ -266,10 +218,6 @@ M: ppc %copy-float ( dst src -- ) FMR ;
 
 M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
 
-M:: ppc %box-float ( dst src temp -- )
-    dst 16 float temp %allot
-    src dst float-offset STFD ;
-
 M:: ppc %unbox-any-c-ptr ( dst src temp -- )
     [
         { "is-byte-array" "end" "start" } [ define-label ] each
@@ -401,12 +349,12 @@ M: ppc %gc
     "end" resolve-label ;
 
 M: ppc %prologue ( n -- )
-    0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
+    0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this
     0 MFLR
     1 1 pick neg ADDI
-    11 1 pick xt-save STW
-    dup 11 LI
-    11 1 pick next-save STW
+    scratch-reg 1 pick xt-save STW
+    dup scratch-reg LI
+    scratch-reg 1 pick next-save STW
     0 1 rot lr-save + STW ;
 
 M: ppc %epilogue ( n -- )
@@ -457,22 +405,38 @@ M: ppc %compare-branch (%compare) %branch ;
 M: ppc %compare-imm-branch (%compare-imm) %branch ;
 M: ppc %compare-float-branch (%compare-float) %branch ;
 
-M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ;
-M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ;
+: spill-integer-base ( stack-frame -- n )
+    [ params>> ] [ return>> ] bi + ;
 
-M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ;
-M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ;
+: stack@ 1 swap ; inline
+
+: spill-integer@ ( n -- reg offset )
+    cells
+    stack-frame get spill-integer-base
+    + stack@ ;
+
+: spill-float-base ( stack-frame -- n )
+    [ spill-counts>> int-regs swap at int-regs reg-size * ]
+    [ params>> ]
+    [ return>> ]
+    tri + + ;
+
+: spill-float@ ( n -- reg offset )
+    double-float-regs reg-size *
+    stack-frame get spill-float-base
+    + stack@ ;
+
+M: ppc %spill-integer ( src n -- ) spill-integer@ STW ;
+M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ;
+
+M: ppc %spill-float ( src n -- ) spill-float@ STFD ;
+M: ppc %reload-float ( dst n -- ) spill-float@ LFD ;
 
 M: ppc %loop-entry ;
 
 M: int-regs return-reg drop 3 ;
 M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
 M: float-regs return-reg drop 1 ;
-M: float-regs param-regs 
-    drop os H{
-        { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
-        { linux { 1 2 3 4 5 6 7 8 } }
-    } at ;
 
 M: int-regs %save-param-reg drop 1 rot local@ STW ;
 M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
@@ -595,13 +559,6 @@ M: ppc %callback-value ( ctype -- )
     ! Unbox former top of data stack to return registers
     unbox-return ;
 
-M: ppc value-structs?
-    #! On Linux/PPC, value structs are passed in the same way
-    #! as reference structs, we just have to make a copy first.
-    os linux? not ;
-
-M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
-
 M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
 
 M: ppc struct-small-enough? ( size -- ? ) drop f ;
@@ -611,3 +568,10 @@ M: ppc %box-small-struct
 
 M: ppc %unbox-small-struct
     drop "No small structs" throw ;
+
+USE: vocabs.loader
+
+{
+    { [ os macosx? ] [ "cpu.ppc.macosx" require ] }
+    { [ os linux? ] [ "cpu.ppc.linux" require ] }
+} cond

From 1b744ab14b54f7be631e11b1daff300bb103d589 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 7 Nov 2008 21:09:42 -0600
Subject: [PATCH 210/318] Updating code for boot image renaming

---
 basis/bootstrap/image/image.factor   | 10 ++++++++--
 build-support/factor.sh              | 20 ++++++++++----------
 extra/mason/platform/platform.factor |  4 ++--
 3 files changed, 20 insertions(+), 14 deletions(-)

diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index 3816b930e0..c556ee660f 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -12,9 +12,15 @@ io.encodings.binary math.order math.private accessors
 slots.private compiler.units ;
 IN: bootstrap.image
 
+: arch ( os cpu -- arch )
+    {
+        { "ppc" [ name>> "-ppc" append ] }
+        { "x86.64" [ name>> "winnt" = "winnt" "unix" ? "-x86.64" append ] }
+        [ nip ]
+    } case ;
+
 : my-arch ( -- arch )
-    cpu name>> 
-    dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
+    os name>> cpu name>> arch ;
 
 : boot-image-name ( arch -- string )
     "boot." swap ".image" 3append ;
diff --git a/build-support/factor.sh b/build-support/factor.sh
index 5cbc1e96e3..07d05e29b5 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -271,18 +271,18 @@ check_os_arch_word() {
 set_build_info() {
     check_os_arch_word
     MAKE_TARGET=$OS-$ARCH-$WORD
-    MAKE_IMAGE_TARGET=$ARCH.$WORD
-    BOOT_IMAGE=boot.$ARCH.$WORD.image
     if [[ $OS == macosx && $ARCH == ppc ]] ; then
-        MAKE_IMAGE_TARGET=$OS-$ARCH
-        MAKE_TARGET=$OS-$ARCH
-        BOOT_IMAGE=boot.macosx-ppc.image
-    fi
-    if [[ $OS == linux && $ARCH == ppc ]] ; then
-        MAKE_IMAGE_TARGET=$OS-$ARCH
-        MAKE_TARGET=$OS-$ARCH
-        BOOT_IMAGE=boot.linux-ppc.image
+        MAKE_IMAGE_TARGET=macosx-ppc
+    elif [[ $OS == linux && $ARCH == ppc ]] ; then
+        MAKE_IMAGE_TARGET=linux-ppc
+    elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
+        MAKE_IMAGE_TARGET=winnt-x86.64
+    elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
+        MAKE_IMAGE_TARGET=unix-x86.64
+	else
+        MAKE_IMAGE_TARGET=$ARCH.$WORD
     fi
+    BOOT_IMAGE_NAME=boot.$MAKE_IMAGE_TARGET.image
 }
 
 parse_build_info() {
diff --git a/extra/mason/platform/platform.factor b/extra/mason/platform/platform.factor
index cd7d3f3836..59c525f5ea 100644
--- a/extra/mason/platform/platform.factor
+++ b/extra/mason/platform/platform.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel system accessors namespaces splitting sequences
-mason.config ;
+mason.config bootstrap.image ;
 IN: mason.platform
 
 : platform ( -- string )
@@ -11,7 +11,7 @@ IN: mason.platform
     target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
 
 : boot-image-arch ( -- string )
-    target-cpu get dup "ppc" = [ target-os get "-" append prepend ] when ;
+    target-os get target-cpu get arch ;
 
 : boot-image-name ( -- string )
     "boot." boot-image-arch ".image" 3append ;

From eb83b542d6247c632807407433f20d2c3eef074e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 7 Nov 2008 21:54:13 -0600
Subject: [PATCH 211/318] Fix unix x86.64 bootstrap

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

diff --git a/basis/cpu/x86/64/unix/bootstrap.factor b/basis/cpu/x86/64/unix/bootstrap.factor
index a42353fabd..29d48bd794 100644
--- a/basis/cpu/x86/64/unix/bootstrap.factor
+++ b/basis/cpu/x86/64/unix/bootstrap.factor
@@ -8,5 +8,5 @@ IN: bootstrap.x86
 : arg0 ( -- reg ) RDI ;
 : arg1 ( -- reg ) RSI ;
 
-<< "resource:basis/cpu/x86/64/bootstrap.factor" parsed-file parsed >>
+<< "resource:basis/cpu/x86/64/bootstrap.factor" parse-file parsed >>
 call
diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor
index 9e70ada5d0..abbd0cf21b 100644
--- a/basis/cpu/x86/64/unix/unix.factor
+++ b/basis/cpu/x86/64/unix/unix.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel layouts system compiler.cfg.registers
-cpu.architecture cpu.x86.assembler ;
+cpu.architecture cpu.x86.assembler cpu.x86 ;
 IN: cpu.x86.64.unix
 
 M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;

From c669040754d94077d17f88f38ee33840bca4f1be Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 7 Nov 2008 21:56:57 -0600
Subject: [PATCH 212/318] Pass -fno-forward-propagate on gcc 4.3

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

diff --git a/build-support/factor.sh b/build-support/factor.sh
index 07d05e29b5..7fbb54a568 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -60,10 +60,11 @@ check_gcc_version() {
     GCC_VERSION=`$CC --version`
     check_ret gcc
     if [[ $GCC_VERSION == *3.3.* ]] ; then
-        $ECHO "bad!"
         $ECHO "You have a known buggy version of gcc (3.3)"
         $ECHO "Install gcc 3.4 or higher and try again."
         exit 3
+    elif [[ $GCC_VERSION == *4.3.* ]] ; then
+       MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate"
     fi
     $ECHO "ok."
 }
@@ -282,7 +283,7 @@ set_build_info() {
 	else
         MAKE_IMAGE_TARGET=$ARCH.$WORD
     fi
-    BOOT_IMAGE_NAME=boot.$MAKE_IMAGE_TARGET.image
+    BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image
 }
 
 parse_build_info() {
@@ -335,7 +336,7 @@ cd_factor() {
 }
 
 invoke_make() {
-   $MAKE $*
+   $MAKE $MAKE_OPTS $*
    check_ret $MAKE
 }
 

From 6182a161dba6eead4fa91a11cafcbba1732a27d8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Fri, 7 Nov 2008 22:03:27 -0600
Subject: [PATCH 213/318] support reading 8bit bitmaps, 4bit is blocking on
 bit-streams

---
 extra/graphics/bitmap/bitmap.factor | 34 +++++++++++++++++++----------
 1 file changed, 22 insertions(+), 12 deletions(-)

diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor
index 651c5f7ca1..4d83300934 100755
--- a/extra/graphics/bitmap/bitmap.factor
+++ b/extra/graphics/bitmap/bitmap.factor
@@ -5,7 +5,7 @@ USING: alien arrays byte-arrays combinators summary
 io.backend graphics.viewer io io.binary io.files kernel libc
 math math.functions namespaces opengl opengl.gl prettyprint
 sequences strings ui ui.gadgets.panes io.encodings.binary
-accessors ;
+accessors grouping ;
 IN: graphics.bitmap
 
 ! Currently can only handle 24bit bitmaps.
@@ -23,16 +23,25 @@ TUPLE: bitmap magic size reserved offset header-length width
         swap [ >>array ] [ >>color-index ] bi
         24 >>bit-count ;
 
-: raw-bitmap>string ( str n -- str )
+: 8bit>array ( bitmap -- array )
+    [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+    [ color-index>> >array ] bi [ swap nth ] with map concat ;
+
+: 4bit>array ( bitmap -- array )
+    [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+    [ color-index>> >array ] bi [ swap nth ] with map concat ;
+
+: raw-bitmap>array ( bitmap -- array )
+    dup bit-count>>
     {
         { 32 [ "32bit" throw ] }
-        { 24 [ ] }
+        { 24 [ color-index>> ] }
         { 16 [ "16bit" throw ] }
-        { 8 [ "8bit" throw ] }
-        { 4 [ "4bit" throw ] }
+        { 8 [ 8bit>array ] }
+        { 4 [ 4bit>array ] }
         { 2 [ "2bit" throw ] }
         { 1 [ "1bit" throw ] }
-    } case ;
+    } case >byte-array ;
 
 ERROR: bitmap-magic ;
 
@@ -72,13 +81,12 @@ M: bitmap-magic summary
 
 : load-bitmap ( path -- bitmap )
     normalize-path binary [
-        T{ bitmap } clone
-        dup parse-file-header
-        dup parse-bitmap-header
-        dup parse-bitmap
+        bitmap new
+            dup parse-file-header
+            dup parse-bitmap-header
+            dup parse-bitmap
     ] with-file-reader
-    dup color-index>> over bit-count>>
-    raw-bitmap>string >byte-array >>array ;
+    dup raw-bitmap>array >>array ;
 
 : save-bitmap ( bitmap path -- )
     binary [
@@ -118,6 +126,8 @@ M: bitmap draw-image ( bitmap -- )
         bit-count>> {
             ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
             { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
+            { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
+            { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
         } case
     ] keep array>> glDrawPixels ;
 

From 9cc193ea5b40c4e856dc42fec39d2fb65873ed0f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 7 Nov 2008 22:37:40 -0600
Subject: [PATCH 214/318] Add unportable tags and fix my-arch word

---
 basis/bootstrap/image/image.factor | 4 ++--
 basis/cpu/x86/64/unix/tags.txt     | 1 +
 basis/cpu/x86/64/winnt/tags.txt    | 1 +
 3 files changed, 4 insertions(+), 2 deletions(-)
 create mode 100644 basis/cpu/x86/64/unix/tags.txt
 create mode 100644 basis/cpu/x86/64/winnt/tags.txt

diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index 3a3ae341d1..8b0051148f 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -14,8 +14,8 @@ IN: bootstrap.image
 
 : arch ( os cpu -- arch )
     {
-        { "ppc" [ name>> "-ppc" append ] }
-        { "x86.64" [ name>> "winnt" = "winnt" "unix" ? "-x86.64" append ] }
+        { "ppc" [ "-ppc" append ] }
+        { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
         [ nip ]
     } case ;
 
diff --git a/basis/cpu/x86/64/unix/tags.txt b/basis/cpu/x86/64/unix/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/cpu/x86/64/unix/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/cpu/x86/64/winnt/tags.txt b/basis/cpu/x86/64/winnt/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/cpu/x86/64/winnt/tags.txt
@@ -0,0 +1 @@
+unportable

From 1280ed63fed27e0cbe5cd58592f35f8cfc4cb2cd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 7 Nov 2008 22:40:21 -0600
Subject: [PATCH 215/318] Fix mason tests

---
 extra/mason/release/branch/branch-tests.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/mason/release/branch/branch-tests.factor b/extra/mason/release/branch/branch-tests.factor
index 68046f79cf..ae3ddb61fc 100644
--- a/extra/mason/release/branch/branch-tests.factor
+++ b/extra/mason/release/branch/branch-tests.factor
@@ -12,7 +12,7 @@ USING: mason.release.branch mason.config tools.test namespaces ;
     ] with-scope
 ] unit-test
 
-[ { "scp" "boot.x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
+[ { "scp" "boot.unix-x86.64.image" "joe@blah.com:/stuff/clean/netbsd-x86-64" } ] [
     [
         "joe" image-username set
         "blah.com" image-host set

From 23ec6ef1228d6778248f6b217514b83c873c9235 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sat, 8 Nov 2008 15:30:28 -0500
Subject: [PATCH 216/318] Minor stack shuffling changes

---
 extra/math/erato/erato.factor     | 2 +-
 extra/math/finance/finance.factor | 4 ++--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor
index 894905e405..7f9262380c 100644
--- a/extra/math/erato/erato.factor
+++ b/extra/math/erato/erato.factor
@@ -15,7 +15,7 @@ TUPLE: erato limit bits latest ;
     [ ind ] [ bits>> ] bi* nth ; inline
 
 : indices ( n erato -- range )
-    limit>> ind over 3 * ind swap rot <range> ;
+    limit>> ind over 3 * ind spin <range> ;
 
 : mark-multiples ( n erato -- )
     2dup [ sq ] [ limit>> ] bi* <= [
diff --git a/extra/math/finance/finance.factor b/extra/math/finance/finance.factor
index f006e6aee7..e02f4be624 100644
--- a/extra/math/finance/finance.factor
+++ b/extra/math/finance/finance.factor
@@ -7,7 +7,7 @@ IN: math.finance
 <PRIVATE
 
 : weighted ( x y a -- z )
-    tuck [ * ] [ 1 swap - * ] 2bi* + ;
+    tuck [ * ] [ 1- neg * ] 2bi* + ;
 
 : a ( n -- a )
     1+ 2 swap / ;
@@ -15,7 +15,7 @@ IN: math.finance
 PRIVATE>
 
 : ema ( seq n -- newseq )
-    a swap unclip [ [ dup ] 2dip swap rot weighted ] accumulate 2nip ;
+    a swap unclip [ [ dup ] 2dip spin weighted ] accumulate 2nip ;
 
 : sma ( seq n -- newseq )
     clump [ mean ] map ;

From 798139f2e7ad63e026d2a8d4b784aaa28607db23 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sat, 8 Nov 2008 16:03:52 -0500
Subject: [PATCH 217/318] Minor polynomials cleanup, could use refactoring

---
 extra/math/polynomials/polynomials.factor | 16 +++++++++-------
 1 file changed, 9 insertions(+), 7 deletions(-)

diff --git a/extra/math/polynomials/polynomials.factor b/extra/math/polynomials/polynomials.factor
index 51512ca2e3..47226114d0 100644
--- a/extra/math/polynomials/polynomials.factor
+++ b/extra/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 sequences vectors math math.vectors
-namespaces make shuffle splitting sequences.lib math.order ;
+USING: arrays kernel make math math.order math.vectors sequences shuffle
+    splitting vectors ;
 IN: math.polynomials
 
 ! Polynomials are vectors with the highest powers on the right:
@@ -13,14 +13,16 @@ IN: math.polynomials
     <array> 1 [ * ] accumulate nip ;
 
 <PRIVATE
-: 2pad-left ( p p n -- p p ) 0 [ pad-left swap ] 2keep pad-left swap ;
-: 2pad-right ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ;
+
+: 2pad-left ( p p n -- p p ) [ 0 pad-left ] curry bi@ ;
+: 2pad-right ( p p n -- p p ) [ 0 pad-right ] curry bi@ ;
 : pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ;
 : pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ;
 : unempty ( seq -- seq ) [ { 0 } ] when-empty ;
 : 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
 
 PRIVATE>
+
 : p= ( p p -- ? ) pextend = ;
 
 : ptrim ( p -- p )
@@ -33,14 +35,14 @@ PRIVATE>
 
 ! convolution
 : pextend-conv ( p p -- p p )
-    #! extend to: p_m + p_n - 1 
+    #! extend to: p_m + p_n - 1
     2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
 
 : p* ( p p -- p )
     #! Multiply two polynomials.
     2unempty pextend-conv <reversed> dup length
     [ over length pick <slice> pick [ * ] 2map sum ] map 2nip reverse ;
-    
+
 : p-sq ( p -- p-sq )
     dup p* ;
 
@@ -72,7 +74,7 @@ PRIVATE>
     dup V{ 0 } clone p= [
         drop nip
     ] [
-        tuck p/mod >r pick p* swap >r swapd p- r> r> (pgcd)
+        tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
     ] if ;
 
 : pgcd ( p p -- p q )

From 774cb858d5c9fd8f747b97c6ae3b67d348e3de59 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sat, 8 Nov 2008 16:34:39 -0500
Subject: [PATCH 218/318] Small updates to math.primes

---
 extra/math/primes/factors/factors.factor | 11 ++++++-----
 extra/math/primes/primes.factor          | 10 ++++------
 2 files changed, 10 insertions(+), 11 deletions(-)

diff --git a/extra/math/primes/factors/factors.factor b/extra/math/primes/factors/factors.factor
index 059bd67c18..80c93f2ae0 100644
--- a/extra/math/primes/factors/factors.factor
+++ b/extra/math/primes/factors/factors.factor
@@ -1,7 +1,6 @@
 ! Copyright (C) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel lists math math.primes namespaces make
-sequences ;
+USING: arrays kernel lists make math math.primes sequences ;
 IN: math.primes.factors
 
 <PRIVATE
@@ -11,14 +10,16 @@ IN: math.primes.factors
 
 : (count) ( n d -- n' )
     [ (factor) ] { } make
-    [ [ first ] keep length 2array , ] unless-empty ;
+    [ [ first ] [ length ] bi 2array , ] unless-empty ;
 
 : (unique) ( n d -- n' )
     [ (factor) ] { } make
     [ first , ] unless-empty ;
 
 : (factors) ( quot list n -- )
-    dup 1 > [ swap uncons swap >r pick call r> swap (factors) ] [ 3drop ] if ;
+    dup 1 > [
+        swap uncons swap [ pick call ] dip swap (factors)
+    ] [ 3drop ] if ;
 
 : (decompose) ( n quot -- seq )
     [ lprimes rot (factors) ] { } make ;
@@ -38,5 +39,5 @@ PRIVATE>
     dup 2 < [
         drop 0
     ] [
-        dup unique-factors dup 1 [ 1- * ] reduce swap product / *
+        dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / *
     ] if ; foldable
diff --git a/extra/math/primes/primes.factor b/extra/math/primes/primes.factor
index feb60c555d..820d5b6c4a 100644
--- a/extra/math/primes/primes.factor
+++ b/extra/math/primes/primes.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2007 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel lists.lazy math math.functions math.miller-rabin
-       math.order math.primes.list math.ranges sequences sorting
-       binary-search ;
+USING: binary-search combinators kernel lists.lazy math math.functions
+    math.miller-rabin math.primes.list sequences ;
 IN: math.primes
 
 <PRIVATE
@@ -45,8 +44,7 @@ PRIVATE>
     } cond ; foldable
 
 : primes-between ( low high -- seq )
-    primes-upto
-    [ 1- next-prime ] dip
-    [ natural-search drop ] keep [ length ] keep <slice> ; foldable
+    primes-upto [ 1- next-prime ] dip
+    [ natural-search drop ] [ length ] [ ] tri <slice> ; foldable
 
 : coprime? ( a b -- ? ) gcd nip 1 = ; foldable

From 326ce8c71b72348d7b38014a49eab0c499c49a08 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sat, 8 Nov 2008 16:47:58 -0500
Subject: [PATCH 219/318] Update >r r> to dip in math.quaternions

---
 extra/math/quaternions/quaternions.factor | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/extra/math/quaternions/quaternions.factor b/extra/math/quaternions/quaternions.factor
index 65f18d3568..ffc0fcc9f7 100755
--- a/extra/math/quaternions/quaternions.factor
+++ b/extra/math/quaternions/quaternions.factor
@@ -16,9 +16,9 @@ IN: math.quaternions
 
 : 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
 
-: q*a ( u v -- a ) 2q swapd ** >r * r> - ; inline
+: q*a ( u v -- a ) 2q swapd ** [ * ] dip - ; inline
 
-: q*b ( u v -- b ) 2q >r ** swap r> * + ; inline
+: q*b ( u v -- b ) 2q [ ** swap ] dip * + ; inline
 
 PRIVATE>
 
@@ -51,12 +51,12 @@ PRIVATE>
 
 : v>q ( v -- q )
     #! Turn a 3-vector into a quaternion with real part 0.
-    first3 rect> >r 0 swap rect> r> 2array ;
+    first3 rect> [ 0 swap rect> ] dip 2array ;
 
 : q>v ( q -- v )
     #! Get the vector part of a quaternion, discarding the real
     #! part.
-    first2 >r imaginary-part r> >rect 3array ;
+    first2 [ imaginary-part ] dip >rect 3array ;
 
 ! Zero
 : q0 { 0 0 } ;
@@ -71,7 +71,7 @@ PRIVATE>
 ! http://www.mathworks.com/access/helpdesk/help/toolbox/aeroblks/euleranglestoquaternions.html
 
 : (euler) ( theta unit -- q )
-    >r -0.5 * dup cos c>q swap sin r> n*v v- ;
+    [ -0.5 * dup cos c>q swap sin ] dip n*v v- ;
 
 : euler ( phi theta psi -- q )
   [ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ;

From 8e44e783cf4efe4d7f39ddeba396c7b12ac5034f Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 8 Nov 2008 15:59:21 -0600
Subject: [PATCH 220/318] ui.gadgets.lists: minor tweak to 'select-gadget'

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

diff --git a/basis/ui/gadgets/lists/lists.factor b/basis/ui/gadgets/lists/lists.factor
index 62e5b7d780..17fe68721d 100644
--- a/basis/ui/gadgets/lists/lists.factor
+++ b/basis/ui/gadgets/lists/lists.factor
@@ -97,7 +97,7 @@ M: list focusable-child* drop t ;
     ] if ;
 
 : select-gadget ( gadget list -- )
-    swap over children>> index
+    tuck children>> index
     [ swap select-index ] [ drop ] if* ;
 
 : clamp-loc ( point max -- point )

From 8262b50c87d89cebd807bd7eb41436e3ef211dfe Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 8 Nov 2008 16:23:06 -0600
Subject: [PATCH 221/318] ui.gadgets.scrollers: minor tweak in 'new-scroller'

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

diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index fefce8a040..633e3ad4a8 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -41,7 +41,7 @@ scroller H{
         dup model>> dependencies>> first  <x-slider> >>x dup x>> @bottom grid-add
         dup model>> dependencies>> second <y-slider> >>y dup y>> @right  grid-add
 
-        swap over model>> <viewport> >>viewport
+        tuck model>> <viewport> >>viewport
         dup viewport>> @center grid-add ;
 
 : <scroller> ( gadget -- scroller ) scroller new-scroller ;

From 313cdf4af02d547cff9e7d59d66ba7188f441526 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 8 Nov 2008 18:29:05 -0600
Subject: [PATCH 222/318] Fix release.tidy bug

---
 extra/mason/release/tidy/tidy.factor | 11 +++++------
 1 file changed, 5 insertions(+), 6 deletions(-)

diff --git a/extra/mason/release/tidy/tidy.factor b/extra/mason/release/tidy/tidy.factor
index a456e6ff23..fb931650d4 100644
--- a/extra/mason/release/tidy/tidy.factor
+++ b/extra/mason/release/tidy/tidy.factor
@@ -1,16 +1,14 @@
 ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces continuations debugger sequences fry
-io.files io.launcher mason.common mason.platform
+io.files io.launcher bootstrap.image qualified mason.common
 mason.config ;
+FROM: mason.config => target-os ;
 IN: mason.release.tidy
 
 : common-files ( -- seq )
+    images [ boot-image-name ] map
     {
-        "boot.x86.32.image"
-        "boot.x86.64.image"
-        "boot.macosx-ppc.image"
-        "boot.linux-ppc.image"
         "vm"
         "temp"
         "logs"
@@ -20,7 +18,8 @@ IN: mason.release.tidy
         "unmaintained"
         "unfinished"
         "build-support"
-    } ;
+    }
+    append ;
 
 : remove-common-files ( -- )
     common-files [ delete-tree ] each ;

From 57242951b9ec01c676c673b0eabf0b63a760813d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 8 Nov 2008 19:33:15 -0600
Subject: [PATCH 223/318] Better error reporting in FROM: and RENAME: words

---
 basis/fry/fry.factor                   |  2 +-
 basis/qualified/qualified-docs.factor  | 11 +++++++++
 basis/qualified/qualified-tests.factor | 31 +++++++++++++++++---------
 basis/qualified/qualified.factor       | 30 ++++++++++++-------------
 core/parser/parser-docs.factor         |  2 +-
 core/parser/parser.factor              |  4 ++--
 6 files changed, 50 insertions(+), 30 deletions(-)

diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor
index 395d5c3caf..87c59e18a0 100644
--- a/basis/fry/fry.factor
+++ b/basis/fry/fry.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences combinators parser splitting math
-quotations arrays make qualified words ;
+quotations arrays make words ;
 IN: fry
 
 : _ ( -- * ) "Only valid inside a fry" throw ;
diff --git a/basis/qualified/qualified-docs.factor b/basis/qualified/qualified-docs.factor
index d62f696a74..067d221d2f 100644
--- a/basis/qualified/qualified-docs.factor
+++ b/basis/qualified/qualified-docs.factor
@@ -32,3 +32,14 @@ HELP: RENAME:
     "RENAME: + math => -"
     "2 3 - ! => 5" } } ;
 
+ARTICLE: "qualified" "Qualified word lookup"
+"The " { $vocab-link "qualified" } " vocabulary provides a handful of parsing words which give more control over word lookup than is offered by " { $link POSTPONE: USE: } " and " { $link POSTPONE: USING: } "."
+$nl
+"These words are useful when there is no way to avoid using two vocabularies with identical word names in the same source file."
+{ $subsection POSTPONE: QUALIFIED: }
+{ $subsection POSTPONE: QUALIFIED-WITH: }
+{ $subsection POSTPONE: FROM: }
+{ $subsection POSTPONE: EXCLUDE: }
+{ $subsection POSTPONE: RENAME: } ;
+
+ABOUT: "qualified"
diff --git a/basis/qualified/qualified-tests.factor b/basis/qualified/qualified-tests.factor
index 8f67ddf730..78efec4861 100644
--- a/basis/qualified/qualified-tests.factor
+++ b/basis/qualified/qualified-tests.factor
@@ -1,24 +1,33 @@
-USING: tools.test qualified ;
-IN: foo
+USING: tools.test qualified eval accessors parser ;
+IN: qualified.tests.foo
 : x 1 ;
-IN: bar
+: y 5 ;
+IN: qualified.tests.bar
 : x 2 ;
-IN: baz
+: y 4 ;
+IN: qualified.tests.baz
 : x 3 ;
 
-QUALIFIED: foo
-QUALIFIED: bar
-[ 1 2 3 ] [ foo:x bar:x x ] unit-test
+QUALIFIED: qualified.tests.foo
+QUALIFIED: qualified.tests.bar
+[ 1 2 3 ] [ qualified.tests.foo:x qualified.tests.bar:x x ] unit-test
 
-QUALIFIED-WITH: bar p
+QUALIFIED-WITH: qualified.tests.bar p
 [ 2 ] [ p:x ] unit-test
 
-RENAME: x baz => y
+RENAME: x qualified.tests.baz => y
 [ 3 ] [ y ] unit-test
 
-FROM: baz => x ;
+FROM: qualified.tests.baz => x ;
 [ 3 ] [ x ] unit-test
+[ 3 ] [ y ] unit-test
 
-EXCLUDE: bar => x ;
+EXCLUDE: qualified.tests.bar => x ;
 [ 3 ] [ x ] unit-test
+[ 4 ] [ y ] unit-test
 
+[ "USE: qualified IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
+[ error>> no-word-error? ] must-fail-with
+
+[ "USE: qualified IN: qualified.tests RENAME: doesnotexist qualified.tests => blah" eval ]
+[ error>> no-word-error? ] must-fail-with
diff --git a/basis/qualified/qualified.factor b/basis/qualified/qualified.factor
index d636cc0152..d387ef4b0e 100644
--- a/basis/qualified/qualified.factor
+++ b/basis/qualified/qualified.factor
@@ -1,12 +1,12 @@
 ! Copyright (C) 2007, 2008 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences assocs hashtables parser lexer
-vocabs words namespaces vocabs.loader debugger sets ;
+vocabs words namespaces vocabs.loader debugger sets fry ;
 IN: qualified
 
 : define-qualified ( vocab-name prefix-name -- )
     [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
-    [ -rot >r append r> ] curry assoc-map
+    '[ [ [ _ ] dip append ] dip ] assoc-map
     use get push ;
 
 : QUALIFIED:
@@ -19,27 +19,27 @@ IN: qualified
 
 : expect=> ( -- ) scan "=>" assert= ;
 
-: partial-vocab ( words name -- assoc )
-    dupd [
-        lookup [ "No such word: " swap append throw ] unless*
-    ] curry map zip ;
-
-: partial-vocab-ignoring ( words name -- assoc )
-    [ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
-
-: EXCLUDE:
-    #! Syntax: EXCLUDE: vocab => words ... ;
-    scan expect=>
-    ";" parse-tokens swap partial-vocab-ignoring use get push ; parsing
+: partial-vocab ( words vocab -- assoc )
+    '[ dup _ lookup [ no-word-error ] unless* ]
+    { } map>assoc ;
 
 : FROM:
     #! Syntax: FROM: vocab => words... ;
     scan dup load-vocab drop expect=>
     ";" parse-tokens swap partial-vocab use get push ; parsing
 
+: partial-vocab-excluding ( words vocab -- assoc )
+    [ load-vocab vocab-words keys swap diff ] keep partial-vocab ;
+
+: EXCLUDE:
+    #! Syntax: EXCLUDE: vocab => words ... ;
+    scan expect=>
+    ";" parse-tokens swap partial-vocab-excluding use get push ; parsing
+
 : RENAME:
     #! Syntax: RENAME: word vocab => newname
-    scan scan dup load-vocab drop lookup [ "No such word" throw ] unless*
+    scan scan dup load-vocab drop
+    dupd lookup [ ] [ no-word-error ] ?if
     expect=>
     scan associate use get push ; parsing
 
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index 1d8d1f0714..d33f5cd6d9 100644
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -69,7 +69,7 @@ $nl
 { $subsection POSTPONE: PRIVATE> }
 { $subsection "vocabulary-search-errors" }
 { $subsection "vocabulary-search-shadow" }
-{ $see-also "words" } ;
+{ $see-also "words" "qualified" } ;
 
 ARTICLE: "reading-ahead" "Reading ahead"
 "Parsing words can consume input:"
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index a86715b073..ed8fc4510b 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -71,10 +71,10 @@ ERROR: no-current-vocab ;
         ] keep
     ] { } map>assoc ;
 
-TUPLE: no-word-error name ;
+ERROR: no-word-error name ;
 
 : no-word ( name -- newword )
-    dup no-word-error boa
+    dup \ no-word-error boa
     swap words-named [ forward-reference? not ] filter
     word-restarts throw-restarts
     dup vocabulary>> (use+) ;

From 359fb6e5183f781dd0f76c0e0e85ac35de08e43c Mon Sep 17 00:00:00 2001
From: unknown <Administrator@.(none)>
Date: Sat, 8 Nov 2008 20:32:23 -0600
Subject: [PATCH 224/318] VM fixes for Win64 calling convention

---
 vm/cpu-x86.32.S |  4 ++++
 vm/cpu-x86.64.S |  6 ++++++
 vm/cpu-x86.S    | 17 +++++++++--------
 3 files changed, 19 insertions(+), 8 deletions(-)

diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S
index e0e674a7e2..eec850dc9e 100755
--- a/vm/cpu-x86.32.S
+++ b/vm/cpu-x86.32.S
@@ -10,14 +10,18 @@ and the callstack top is passed in EDX */
 #define DS_REG %esi
 #define RETURN_REG %eax
 
+#define NV_TEMP_REG %rbx
+
 #define CELL_SIZE 4
 #define STACK_PADDING 12
 
 #define PUSH_NONVOLATILE \
 	push %ebx ; \
+	push %ebp ; \
 	push %ebp
 
 #define POP_NONVOLATILE \
+	pop %ebp ; \
 	pop %ebp ; \
 	pop %ebx
 
diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S
index 15a4eb8da3..c981095d62 100644
--- a/vm/cpu-x86.64.S
+++ b/vm/cpu-x86.64.S
@@ -7,6 +7,8 @@
 #define CELL_SIZE 8
 #define STACK_PADDING 56
 
+#define NV_TEMP_REG %rbp
+
 #ifdef WINDOWS
 
 	#define ARG0 %rcx
@@ -20,9 +22,11 @@
 		push %rdi ; \
 		push %rsi ; \
 		push %rbx ; \
+		push %rbp ; \
 		push %rbp
 
 	#define POP_NONVOLATILE \
+		pop %rbp ; \
 		pop %rbp ; \
 		pop %rbx ; \
 		pop %rsi ; \
@@ -41,9 +45,11 @@
 		push %rbx ; \
 		push %rbp ; \
 		push %r12 ; \
+		push %r13 ; \
 		push %r13
 
 	#define POP_NONVOLATILE \
+		pop %r13 ; \
 		pop %r13 ; \
 		pop %r12 ; \
 		pop %rbp ; \
diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S
index 3d6cacdebd..1857fb0ed8 100755
--- a/vm/cpu-x86.S
+++ b/vm/cpu-x86.S
@@ -1,20 +1,21 @@
 DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
 	PUSH_NONVOLATILE
-	push ARG0
-
-	/* Save stack pointer */
-	lea -CELL_SIZE(STACK_REG),ARG0      
+	mov ARG0,NV_TEMP_REG
 
 	/* Create register shadow area for Win64 */
-	sub $32,STACK_REG                    
+	sub $32,STACK_REG
+
+	/* Save stack pointer */
+	lea -CELL_SIZE(STACK_REG),ARG0
 	call MANGLE(save_callstack_bottom)
-	add $32,STACK_REG
 
 	/* Call quot-xt */
-	mov (STACK_REG),ARG0
+	mov NV_TEMP_REG,ARG0
 	call *QUOT_XT_OFFSET(ARG0)
 
-	pop ARG0
+	/* Tear down register shadow area */
+	add $32,STACK_REG
+
 	POP_NONVOLATILE
 	ret
 

From b9ee92e484456d2103c6f5b3f9fa13ed36746774 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.local>
Date: Sat, 8 Nov 2008 20:36:05 -0600
Subject: [PATCH 225/318] factor.sh fixes

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

diff --git a/build-support/factor.sh b/build-support/factor.sh
index 7fbb54a568..bd234afb5f 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -271,17 +271,21 @@ check_os_arch_word() {
 
 set_build_info() {
     check_os_arch_word
-    MAKE_TARGET=$OS-$ARCH-$WORD
     if [[ $OS == macosx && $ARCH == ppc ]] ; then
         MAKE_IMAGE_TARGET=macosx-ppc
+        MAKE_TARGET=macosx-ppc
     elif [[ $OS == linux && $ARCH == ppc ]] ; then
         MAKE_IMAGE_TARGET=linux-ppc
+        MAKE_TARGET=linux-ppc
     elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
         MAKE_IMAGE_TARGET=winnt-x86.64
+        MAKE_TARGET=winnt-x86-64
     elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
         MAKE_IMAGE_TARGET=unix-x86.64
-	else
+        MAKE_TARGET=$OS-x86-64
+    else
         MAKE_IMAGE_TARGET=$ARCH.$WORD
+        MAKE_TARGET=$OS-$ARCH-$WORD
     fi
     BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image
 }

From 65dea0aa26e233cddd29af5494ab085ea900c2fd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.local>
Date: Sat, 8 Nov 2008 20:36:14 -0600
Subject: [PATCH 226/318] PowerPC backend fixes

---
 basis/cpu/ppc/linux/linux.factor   | 13 +++++++------
 basis/cpu/ppc/macosx/macosx.factor | 13 +++++++------
 basis/cpu/ppc/ppc.factor           | 13 +++++++++----
 3 files changed, 23 insertions(+), 16 deletions(-)

diff --git a/basis/cpu/ppc/linux/linux.factor b/basis/cpu/ppc/linux/linux.factor
index d92709a399..6f21aa74d5 100644
--- a/basis/cpu/ppc/linux/linux.factor
+++ b/basis/cpu/ppc/linux/linux.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ;
+USING: accessors system kernel layouts
+alien.c-types cpu.architecture cpu.ppc ;
 IN: cpu.ppc.linux
 
 <<
@@ -8,12 +9,12 @@ t "longlong" c-type (>>stack-align?)
 t "ulonglong" c-type (>>stack-align?)
 >>
 
-M: linux reserved-area-size 2 ;
+M: linux reserved-area-size 2 cells ;
 
-M: linux lr-save 1 ;
+M: linux lr-save 1 cells ;
 
-M: float-regs param-regs { 1 2 3 4 5 6 7 8 } ;
+M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ;
 
-M: ppc value-structs? drop f ;
+M: ppc value-structs? f ;
 
-M: ppc fp-shadows-int? drop f ;
+M: ppc fp-shadows-int? f ;
diff --git a/basis/cpu/ppc/macosx/macosx.factor b/basis/cpu/ppc/macosx/macosx.factor
index 1e0a6caca0..619b82a04b 100644
--- a/basis/cpu/ppc/macosx/macosx.factor
+++ b/basis/cpu/ppc/macosx/macosx.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors system kernel alien.c-types cpu.architecture cpu.ppc ;
+USING: accessors system kernel layouts
+alien.c-types cpu.architecture cpu.ppc ;
 IN: cpu.ppc.macosx
 
 <<
@@ -9,12 +10,12 @@ IN: cpu.ppc.macosx
 4 "double" c-type (>>align)
 >>
 
-M: macosx reserved-area-size 6 ;
+M: macosx reserved-area-size 6 cells ;
 
-M: macosx lr-save 2 ;
+M: macosx lr-save 2 cells ;
 
-M: float-regs param-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
+M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
 
-M: ppc value-structs? drop t ;
+M: ppc value-structs? t ;
 
-M: ppc fp-shadows-int? drop t ;
+M: ppc fp-shadows-int? t ;
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index d2d1e26396..2be46d15ee 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -349,12 +349,17 @@ M: ppc %gc
     "end" resolve-label ;
 
 M: ppc %prologue ( n -- )
-    0 scratch-reg LOAD32 rc-absolute-ppc-2/2 rel-this
+    #! We use a volatile register (r11) here for scratch. Because
+    #! callback bodies have a prologue too, we cannot assume
+    #! that c_to_factor saved all non-volatile registers, so
+    #! we have to respect the C calling convention. Also, we
+    #! cannot touch any param-regs either.
+    0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
     0 MFLR
     1 1 pick neg ADDI
-    scratch-reg 1 pick xt-save STW
-    dup scratch-reg LI
-    scratch-reg 1 pick next-save STW
+    11 1 pick xt-save STW
+    dup 11 LI
+    11 1 pick next-save STW
     0 1 rot lr-save + STW ;
 
 M: ppc %epilogue ( n -- )

From fdbea06e279f71892ecf2354790121d5cf8da559 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 8 Nov 2008 20:40:09 -0600
Subject: [PATCH 227/318] Fix compile warning

---
 vm/callstack.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/vm/callstack.c b/vm/callstack.c
index c9466bbbb2..b7e99b418c 100755
--- a/vm/callstack.c
+++ b/vm/callstack.c
@@ -117,7 +117,7 @@ CELL frame_executing(F_STACK_FRAME *frame)
 F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
 {
 	if(frame->size == 0)
-		critical_error("Stack frame has zero size",frame);
+		critical_error("Stack frame has zero size",(CELL)frame);
 	return (F_STACK_FRAME *)((CELL)frame - frame->size);
 }
 

From abc3915387c145215dd50f8923796c71c46fd2b3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 8 Nov 2008 21:06:51 -0600
Subject: [PATCH 228/318] Fix x86-32 VM compilation; was using a 64-bit reg on
 accident

---
 vm/cpu-x86.32.S | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S
index eec850dc9e..6ddbd52da2 100755
--- a/vm/cpu-x86.32.S
+++ b/vm/cpu-x86.32.S
@@ -10,7 +10,7 @@ and the callstack top is passed in EDX */
 #define DS_REG %esi
 #define RETURN_REG %eax
 
-#define NV_TEMP_REG %rbx
+#define NV_TEMP_REG %ebx
 
 #define CELL_SIZE 4
 #define STACK_PADDING 12

From f7fe84e5634a4f2c05b019479dfe072a8bb9f457 Mon Sep 17 00:00:00 2001
From: unknown <Administrator@.(none)>
Date: Sat, 8 Nov 2008 21:40:47 -0600
Subject: [PATCH 229/318] Working on Win64 FFI

---
 basis/compiler/codegen/codegen.factor      | 25 ++++++---
 basis/cpu/architecture/architecture.factor | 10 +++-
 basis/cpu/ppc/linux/linux.factor           |  8 ++-
 basis/cpu/ppc/macosx/macosx.factor         |  8 ++-
 basis/cpu/x86/32/32.factor                 |  6 +++
 basis/cpu/x86/64/64.factor                 | 63 ++++++----------------
 basis/cpu/x86/64/unix/unix.factor          | 40 ++++++++++++++
 basis/cpu/x86/64/winnt/winnt.factor        | 13 ++++-
 basis/cpu/x86/x86.factor                   | 12 ++---
 9 files changed, 117 insertions(+), 68 deletions(-)

diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index cab86dcb54..35d4d59253 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces make math math.parser sequences accessors
+USING: namespaces make math math.order math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
 combinators classes.algebra alien alien.c-types alien.structs
 alien.strings alien.arrays sets threads libc continuations.private
@@ -234,13 +234,26 @@ M: float-regs reg-class-variable drop float-regs ;
 
 GENERIC: inc-reg-class ( register-class -- )
 
-M: reg-class inc-reg-class
-    dup reg-class-variable inc
-    fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+: ?dummy-stack-params ( reg-class -- )
+    dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
+
+: ?dummy-int-params ( reg-class -- )
+    dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
+
+: ?dummy-fp-params ( reg-class -- )
+    drop dummy-fp-params? [ float-regs inc ] when ;
+
+M: int-regs inc-reg-class
+    [ reg-class-variable inc ]
+    [ ?dummy-stack-params ]
+    [ ?dummy-fp-params ]
+    tri ;
 
 M: float-regs inc-reg-class
-    dup call-next-method
-    fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
+    [ reg-class-variable inc ]
+    [ ?dummy-stack-params ]
+    [ ?dummy-int-params ]
+    tri ;
 
 GENERIC: reg-class-full? ( class -- ? )
 
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index e4fa9419f0..b0b5b048d9 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -146,8 +146,14 @@ HOOK: struct-small-enough? cpu ( heap-size -- ? )
 ! Do we pass value structs by value or hidden reference?
 HOOK: value-structs? cpu ( -- ? )
 
-! If t, fp parameters are shadowed by dummy int parameters
-HOOK: fp-shadows-int? cpu ( -- ? )
+! If t, all parameters are shadowed by dummy stack parameters
+HOOK: dummy-stack-params? cpu ( -- ? )
+
+! If t, all FP parameters are shadowed by dummy int parameters
+HOOK: dummy-int-params? cpu ( -- ? )
+
+! If t, all int parameters are shadowed by dummy FP parameters
+HOOK: dummy-fp-params? cpu ( -- ? )
 
 HOOK: %prepare-unbox cpu ( -- )
 
diff --git a/basis/cpu/ppc/linux/linux.factor b/basis/cpu/ppc/linux/linux.factor
index d92709a399..c6649c7ad2 100644
--- a/basis/cpu/ppc/linux/linux.factor
+++ b/basis/cpu/ppc/linux/linux.factor
@@ -14,6 +14,10 @@ M: linux lr-save 1 ;
 
 M: float-regs param-regs { 1 2 3 4 5 6 7 8 } ;
 
-M: ppc value-structs? drop f ;
+M: ppc value-structs? f ;
 
-M: ppc fp-shadows-int? drop f ;
+M: ppc dummy-stack-params? f ;
+
+M: ppc dummy-int-params? f ;
+
+M: ppc dummy-fp-params? f ;
diff --git a/basis/cpu/ppc/macosx/macosx.factor b/basis/cpu/ppc/macosx/macosx.factor
index 1e0a6caca0..bb607d0e44 100644
--- a/basis/cpu/ppc/macosx/macosx.factor
+++ b/basis/cpu/ppc/macosx/macosx.factor
@@ -15,6 +15,10 @@ M: macosx lr-save 2 ;
 
 M: float-regs param-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
 
-M: ppc value-structs? drop t ;
+M: ppc value-structs? t ;
 
-M: ppc fp-shadows-int? drop t ;
+M: ppc dummy-stack-params? t ;
+
+M: ppc dummy-int-params? t ;
+
+M: ppc dummy-fp-params? f ;
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 82fa7a012e..f26d76551a 100644
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -274,6 +274,12 @@ M: x86.32 %callback-return ( n -- )
         [ drop 0 ]
     } cond RET ;
 
+M: x86.32 dummy-stack-params? f ;
+
+M: x86.32 dummy-int-params? f ;
+
+M: x86.32 dummy-fp-params? f ;
+
 os windows? [
     cell "longlong" c-type (>>align)
     cell "ulonglong" c-type (>>align)
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index d45dd098b8..0d20660021 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -26,6 +26,7 @@ M: x86.64 temp-reg-2 RCX ;
 
 : param-reg-1 int-regs param-regs first ; inline
 : param-reg-2 int-regs param-regs second ; inline
+: param-reg-3 int-regs param-regs third ; inline
 
 M: int-regs return-reg drop RAX ;
 M: float-regs return-reg drop XMM0 ;
@@ -40,13 +41,13 @@ M: x86.64 %prologue ( n -- )
 
 M: stack-params %load-param-reg
     drop
-    >r R11 swap stack@ MOV
-    r> stack@ R11 MOV ;
+    >r R11 swap param@ MOV
+    r> param@ R11 MOV ;
 
 M: stack-params %save-param-reg
     drop
     R11 swap next-stack@ MOV
-    stack@ R11 MOV ;
+    param@ R11 MOV ;
 
 : with-return-regs ( quot -- )
     [
@@ -55,37 +56,6 @@ M: stack-params %save-param-reg
         call
     ] with-scope ; inline
 
-! The ABI for passing structs by value is pretty messed up
-<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type (>>reg-class) >>
-
-: struct-types&offset ( struct-type -- pairs )
-    fields>> [
-        [ type>> ] [ offset>> ] bi 2array
-    ] map ;
-
-: split-struct ( pairs -- seq )
-    [
-        [ 8 mod zero? [ t , ] when , ] assoc-each
-    ] { } make { t } split harvest ;
-
-: flatten-small-struct ( c-type -- seq )
-    struct-types&offset split-struct [
-        [ c-type c-type-reg-class ] map
-        int-regs swap member? "void*" "double" ? c-type
-    ] map ;
-
-: flatten-large-struct ( c-type -- seq )
-    heap-size cell align
-    cell /i "__stack_value" c-type <repetition> ;
-
-M: struct-type flatten-value-type ( type -- seq )
-    dup heap-size 16 > [
-        flatten-large-struct
-    ] [
-        flatten-small-struct
-    ] if ;
-
 M: x86.64 %prepare-unbox ( -- )
     ! First parameter is top of stack
     param-reg-1 R14 [] MOV
@@ -102,7 +72,7 @@ M: x86.64 %unbox-long-long ( n func -- )
 
 : %unbox-struct-field ( c-type i -- )
     ! Alien must be in param-reg-1.
-    param-reg-1 swap cells [+] swap reg-class>> {
+    R11 swap cells [+] swap reg-class>> {
         { int-regs [ int-regs get pop swap MOV ] }
         { double-float-regs [ float-regs get pop swap MOVSD ] }
     } case ;
@@ -110,20 +80,20 @@ M: x86.64 %unbox-long-long ( n func -- )
 M: x86.64 %unbox-small-struct ( c-type -- )
     ! Alien must be in param-reg-1.
     "alien_offset" f %alien-invoke
-    ! Move alien_offset() return value to param-reg-1 so that we don't
+    ! Move alien_offset() return value to R11 so that we don't
     ! clobber it.
-    param-reg-1 RAX MOV
+    R11 RAX MOV
     [
-        flatten-small-struct [ %unbox-struct-field ] each-index
+        flatten-value-type [ %unbox-struct-field ] each-index
     ] with-return-regs ;
 
 M: x86.64 %unbox-large-struct ( n c-type -- )
     ! Source is in param-reg-1
     heap-size
     ! Load destination address
-    param-reg-2 rot stack@ LEA
+    param-reg-2 rot param@ LEA
     ! Load structure size
-    RDX swap MOV
+    param-reg-3 swap MOV
     ! Copy the struct to the C stack
     "to_value_struct" f %alien-invoke ;
 
@@ -142,10 +112,7 @@ M: x86.64 %box ( n reg-class func -- )
 M: x86.64 %box-long-long ( n func -- )
     int-regs swap %box ;
 
-M: x86.64 struct-small-enough? ( size -- ? )
-    heap-size 2 cells <= ;
-
-: box-struct-field@ ( i -- operand ) 1+ cells stack@ ;
+: box-struct-field@ ( i -- operand ) 1+ cells param@ ;
 
 : %box-struct-field ( c-type i -- )
     box-struct-field@ swap reg-class>> {
@@ -156,15 +123,15 @@ M: x86.64 struct-small-enough? ( size -- ? )
 M: x86.64 %box-small-struct ( c-type -- )
     #! Box a <= 16-byte struct.
     [
-        [ flatten-small-struct [ %box-struct-field ] each-index ]
-        [ RDX swap heap-size MOV ] bi
+        [ flatten-value-type [ %box-struct-field ] each-index ]
+        [ param-reg-3 swap heap-size MOV ] bi
         param-reg-1 0 box-struct-field@ MOV
         param-reg-2 1 box-struct-field@ MOV
         "box_small_struct" f %alien-invoke
     ] with-return-regs ;
 
 : struct-return@ ( n -- operand )
-    [ stack-frame get params>> ] unless* stack@ ;
+    [ stack-frame get params>> ] unless* param@ ;
 
 M: x86.64 %box-large-struct ( n c-type -- )
     ! Struct size is parameter 2
@@ -178,7 +145,7 @@ M: x86.64 %prepare-box-struct ( -- )
     ! Compute target address for value struct return
     RAX f struct-return@ LEA
     ! Store it as the first parameter
-    0 stack@ RAX MOV ;
+    0 param@ RAX MOV ;
 
 M: x86.64 %prepare-var-args RAX RAX XOR ;
 
diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor
index abbd0cf21b..1a65132fab 100644
--- a/basis/cpu/x86/64/unix/unix.factor
+++ b/basis/cpu/x86/64/unix/unix.factor
@@ -10,3 +10,43 @@ M: float-regs param-regs
     drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 M: x86.64 reserved-area-size 0 ;
+
+! The ABI for passing structs by value is pretty messed up
+<< "void*" c-type clone "__stack_value" define-primitive-type
+stack-params "__stack_value" c-type (>>reg-class) >>
+
+: struct-types&offset ( struct-type -- pairs )
+    fields>> [
+        [ type>> ] [ offset>> ] bi 2array
+    ] map ;
+
+: split-struct ( pairs -- seq )
+    [
+        [ 8 mod zero? [ t , ] when , ] assoc-each
+    ] { } make { t } split harvest ;
+
+: flatten-small-struct ( c-type -- seq )
+    struct-types&offset split-struct [
+        [ c-type c-type-reg-class ] map
+        int-regs swap member? "void*" "double" ? c-type
+    ] map ;
+
+: flatten-large-struct ( c-type -- seq )
+    heap-size cell align
+    cell /i "__stack_value" c-type <repetition> ;
+
+M: struct-type flatten-value-type ( type -- seq )
+    dup heap-size 16 > [
+        flatten-large-struct
+    ] [
+        flatten-small-struct
+    ] if ;
+
+M: x86.64 struct-small-enough? ( size -- ? )
+    heap-size 2 cells <= ;
+
+M: x86.64 dummy-stack-params? f ;
+
+M: x86.64 dummy-int-params? f ;
+
+M: x86.64 dummy-fp-params? f ;
diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor
index d4c092f63d..0124c40877 100644
--- a/basis/cpu/x86/64/winnt/winnt.factor
+++ b/basis/cpu/x86/64/winnt/winnt.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel layouts system alien.c-types compiler.cfg.registers
-cpu.architecture cpu.x86.assembler cpu.x86 ;
+USING: kernel layouts system math alien.c-types
+compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
 IN: cpu.x86.64.winnt
 
 M: int-regs param-regs drop { RCX RDX R8 R9 } ;
@@ -10,6 +10,15 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
 
 M: x86.64 reserved-area-size 4 cells ;
 
+M: x86.64 struct-small-enough? ( size -- ? )
+    heap-size cell <= ;
+
+M: x86.64 dummy-stack-params? f ;
+
+M: x86.64 dummy-int-params? t ;
+
+M: x86.64 dummy-fp-params? t ;
+
 <<
 "longlong" "ptrdiff_t" typedef
 "int" "long" typedef
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 55675a5e42..4f72fe45e1 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -467,6 +467,8 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
 
 : stack@ ( n -- op ) stack-reg swap [+] ;
 
+: param@ ( n -- op ) reserved-area-size + stack@ ;
+
 : spill-integer-base ( stack-frame -- n )
     [ params>> ] [ return>> ] bi + reserved-area-size + ;
 
@@ -493,16 +495,16 @@ M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ;
 
 M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
-M: int-regs %save-param-reg drop >r stack@ r> MOV ;
-M: int-regs %load-param-reg drop swap stack@ MOV ;
+M: int-regs %save-param-reg drop >r param@ r> MOV ;
+M: int-regs %load-param-reg drop swap param@ MOV ;
 
 GENERIC: MOVSS/D ( dst src reg-class -- )
 
 M: single-float-regs MOVSS/D drop MOVSS ;
 M: double-float-regs MOVSS/D drop MOVSD ;
 
-M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
-M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
+M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ;
+M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ;
 
 GENERIC: push-return-reg ( reg-class -- )
 GENERIC: load-return-reg ( n reg-class -- )
@@ -518,8 +520,6 @@ M: x86 %prepare-alien-invoke
     temp-reg-1 2 cells [+] ds-reg MOV
     temp-reg-1 3 cells [+] rs-reg MOV ;
 
-M: x86 fp-shadows-int? ( -- ? ) f ;
-
 M: x86 value-structs? t ;
 
 M: x86 small-enough? ( n -- ? )

From 28e397420d257d4fbd3896b68f72e8b6bb8da8b8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 8 Nov 2008 21:43:55 -0600
Subject: [PATCH 230/318] Fix USING:

---
 basis/cpu/x86/64/unix/unix.factor | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor
index 1a65132fab..ddb412873a 100644
--- a/basis/cpu/x86/64/unix/unix.factor
+++ b/basis/cpu/x86/64/unix/unix.factor
@@ -1,7 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel layouts system compiler.cfg.registers
-cpu.architecture cpu.x86.assembler cpu.x86 ;
+USING: accessors arrays sequences math splitting make assocs
+kernel layouts system alien.c-types alien.structs
+cpu.architecture cpu.x86.assembler cpu.x86
+compiler.codegen compiler.cfg.registers ;
 IN: cpu.x86.64.unix
 
 M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;

From 70d7c0ca20ce976a976240e65ac97f84c32fdf09 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Sun, 9 Nov 2008 13:01:03 -0600
Subject: [PATCH 231/318] make hexdump work with byte-arrays

---
 extra/hexdump/hexdump-tests.factor | 3 +++
 extra/hexdump/hexdump.factor       | 4 ++--
 2 files changed, 5 insertions(+), 2 deletions(-)

diff --git a/extra/hexdump/hexdump-tests.factor b/extra/hexdump/hexdump-tests.factor
index 7fb26e10c5..b3c03196f5 100644
--- a/extra/hexdump/hexdump-tests.factor
+++ b/extra/hexdump/hexdump-tests.factor
@@ -6,3 +6,6 @@ USING: hexdump kernel sequences tools.test ;
 
 [ t ] [ 256 [ ] map hexdump "Length: 256, 100h\n00000000h: 00 01 02 03 04 05 06 07 08 09 0a 0b 0c 0d 0e 0f ................\n00000010h: 10 11 12 13 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f ................\n00000020h: 20 21 22 23 24 25 26 27 28 29 2a 2b 2c 2d 2e 2f  !\"#$%&'()*+,-./\n00000030h: 30 31 32 33 34 35 36 37 38 39 3a 3b 3c 3d 3e 3f 0123456789:;<=>?\n00000040h: 40 41 42 43 44 45 46 47 48 49 4a 4b 4c 4d 4e 4f @ABCDEFGHIJKLMNO\n00000050h: 50 51 52 53 54 55 56 57 58 59 5a 5b 5c 5d 5e 5f PQRSTUVWXYZ[\\]^_\n00000060h: 60 61 62 63 64 65 66 67 68 69 6a 6b 6c 6d 6e 6f `abcdefghijklmno\n00000070h: 70 71 72 73 74 75 76 77 78 79 7a 7b 7c 7d 7e 7f pqrstuvwxyz{|}~.\n00000080h: 80 81 82 83 84 85 86 87 88 89 8a 8b 8c 8d 8e 8f ................\n00000090h: 90 91 92 93 94 95 96 97 98 99 9a 9b 9c 9d 9e 9f ................\n000000a0h: a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 aa ab ac ad ae af ................\n000000b0h: b0 b1 b2 b3 b4 b5 b6 b7 b8 b9 ba bb bc bd be bf ................\n000000c0h: c0 c1 c2 c3 c4 c5 c6 c7 c8 c9 ca cb cc cd ce cf ................\n000000d0h: d0 d1 d2 d3 d4 d5 d6 d7 d8 d9 da db dc dd de df ................\n000000e0h: e0 e1 e2 e3 e4 e5 e6 e7 e8 e9 ea eb ec ed ee ef ................\n000000f0h: f0 f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb fc fd fe ff ................\n" = ] unit-test
 
+
+[
+    "Length: 3, 3h\n00000000h: 01 02 03                                        ...\n" ] [ B{ 1 2 3 } hexdump ] unit-test
diff --git a/extra/hexdump/hexdump.factor b/extra/hexdump/hexdump.factor
index b965fb41bb..ecbc2d6169 100644
--- a/extra/hexdump/hexdump.factor
+++ b/extra/hexdump/hexdump.factor
@@ -21,9 +21,9 @@ IN: hexdump
     [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-right ;
 
 : >ascii ( bytes -- str )
-    [ [ printable? ] keep CHAR: . ? ] map ;
+    [ [ printable? ] keep CHAR: . ? ] "" map-as ;
 
-: write-hex-line ( str lineno -- )
+: write-hex-line ( bytes lineno -- )
     write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
 
 PRIVATE>

From f20ab6f4e8d26a7daff973d55a03b221835e5e16 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sun, 9 Nov 2008 17:16:30 -0500
Subject: [PATCH 232/318] Refactor of math.statistics

---
 extra/math/statistics/statistics.factor | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/extra/math/statistics/statistics.factor b/extra/math/statistics/statistics.factor
index 8cd6d26c1c..267a95c100 100644
--- a/extra/math/statistics/statistics.factor
+++ b/extra/math/statistics/statistics.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman, Michael Judge.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.analysis math.functions math.vectors sequences
-sequences.lib sorting ;
+USING: arrays kernel math math.analysis math.functions sequences sequences.lib
+    sorting ;
 IN: math.statistics
 
 : mean ( seq -- n )
@@ -19,10 +19,10 @@ IN: math.statistics
 
 : median ( seq -- n )
     #! middle number if odd, avg of two middle numbers if even
-    natural-sort dup length dup even? [
-        1- 2 / swap [ nth ] [ [ 1+ ] dip nth ] 2bi + 2 /
+    natural-sort dup length even? [
+        [ midpoint@ dup 1- 2array ] keep nths mean
     ] [
-        2 / swap nth
+        [ midpoint@ ] keep nth
     ] if ;
 
 : range ( seq -- n )
@@ -44,14 +44,14 @@ IN: math.statistics
 
 : ste ( seq -- x )
     #! standard error, standard deviation / sqrt ( length of sequence )
-    dup std swap length sqrt / ;
+    [ std ] [ length ] bi sqrt / ;
 
 : ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
     ! finds sigma((xi-mean(x))(yi-mean(y))
-    0 [ [ >r pick r> swap - ] bi@ * + ] 2reduce 2nip ;
+    0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
 
 : (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
-    * recip >r [ ((r)) ] keep length 1- / r> * ;
+    * recip [ [ ((r)) ] keep length 1- / ] dip * ;
 
 : [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
     first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;

From e5c155338fe0f6cac1fa4a139dd6fb858f73c15f Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sun, 9 Nov 2008 17:23:24 -0500
Subject: [PATCH 233/318] Fix short-circuit usage in number>text

---
 extra/math/text/english/english.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor
index dfb0c00388..58dab74cdb 100755
--- a/extra/math/text/english/english.factor
+++ b/extra/math/text/english/english.factor
@@ -26,7 +26,7 @@ IN: math.text.english
 
 SYMBOL: and-needed?
 : set-conjunction ( seq -- )
-    first { [ dup 100 < ] [ dup 0 > ] } 0&& and-needed? set drop ;
+    first { [ 100 < ] [ 0 > ] } 1&& and-needed? set ;
 
 : negative-text ( n -- str )
     0 < "Negative " "" ? ;

From 429fe85f460face61d8a31fdc12d001e950249c9 Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Sun, 9 Nov 2008 17:27:39 -0600
Subject: [PATCH 234/318] Fix compile error

---
 basis/io/windows/files/files.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)
 mode change 100644 => 100755 basis/io/windows/files/files.factor

diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor
old mode 100644
new mode 100755
index 3fb8029ee7..3952299543
--- a/basis/io/windows/files/files.factor
+++ b/basis/io/windows/files/files.factor
@@ -276,7 +276,7 @@ M: winnt file-system-info ( path -- file-system-info )
         swap >>type
         swap >>mount-point ;
 
-: find-first-volume ( word -- string handle )
+: find-first-volume ( -- string handle )
     MAX_PATH 1+ <byte-array> dup length
     dupd
     FindFirstVolume dup win32-error=0/f

From 2bf9a55cead31028ef311b3faf066511b60792ea Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Sun, 9 Nov 2008 17:27:51 -0600
Subject: [PATCH 235/318] Fix Windows deployment

---
 basis/tools/deploy/windows/windows.factor | 26 +++++++++++------------
 1 file changed, 12 insertions(+), 14 deletions(-)

diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor
index ad1b3cbd84..ec1259c777 100755
--- a/basis/tools/deploy/windows/windows.factor
+++ b/basis/tools/deploy/windows/windows.factor
@@ -9,16 +9,14 @@ IN: tools.deploy.windows
     "resource:factor.dll" swap copy-file-into ;
 
 : copy-freetype ( bundle-name -- )
-    deploy-ui? get [
-        {
-            "resource:freetype6.dll"
-            "resource:zlib1.dll"
-        } swap copy-files-into
-    ] [ drop ] if ;
+    {
+        "resource:freetype6.dll"
+        "resource:zlib1.dll"
+    } swap copy-files-into ;
 
 : create-exe-dir ( vocab bundle-name -- vm )
+    dup copy-dll
     deploy-ui? get [
-        dup copy-dll
         dup copy-freetype
         dup "" copy-fonts
     ] when
@@ -26,14 +24,14 @@ IN: tools.deploy.windows
 
 M: winnt deploy*
     "resource:" [
-        deploy-name over deploy-config at
-        [
-            {
+        dup deploy-config [
+            deploy-name get
+            [
                 [ create-exe-dir ]
                 [ image-name ]
                 [ drop ]
-                [ drop deploy-config ]
-            } 2cleave make-deploy-image
-        ]
-        [ nip open-in-explorer ] 2bi
+                2tri namespace make-deploy-image
+            ]
+            [ nip open-in-explorer ] 2bi
+        ] bind
     ] with-directory ;

From 9a3c10d21247eb457d13d9e58f89d25af051871c Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sun, 9 Nov 2008 19:22:04 -0500
Subject: [PATCH 236/318] Add documentation for math.analysis

---
 extra/math/analysis/analysis-docs.factor | 24 ++++++++++++++++++++++++
 1 file changed, 24 insertions(+)
 create mode 100644 extra/math/analysis/analysis-docs.factor

diff --git a/extra/math/analysis/analysis-docs.factor b/extra/math/analysis/analysis-docs.factor
new file mode 100644
index 0000000000..a810ffc1bd
--- /dev/null
+++ b/extra/math/analysis/analysis-docs.factor
@@ -0,0 +1,24 @@
+USING: help.markup help.syntax math ;
+IN: math.analysis
+
+HELP: gamma
+{ $values { "x" number } { "y" number } }
+{ $description "Gamma function; an extension of factorial to real and complex numbers." } ;
+
+HELP: gammaln
+{ $values { "x" number } { "gamma[x]" number } }
+{ $description "An alternative to " { $link gamma } " when gamma(x)'s range varies too widely." } ;
+
+HELP: nth-root
+{ $values { "n" integer } { "x" number } { "y" number } }
+{ $description "Calculates the nth root of a number, such that " { $snippet "y^n=x" } "." } ;
+
+HELP: exp-int
+{ $values { "x" number } { "y" number } }
+{ $description "Exponential integral function." }
+{ $notes "Works only for real values of " { $snippet "x" } " and is accurate to 7 decimal places." } ;
+
+HELP: stirling-fact
+{ $values { "n" integer } { "fact" integer } }
+{ $description "James Stirling's factorial approximation." } ;
+

From 46692390d4c65ea5a4fab3941d3a58552cbc691c Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sun, 9 Nov 2008 21:00:36 -0500
Subject: [PATCH 237/318] Cleanup math.compare docs and tests

---
 extra/math/compare/compare-docs.factor  | 36 ++++++++-----------------
 extra/math/compare/compare-tests.factor |  9 +------
 2 files changed, 12 insertions(+), 33 deletions(-)

diff --git a/extra/math/compare/compare-docs.factor b/extra/math/compare/compare-docs.factor
index eb199cd5fe..6c20db10fd 100644
--- a/extra/math/compare/compare-docs.factor
+++ b/extra/math/compare/compare-docs.factor
@@ -1,37 +1,23 @@
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: help.markup help.syntax ;
-
+USING: help.markup help.syntax math ;
 IN: math.compare
 
 HELP: absmin
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description 
-    "Returns the smaller absolute number with the original sign." 
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the smaller absolute number with the original sign." } ;
 
 HELP: absmax
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description 
-    "Returns the larger absolute number with the original sign."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the larger absolute number with the original sign." } ;
 
 HELP: posmax
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description 
-    "Returns the most-positive value, or zero if both are negative."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the most-positive value, or zero if both are negative." } ;
 
 HELP: negmin
-{ $values { "a" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description 
-    "Returns the most-negative value, or zero if both are positive."
-} ;
+{ $values { "a" number } { "b" number } { "x" number } }
+{ $description "Returns the most-negative value, or zero if both are positive." } ;
 
 HELP: clamp
-{ $values { "a" "a number" } { "value" "a number" } { "b" "a number" } { "x" "a number" } }
-{ $description 
-    "Returns the value when between 'a' and 'b', 'a' if <= 'a', or 'b' if >= 'b'."
-} ;
+{ $values { "a" number } { "value" number } { "b" number } { "x" number } }
+{ $description "Returns the value when between " { $snippet "a" } " and " { $snippet "b" } ", " { $snippet "a" } " if <= " { $snippet "a" } ", or " { $snippet "b" } " if >= " { $snippet "b" } "." } ;
 
diff --git a/extra/math/compare/compare-tests.factor b/extra/math/compare/compare-tests.factor
index 765f34e695..272471fe5d 100644
--- a/extra/math/compare/compare-tests.factor
+++ b/extra/math/compare/compare-tests.factor
@@ -1,8 +1,4 @@
-! Copyright (C) 2008 John Benediktsson
-! See http://factorcode.org/license.txt for BSD license
-
-USING: kernel math math.functions math.compare tools.test ;
-
+USING: kernel math math.compare math.functions tools.test ;
 IN: math.compare.tests
 
 [ -1 ] [ -1 5 absmin ] unit-test
@@ -23,6 +19,3 @@ IN: math.compare.tests
 [ 1 ] [ 0 1 2 clamp ] unit-test
 [ 2 ] [ 0 3 2 clamp ] unit-test
 
-
-
-

From 930458ebd7e316a3ed4dacda98f5124879bcf307 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sun, 9 Nov 2008 21:42:01 -0500
Subject: [PATCH 238/318] Move fft/haar transforms to their own subdirectory

---
 extra/math/{ => transforms}/fft/authors.txt       |  0
 extra/math/transforms/fft/fft-docs.factor         |  7 +++++++
 extra/math/{ => transforms}/fft/fft.factor        |  2 +-
 extra/math/{ => transforms}/fft/summary.txt       |  0
 extra/math/{ => transforms}/haar/authors.txt      |  0
 extra/math/transforms/haar/haar-docs.factor       | 15 +++++++++++++++
 .../math/{ => transforms}/haar/haar-tests.factor  |  5 +++--
 extra/math/{ => transforms}/haar/haar.factor      |  2 +-
 extra/math/{ => transforms}/haar/summary.txt      |  0
 extra/math/transforms/summary.txt                 |  1 +
 10 files changed, 28 insertions(+), 4 deletions(-)
 rename extra/math/{ => transforms}/fft/authors.txt (100%)
 create mode 100644 extra/math/transforms/fft/fft-docs.factor
 rename extra/math/{ => transforms}/fft/fft.factor (96%)
 rename extra/math/{ => transforms}/fft/summary.txt (100%)
 rename extra/math/{ => transforms}/haar/authors.txt (100%)
 create mode 100644 extra/math/transforms/haar/haar-docs.factor
 rename extra/math/{ => transforms}/haar/haar-tests.factor (65%)
 rename extra/math/{ => transforms}/haar/haar.factor (96%)
 rename extra/math/{ => transforms}/haar/summary.txt (100%)
 create mode 100644 extra/math/transforms/summary.txt

diff --git a/extra/math/fft/authors.txt b/extra/math/transforms/fft/authors.txt
similarity index 100%
rename from extra/math/fft/authors.txt
rename to extra/math/transforms/fft/authors.txt
diff --git a/extra/math/transforms/fft/fft-docs.factor b/extra/math/transforms/fft/fft-docs.factor
new file mode 100644
index 0000000000..430058b362
--- /dev/null
+++ b/extra/math/transforms/fft/fft-docs.factor
@@ -0,0 +1,7 @@
+USING: help.markup help.syntax sequences ;
+IN: math.transforms.fft
+
+HELP: fft
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Fast Fourier transform function." } ;
+
diff --git a/extra/math/fft/fft.factor b/extra/math/transforms/fft/fft.factor
similarity index 96%
rename from extra/math/fft/fft.factor
rename to extra/math/transforms/fft/fft.factor
index 7dfdc0bcfc..0688c00468 100644
--- a/extra/math/fft/fft.factor
+++ b/extra/math/transforms/fft/fft.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: columns grouping kernel math math.constants math.functions math.vectors
     sequences ;
-IN: math.fft
+IN: math.transforms.fft
 
 ! Fast Fourier Transform
 
diff --git a/extra/math/fft/summary.txt b/extra/math/transforms/fft/summary.txt
similarity index 100%
rename from extra/math/fft/summary.txt
rename to extra/math/transforms/fft/summary.txt
diff --git a/extra/math/haar/authors.txt b/extra/math/transforms/haar/authors.txt
similarity index 100%
rename from extra/math/haar/authors.txt
rename to extra/math/transforms/haar/authors.txt
diff --git a/extra/math/transforms/haar/haar-docs.factor b/extra/math/transforms/haar/haar-docs.factor
new file mode 100644
index 0000000000..218a63a480
--- /dev/null
+++ b/extra/math/transforms/haar/haar-docs.factor
@@ -0,0 +1,15 @@
+USING: help.markup help.syntax sequences ;
+IN: math.transforms.haar
+
+HELP: haar
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Haar wavelet transform function." }
+{ $notes "The sequence length should be a power of two." }
+{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 7 1 6 6 3 -5 4 2 } haar ." "{ 3 2 -1 -2 3 0 4 1 }" } } ;
+
+HELP: rev-haar
+{ $values { "seq" sequence } { "seq" sequence } }
+{ $description "Reverse Haar wavelet transform function." }
+{ $notes "The sequence length should be a power of two." }
+{ $examples { $example "USING: math.transforms.haar prettyprint ;" "{ 3 2 -1 -2 3 0 4 1 } rev-haar ." "{ 7 1 6 6 3 -5 4 2 }" } } ;
+
diff --git a/extra/math/haar/haar-tests.factor b/extra/math/transforms/haar/haar-tests.factor
similarity index 65%
rename from extra/math/haar/haar-tests.factor
rename to extra/math/transforms/haar/haar-tests.factor
index 9c9124bf17..fd2ab90c0d 100644
--- a/extra/math/haar/haar-tests.factor
+++ b/extra/math/transforms/haar/haar-tests.factor
@@ -1,5 +1,6 @@
-USING: math.haar tools.test ;
-IN: math.haar.tests
+USING: math.transforms.haar tools.test ;
+IN: math.transforms.haar.tests
 
 [ { 3 2 -1 -2 3 0 4 1 } ] [ { 7 1 6 6 3 -5 4 2 } haar ] unit-test
 [ { 7 1 6 6 3 -5 4 2 } ] [ { 3 2 -1 -2 3 0 4 1 } rev-haar ] unit-test
+
diff --git a/extra/math/haar/haar.factor b/extra/math/transforms/haar/haar.factor
similarity index 96%
rename from extra/math/haar/haar.factor
rename to extra/math/transforms/haar/haar.factor
index f745721124..c0359b8e7b 100644
--- a/extra/math/haar/haar.factor
+++ b/extra/math/transforms/haar/haar.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs columns grouping kernel math math.statistics math.vectors
     sequences ;
-IN: math.haar
+IN: math.transforms.haar
 
 ! Haar Wavelet Transform -- http://dmr.ath.cx/gfx/haar/
 
diff --git a/extra/math/haar/summary.txt b/extra/math/transforms/haar/summary.txt
similarity index 100%
rename from extra/math/haar/summary.txt
rename to extra/math/transforms/haar/summary.txt
diff --git a/extra/math/transforms/summary.txt b/extra/math/transforms/summary.txt
new file mode 100644
index 0000000000..d3d93df124
--- /dev/null
+++ b/extra/math/transforms/summary.txt
@@ -0,0 +1 @@
+Collection of mathematical transforms

From e813e1df1849c18eea3111f52c6352158ea97a1a Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sun, 9 Nov 2008 21:42:59 -0500
Subject: [PATCH 239/318] Add unit tests for math.derivatives

---
 extra/math/derivatives/derivatives-tests.factor | 5 +++++
 1 file changed, 5 insertions(+)
 create mode 100644 extra/math/derivatives/derivatives-tests.factor

diff --git a/extra/math/derivatives/derivatives-tests.factor b/extra/math/derivatives/derivatives-tests.factor
new file mode 100644
index 0000000000..cfbc1fa6ec
--- /dev/null
+++ b/extra/math/derivatives/derivatives-tests.factor
@@ -0,0 +1,5 @@
+USING: math math.derivatives tools.test ;
+IN: math.derivatives.test
+
+[ 8 ] [ 4 [ sq ] derivative >integer ] unit-test
+

From 61db7d846b34101cbd7a51f50474b0aafb3a1808 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sun, 9 Nov 2008 22:10:42 -0500
Subject: [PATCH 240/318] Switch zero? to 0 = where appropriate in PE solutions

---
 extra/project-euler/001/001.factor       | 2 +-
 extra/project-euler/004/004.factor       | 2 +-
 extra/project-euler/014/014.factor       | 2 +-
 extra/project-euler/019/019.factor       | 4 ++--
 extra/project-euler/047/047.factor       | 2 +-
 extra/project-euler/052/052.factor       | 2 +-
 extra/project-euler/common/common.factor | 6 +++---
 7 files changed, 10 insertions(+), 10 deletions(-)

diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor
index 344b0f1209..1e49be9a60 100644
--- a/extra/project-euler/001/001.factor
+++ b/extra/project-euler/001/001.factor
@@ -46,7 +46,7 @@ PRIVATE>
 
 
 : euler001b ( -- answer )
-    1000 [ dup 5 mod swap 3 mod [ zero? ] either? ] filter sum ;
+    1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
 
 ! [ euler001b ] 100 ave-time
 ! 0 ms run / 0 ms GC ave time - 100 trials
diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor
index eb5f97b2de..e1918f5fa6 100644
--- a/extra/project-euler/004/004.factor
+++ b/extra/project-euler/004/004.factor
@@ -21,7 +21,7 @@ IN: project-euler.004
 <PRIVATE
 
 : source-004 ( -- seq )
-    100 999 [a,b] [ 10 mod zero? not ] filter ;
+    100 999 [a,b] [ 10 mod 0 = not ] filter ;
 
 : max-palindrome ( seq -- palindrome )
     natural-sort [ palindrome? ] find-last nip ;
diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor
index 3b812cf242..aa04784151 100644
--- a/extra/project-euler/014/014.factor
+++ b/extra/project-euler/014/014.factor
@@ -58,7 +58,7 @@ PRIVATE>
 <PRIVATE
 
 : worth-calculating? ( n -- ? )
-    1- 3 { [ mod zero? ] [ / even? ] } 2&& ;
+    1- 3 { [ mod 0 = ] [ / even? ] } 2&& ;
 
 PRIVATE>
 
diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor
index 62e2e066ff..16a7139f51 100644
--- a/extra/project-euler/019/019.factor
+++ b/extra/project-euler/019/019.factor
@@ -33,7 +33,7 @@ IN: project-euler.019
 : euler019 ( -- answer )
     1901 2000 [a,b] [
         12 [1,b] [ 1 zeller-congruence ] with map
-    ] map concat [ zero? ] count ;
+    ] map concat [ 0 = ] count ;
 
 ! [ euler019 ] 100 ave-time
 ! 1 ms ave run time - 0.51 SD (100 trials)
@@ -58,7 +58,7 @@ IN: project-euler.019
 PRIVATE>
 
 : euler019a ( -- answer )
-    end-date start-date first-days [ zero? ] count ;
+    end-date start-date first-days [ 0 = ] count ;
 
 ! [ euler019a ] 100 ave-time
 ! 17 ms ave run time - 2.13 SD (100 trials)
diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor
index 84041babb7..30c01d8f61 100644
--- a/extra/project-euler/047/047.factor
+++ b/extra/project-euler/047/047.factor
@@ -66,7 +66,7 @@ SYMBOL: sieve
     0 <repetition> >array sieve set ;
 
 : is-prime? ( index -- ? )
-    sieve get nth zero? ;
+    sieve get nth 0 = ;
 
 : multiples ( n -- seq )
     sieve get length 1- over <range> ;
diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor
index 5362a6e9b0..c382d992f6 100644
--- a/extra/project-euler/052/052.factor
+++ b/extra/project-euler/052/052.factor
@@ -30,7 +30,7 @@ IN: project-euler.052
     [ number>digits natural-sort ] map all-equal? ;
 
 : candidate? ( n -- ? )
-    { [ odd? ] [ 3 mod zero? ] } 1&& ;
+    { [ odd? ] [ 3 mod 0 = ] } 1&& ;
 
 : next-all-same ( x n -- n )
     dup candidate? [
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index d3263bbc1e..8176414153 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -42,7 +42,7 @@ IN: project-euler.common
 
 : (sum-divisors) ( n -- sum )
     dup sqrt >fixnum [1,b] [
-        [ 2dup mod zero? [ 2dup / + , ] [ drop ] if ] each
+        [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each
         dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
     ] { } make sum ;
 
@@ -68,7 +68,7 @@ PRIVATE>
     ] if ;
 
 : number>digits ( n -- seq )
-    [ dup zero? not ] [ 10 /mod ] [ ] produce reverse nip ;
+    [ dup 0 = not ] [ 10 /mod ] [ ] produce reverse nip ;
 
 : nth-triangle ( n -- n )
     dup 1+ * 2 / ;
@@ -112,7 +112,7 @@ PRIVATE>
     factor-2s dup [ 1+ ]
     [ perfect-square? -1 0 ? ]
     [ dup sqrt >fixnum [1,b] ] tri* [
-        dupd mod zero? [ [ 2 + ] dip ] when
+        dupd mod 0 = [ [ 2 + ] dip ] when
     ] each drop * ;
 
 ! These transforms are for generating primitive Pythagorean triples

From b04bc4d866883cc0864dae4cfdc435e1c5586e12 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Mon, 10 Nov 2008 00:58:43 -0500
Subject: [PATCH 241/318] Solution to Project Euler problem 71

---
 extra/project-euler/071/071-tests.factor |  4 ++
 extra/project-euler/071/071.factor       | 52 ++++++++++++++++++++++++
 2 files changed, 56 insertions(+)
 create mode 100644 extra/project-euler/071/071-tests.factor
 create mode 100644 extra/project-euler/071/071.factor

diff --git a/extra/project-euler/071/071-tests.factor b/extra/project-euler/071/071-tests.factor
new file mode 100644
index 0000000000..ba61d7640b
--- /dev/null
+++ b/extra/project-euler/071/071-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.071 tools.test ;
+IN: project-euler.071.tests
+
+[ 428570 ] [ euler071 ] unit-test
diff --git a/extra/project-euler/071/071.factor b/extra/project-euler/071/071.factor
new file mode 100644
index 0000000000..1fc08c3548
--- /dev/null
+++ b/extra/project-euler/071/071.factor
@@ -0,0 +1,52 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.ratios sequences ;
+IN: project-euler.071
+
+! http://projecteuler.net/index.php?section=problems&id=71
+
+! DESCRIPTION
+! -----------
+
+! Consider the fraction, n/d, where n and d are positive integers. If n<d and
+! HCF(n,d) = 1, it is called a reduced proper fraction.
+
+! If we list the set of reduced proper fractions for d <= 8 in ascending order of
+! size, we get:
+
+!     1/8, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 3/8, 2/5, 3/7, 1/2, 4/7, 3/5, 5/8,
+!     2/3, 5/7, 3/4, 4/5, 5/6, 6/7, 7/8
+
+! It can be seen that 2/5 is the fraction immediately to the left of 3/7.
+
+! By listing the set of reduced proper fractions for d <= 1,000,000 in
+! ascending order of size, find the numerator of the fraction immediately to the
+! left of 3/7.
+
+
+! SOLUTION
+! --------
+
+! Use the properties of a Farey sequence by setting an upper bound of 3/7 and
+! then taking the mediant of that fraction and the one to its immediate left
+! repeatedly until the denominator is as close to 1000000 as possible without
+! going over.
+
+<PRIVATE
+
+: penultimate ( seq -- elt )
+    dup length 2 - swap nth ;
+
+: mediant ( a/c b/d -- [a+b]/[c+d] )
+    [ >fraction ] bi@ swapd [ + ] 2bi@ / ;
+
+PRIVATE>
+
+: euler071 ( -- answer )
+    2/5 [ dup denominator 1000000 <= ] [ 3/7 mediant dup ] [ ] produce
+    nip penultimate numerator ;
+
+! [ euler071 ] 100 ave-time
+! 155 ms ave run time - 6.95 SD (100 trials)
+
+MAIN: euler071

From b8eebd5c2be585b506b00e57f2307ec35f3db1ce Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 10 Nov 2008 00:16:11 -0600
Subject: [PATCH 242/318] swap over == tuck; dupd swap == over

---
 basis/io/unix/launcher/parser/parser.factor | 2 +-
 basis/peg/ebnf/ebnf.factor                  | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/io/unix/launcher/parser/parser.factor b/basis/io/unix/launcher/parser/parser.factor
index e5e83ab4e9..276ed45f27 100644
--- a/basis/io/unix/launcher/parser/parser.factor
+++ b/basis/io/unix/launcher/parser/parser.factor
@@ -29,5 +29,5 @@ IN: io.unix.launcher.parser
 
 PEG: tokenize-command ( command -- ast/f )
     'argument' " " token repeat1 list-of
-    " " token repeat0 swap over pack
+    " " token repeat0 tuck pack
     just ;
diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor
index 776450ccd9..ccae0fec93 100644
--- a/basis/peg/ebnf/ebnf.factor
+++ b/basis/peg/ebnf/ebnf.factor
@@ -487,7 +487,7 @@ M: ebnf-terminal (transform) ( ast -- parser )
 M: ebnf-foreign (transform) ( ast -- parser )
   dup word>> search
   [ "Foreign word '" swap word>> append "' not found" append throw ] unless*
-  swap rule>> [ main ] unless* dupd swap rule [
+  swap rule>> [ main ] unless* over rule [
     nip
   ] [
     execute

From 57af68f7ed49dfcb3b6217731407cd2bd6ee4433 Mon Sep 17 00:00:00 2001
From: Eric Mertens <emertens@galois.com>
Date: Sun, 9 Nov 2008 22:20:12 -0800
Subject: [PATCH 243/318] add project-euler.215

---
 extra/project-euler/215/215-tests.factor |  5 +++
 extra/project-euler/215/215.factor       | 56 ++++++++++++++++++++++++
 2 files changed, 61 insertions(+)
 create mode 100644 extra/project-euler/215/215-tests.factor
 create mode 100644 extra/project-euler/215/215.factor

diff --git a/extra/project-euler/215/215-tests.factor b/extra/project-euler/215/215-tests.factor
new file mode 100644
index 0000000000..ddd87cc2ff
--- /dev/null
+++ b/extra/project-euler/215/215-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.215 tools.test ;
+IN: project-euler.215.tests
+
+[ 8 ] [ 9 3 solve ] unit-test
+[ 806844323190414 ] [ euler215 ] unit-test
diff --git a/extra/project-euler/215/215.factor b/extra/project-euler/215/215.factor
new file mode 100644
index 0000000000..056de72e50
--- /dev/null
+++ b/extra/project-euler/215/215.factor
@@ -0,0 +1,56 @@
+USING: accessors kernel locals math ;
+IN: project-euler.215
+
+TUPLE: block two three ;
+TUPLE: end { ways integer } ;
+
+C: <block> block
+C: <end> end
+: <failure> 0 <end> ; inline
+: <success> 1 <end> ; inline
+
+: failure? ( t -- ? ) ways>> 0 = ; inline
+
+: choice ( t p q -- t t ) [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline
+
+GENERIC: merge ( t t -- t )
+GENERIC# block-merge 1 ( t t -- t )
+GENERIC# end-merge 1 ( t t -- t )
+M: block merge block-merge ;
+M: end   merge end-merge ;
+M: block block-merge [ [ two>>   ] bi@ merge ]
+                     [ [ three>> ] bi@ merge ] 2bi <block> ;
+M: end   block-merge nip ;
+M: block end-merge drop ;
+M: end   end-merge [ ways>> ] bi@ + <end> ;
+
+GENERIC: h-1 ( t -- t )
+GENERIC: h0 ( t -- t )
+GENERIC: h1 ( t -- t )
+GENERIC: h2 ( t -- t )
+
+M: block h-1 [ h1 ] [ h2 ] choice merge ;
+M: block h0 drop <failure> ;
+M: block h1 [ [ h1 ] [ h2 ] choice merge ]
+            [ [ h0 ] [ h1 ] choice merge ] bi <block> ;
+M: block h2 [ h1 ] [ h2 ] choice merge <failure> swap <block> ;
+
+M: end h-1 drop <failure> ;
+M: end h0 ;
+M: end h1 drop <failure> ;
+M: end h2 dup failure? [ <failure> <block> ] unless ;
+
+: next-row ( t -- t ) [ h-1 ] [ h1 ] choice swap <block> ;
+
+: first-row ( n -- t )
+  [ <failure> <success> <failure> ] dip
+  1- [| a b c | b c <block> a b ] times 2drop ;
+
+GENERIC: total ( t -- n )
+M: block total [ total ] dup choice + ;
+M: end   total ways>> ;
+
+: solve ( width height -- ways )
+  [ first-row ] dip 1- [ next-row ] times total ;
+
+: euler215 ( -- ways ) 32 10 solve ;

From 6df7342b812b53a6c15e7ce100251baaef50c63d Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 10 Nov 2008 02:10:18 -0600
Subject: [PATCH 244/318] ui.gadgets.scrollers: Nicer version of
 'find-scroller*'

---
 basis/ui/gadgets/scrollers/scrollers.factor | 14 ++++++--------
 1 file changed, 6 insertions(+), 8 deletions(-)

diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index 633e3ad4a8..8c63e15a4d 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -4,7 +4,8 @@ USING: accessors arrays ui.gadgets ui.gadgets.viewports
 ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
 ui.gadgets.sliders ui.gestures kernel math namespaces sequences
 models models.range models.compose
-combinators math.vectors classes.tuple math.geometry.rect ;
+combinators math.vectors classes.tuple math.geometry.rect
+combinators.short-circuit ;
 IN: ui.gadgets.scrollers
 
 TUPLE: scroller < frame viewport x y follows ;
@@ -70,13 +71,10 @@ scroller H{
 : relative-scroll-rect ( rect gadget scroller -- newrect )
     viewport>> gadget-child relative-loc offset-rect ;
 
-: find-scroller* ( gadget -- scroller )
-    dup find-scroller dup [
-        2dup viewport>> gadget-child
-        swap child? [ nip ] [ 2drop f ] if
-    ] [
-        2drop f
-    ] if ;
+: find-scroller* ( gadget -- scroller/f )
+    dup find-scroller
+        { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
+    2&& ;
 
 : scroll>rect ( rect gadget -- )
     dup find-scroller* dup [

From 359f177a984e16b25e54b613b9565965453e30d7 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 10 Nov 2008 02:40:14 -0600
Subject: [PATCH 245/318] Remove 'builder' vocabulary (now called 'mason')

---
 extra/builder/build/build.factor             |  46 --------
 extra/builder/builder.factor                 |  21 ----
 extra/builder/child/child.factor             |  68 ------------
 extra/builder/cleanup/cleanup.factor         |  26 -----
 extra/builder/common/common.factor           |  54 ----------
 extra/builder/email/email.factor             |  24 -----
 extra/builder/release/archive/archive.factor |  69 ------------
 extra/builder/release/branch/branch.factor   |  40 -------
 extra/builder/release/release.factor         |  27 -----
 extra/builder/release/tidy/tidy.factor       |  29 -----
 extra/builder/release/upload/upload.factor   |  54 ----------
 extra/builder/report/report.factor           |  35 ------
 extra/builder/test/test.factor               |  35 ------
 extra/builder/updates/updates.factor         |  31 ------
 extra/builder/util/util.factor               | 106 -------------------
 15 files changed, 665 deletions(-)
 delete mode 100644 extra/builder/build/build.factor
 delete mode 100644 extra/builder/builder.factor
 delete mode 100644 extra/builder/child/child.factor
 delete mode 100644 extra/builder/cleanup/cleanup.factor
 delete mode 100644 extra/builder/common/common.factor
 delete mode 100644 extra/builder/email/email.factor
 delete mode 100644 extra/builder/release/archive/archive.factor
 delete mode 100644 extra/builder/release/branch/branch.factor
 delete mode 100644 extra/builder/release/release.factor
 delete mode 100644 extra/builder/release/tidy/tidy.factor
 delete mode 100644 extra/builder/release/upload/upload.factor
 delete mode 100644 extra/builder/report/report.factor
 delete mode 100644 extra/builder/test/test.factor
 delete mode 100644 extra/builder/updates/updates.factor
 delete mode 100644 extra/builder/util/util.factor

diff --git a/extra/builder/build/build.factor b/extra/builder/build/build.factor
deleted file mode 100644
index e9f58980ea..0000000000
--- a/extra/builder/build/build.factor
+++ /dev/null
@@ -1,46 +0,0 @@
-
-USING: io.files io.launcher io.encodings.utf8 prettyprint
-       builder.util builder.common builder.child builder.release
-       builder.report builder.email builder.cleanup ;
-
-IN: builder.build
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: create-build-dir ( -- )
-  datestamp >stamp
-  build-dir make-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: enter-build-dir  ( -- ) build-dir set-current-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: clone-builds-factor ( -- )
-  { "git" "clone" builds/factor } to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: record-id ( -- )
-  "factor"
-    [ git-id "../git-id" utf8 [ . ] with-file-writer ]
-  with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: build ( -- )
-  reset-status
-  create-build-dir
-  enter-build-dir
-  clone-builds-factor
-  record-id
-  build-child
-  release
-  report
-  email-report
-  cleanup ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: build
\ No newline at end of file
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
deleted file mode 100644
index 29daa8160b..0000000000
--- a/extra/builder/builder.factor
+++ /dev/null
@@ -1,21 +0,0 @@
-
-USING: kernel debugger io.files threads calendar 
-       builder.common
-       builder.updates
-       builder.build ;
-
-IN: builder
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: build-loop ( -- )
-  builds-check
-  [
-    builds/factor set-current-directory
-    new-code-available? [ build ] when
-  ]
-  try
-  5 minutes sleep
-  build-loop ;
-
-MAIN: build-loop
\ No newline at end of file
diff --git a/extra/builder/child/child.factor b/extra/builder/child/child.factor
deleted file mode 100644
index 0f701dfdd7..0000000000
--- a/extra/builder/child/child.factor
+++ /dev/null
@@ -1,68 +0,0 @@
-
-USING: namespaces debugger io.files io.launcher accessors bootstrap.image
-       calendar builder.util builder.common ;
-
-IN: builder.child
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-vm ( -- )
-  <process>
-    gnu-make         >>command
-    "../compile-log" >>stdout
-    +stdout+         >>stderr
-  try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ;
-
-: copy-image ( -- )
-  builds-factor-image ".." copy-file-into
-  builds-factor-image "."  copy-file-into ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: boot-cmd ( -- cmd )
-  { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
-
-: boot ( -- )
-  <process>
-    boot-cmd      >>command
-    +closed+      >>stdin
-    "../boot-log" >>stdout
-    +stdout+      >>stderr
-    60 minutes    >>timeout
-  try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
-
-: test ( -- )
-  <process>
-    test-cmd      >>command
-    +closed+      >>stdin
-    "../test-log" >>stdout
-    +stdout+      >>stderr
-    240 minutes   >>timeout
-  try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (build-child) ( -- )
-  make-clean
-  make-vm      status-vm   on
-  copy-image
-  boot         status-boot on
-  test         status-test on
-               status      on ;
-
-: build-child ( -- )
-  "factor" set-current-directory
-    [ (build-child) ] try
-  ".." set-current-directory ;
\ No newline at end of file
diff --git a/extra/builder/cleanup/cleanup.factor b/extra/builder/cleanup/cleanup.factor
deleted file mode 100644
index e601506fb4..0000000000
--- a/extra/builder/cleanup/cleanup.factor
+++ /dev/null
@@ -1,26 +0,0 @@
-
-USING: kernel namespaces io.files io.launcher bootstrap.image
-       builder.util builder.common ;
-
-IN: builder.cleanup
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builder-debug
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
-
-: delete-child-factor ( -- )
-  build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ;
-
-: cleanup ( -- )
-  builder-debug get f =
-    [
-      "test-log" delete-file
-      delete-child-factor
-      compress-image
-    ]
-  when ;
-
diff --git a/extra/builder/common/common.factor b/extra/builder/common/common.factor
deleted file mode 100644
index 474606e451..0000000000
--- a/extra/builder/common/common.factor
+++ /dev/null
@@ -1,54 +0,0 @@
-
-USING: kernel namespaces sequences splitting
-       io io.files io.launcher io.encodings.utf8 prettyprint
-       vars builder.util ;
-
-IN: builder.common
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: upload-to-factorcode
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builds-dir
-
-: builds ( -- path )
-  builds-dir get
-  home "/builds" append
-  or ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-VAR: stamp
-
-: builds/factor ( -- path ) builds "factor" append-path ;
-: build-dir     ( -- path ) builds stamp>   append-path ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prepare-build-machine ( -- )
-  builds make-directory
-  builds
-    [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
-  with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: status-vm
-SYMBOL: status-boot
-SYMBOL: status-test
-SYMBOL: status-build
-SYMBOL: status-release
-SYMBOL: status
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: reset-status ( -- )
-  { status-vm status-boot status-test status-build status-release status }
-    [ off ]
-  each ;
diff --git a/extra/builder/email/email.factor b/extra/builder/email/email.factor
deleted file mode 100644
index ecde47f8f7..0000000000
--- a/extra/builder/email/email.factor
+++ /dev/null
@@ -1,24 +0,0 @@
-
-USING: kernel namespaces accessors smtp builder.util builder.common ;
-
-IN: builder.email
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builder-from
-SYMBOL: builder-recipients
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
-
-: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
-
-: email-report ( -- )
-  <email>
-    builder-from get       >>from
-    builder-recipients get >>to
-    subject                >>subject
-    "report" file>string   >>body
-  send-email ;
-
diff --git a/extra/builder/release/archive/archive.factor b/extra/builder/release/archive/archive.factor
deleted file mode 100644
index 25153436e6..0000000000
--- a/extra/builder/release/archive/archive.factor
+++ /dev/null
@@ -1,69 +0,0 @@
-
-USING: kernel combinators system sequences io.files io.launcher prettyprint
-       builder.util
-       builder.common ;
-
-IN: builder.release.archive
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: base-name ( -- string )
-  { "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
-
-: extension ( -- extension )
-  {
-    { [ os winnt?  ] [ ".zip"    ] }  
-    { [ os macosx? ] [ ".dmg"    ] }
-    { [ os unix?   ] [ ".tar.gz" ] }
-  }
-  cond ;
-
-: archive-name ( -- string ) base-name extension append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
-
-! : macosx-archive-cmd ( -- cmd )
-!   { "hdiutil" "create"
-!               "-srcfolder" "factor"
-!               "-fs" "HFS+"
-!               "-volname" "factor"
-!               archive-name } ;
-
-: macosx-archive-cmd ( -- cmd )
-  { "mkdir" "dmg-root" }                         try-process
-  { "cp" "-r" "factor" "dmg-root" }              try-process
-  { "hdiutil" "create"
-              "-srcfolder" "dmg-root"
-              "-fs" "HFS+"
-              "-volname" "factor"
-              archive-name }          to-strings try-process
-  { "rm" "-rf" "dmg-root" }                      try-process
-  { "true" } ;
-
-: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: archive-cmd ( -- cmd )
-  {
-    { [ os windows? ] [ windows-archive-cmd ] }
-    { [ os macosx?  ] [ macosx-archive-cmd  ] }
-    { [ os unix?    ] [ unix-archive-cmd    ] }
-  }
-  cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-archive ( -- ) archive-cmd to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: releases ( -- path )
-  builds "releases" append-path
-  dup exists? not
-    [ dup make-directory ]
-  when ;
-
-: save-archive ( -- ) archive-name releases move-file-into ;
\ No newline at end of file
diff --git a/extra/builder/release/branch/branch.factor b/extra/builder/release/branch/branch.factor
deleted file mode 100644
index 6b1266bb45..0000000000
--- a/extra/builder/release/branch/branch.factor
+++ /dev/null
@@ -1,40 +0,0 @@
-
-USING: kernel system namespaces sequences prettyprint io.files io.launcher
-       bootstrap.image
-       builder.util
-       builder.common ;
-
-IN: builder.release.branch
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: branch-name ( -- string ) "clean-" platform append ;
-
-: refspec ( -- string ) "master:" branch-name append ;
-
-: push-to-clean-branch ( -- )
-  { "git" "push" "factorcode.org:/git/factor.git" refspec }
-  to-strings
-  try-process ;
-
-: upload-clean-image ( -- )
-  {
-    "scp"
-    my-boot-image-name
-    { "factorcode.org:/var/www/factorcode.org/newsite/images/clean/" platform }
-  }
-  to-strings
-  try-process ;
-
-: (update-clean-branch) ( -- )
-  "factor"
-    [
-      push-to-clean-branch
-      upload-clean-image
-    ]
-  with-directory ;
-
-: update-clean-branch ( -- )
-  upload-to-factorcode get
-    [ (update-clean-branch) ]
-  when ;
diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor
deleted file mode 100644
index 28ce3e8b35..0000000000
--- a/extra/builder/release/release.factor
+++ /dev/null
@@ -1,27 +0,0 @@
-
-USING: kernel debugger system namespaces sequences splitting combinators
-       io io.files io.launcher prettyprint bootstrap.image
-       combinators.cleave
-       builder.util
-       builder.common
-       builder.release.branch
-       builder.release.tidy
-       builder.release.archive
-       builder.release.upload ;
-
-IN: builder.release
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (release) ( -- )
-  update-clean-branch
-  tidy
-  make-archive
-  upload
-  save-archive
-  status-release on ;
-
-: clean-build? ( -- ? )
-  { "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ;
-
-: release ( -- ) [ clean-build? [ (release) ] when ] try ;
\ No newline at end of file
diff --git a/extra/builder/release/tidy/tidy.factor b/extra/builder/release/tidy/tidy.factor
deleted file mode 100644
index f8f27e75f2..0000000000
--- a/extra/builder/release/tidy/tidy.factor
+++ /dev/null
@@ -1,29 +0,0 @@
-
-USING: kernel system io.files io.launcher builder.util ;
-
-IN: builder.release.tidy
-
-: common-files ( -- seq )
-  {
-    "boot.x86.32.image"
-    "boot.x86.64.image"
-    "boot.macosx-ppc.image"
-    "boot.linux-ppc.image"
-    "vm"
-    "temp"
-    "logs"
-    ".git"
-    ".gitignore"
-    "Makefile"
-    "unmaintained"
-    "build-support"
-  } ;
-
-: remove-common-files ( -- )
-  { "rm" "-rf" common-files } to-strings try-process ;
-
-: remove-factor-app ( -- )
-  os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
-
-: tidy ( -- )
-  "factor" [ remove-factor-app remove-common-files ] with-directory ;
diff --git a/extra/builder/release/upload/upload.factor b/extra/builder/release/upload/upload.factor
deleted file mode 100644
index 19d3936fd9..0000000000
--- a/extra/builder/release/upload/upload.factor
+++ /dev/null
@@ -1,54 +0,0 @@
-
-USING: kernel namespaces make sequences arrays io io.files
-       builder.util
-       builder.common
-       builder.release.archive ;
-
-IN: builder.release.upload
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: upload-host
-
-SYMBOL: upload-username
-
-SYMBOL: upload-directory
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: remote-location ( -- dest )
-  upload-directory get platform append ;
-
-: remote-archive-name ( -- dest )
-  remote-location "/" archive-name 3append ;
-
-: temp-archive-name ( -- dest )
-  remote-archive-name ".incomplete" append ;
-
-: upload-command ( -- args )
-  "scp"
-  archive-name
-  [ upload-username get % "@" % upload-host get % ":" % temp-archive-name % ] "" make
-  3array ;
-
-: rename-command ( -- args )
-  [
-    "ssh" ,
-    upload-host get ,
-    "-l" ,
-    upload-username get ,
-    "mv" ,
-    temp-archive-name ,
-    remote-archive-name ,
-  ] { } make ;
-
-: upload-temp-file ( -- )
-  upload-command [ "Error uploading binary to factorcode" print ] run-or-bail ;
-
-: rename-temp-file ( -- )
-  rename-command [ "Error renaming binary on factorcode" print ] run-or-bail ;
-
-: upload ( -- )
-  upload-to-factorcode get
-    [ upload-temp-file rename-temp-file ]
-  when ;
diff --git a/extra/builder/report/report.factor b/extra/builder/report/report.factor
deleted file mode 100644
index 2ac8482a76..0000000000
--- a/extra/builder/report/report.factor
+++ /dev/null
@@ -1,35 +0,0 @@
-
-USING: kernel namespaces debugger system io io.files io.sockets
-       io.encodings.utf8 prettyprint benchmark
-       builder.util builder.common ;
-
-IN: builder.report
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: (report) ( -- )
-
-  "Build machine:   " write host-name             print
-  "CPU:             " write cpu                   .
-  "OS:              " write os                    .
-  "Build directory: " write build-dir             print
-  "git id:          " write "git-id" eval-file    print nl
-
-  status-vm   get f = [ "compile-log"  cat   "vm compile error" throw ] when
-  status-boot get f = [ "boot-log" 100 cat-n "Boot error"       throw ] when
-  status-test get f = [ "test-log" 100 cat-n "Test error"       throw ] when
-
-  "Boot time: " write "boot-time" eval-file milli-seconds>time print
-  "Load time: " write "load-time" eval-file milli-seconds>time print
-  "Test time: " write "test-time" eval-file milli-seconds>time print nl
-
-  "Did not pass load-everything: " print "load-everything-vocabs" cat
-      
-  "Did not pass test-all: "        print "test-all-vocabs"        cat
-                                         "test-failures"          cat
-      
-  "help-lint results:"             print "help-lint"              cat
-
-  "Benchmarks: " print "benchmarks" eval-file benchmarks. ;
-
-: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ;
\ No newline at end of file
diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor
deleted file mode 100644
index 2a0769f278..0000000000
--- a/extra/builder/test/test.factor
+++ /dev/null
@@ -1,35 +0,0 @@
-
-USING: kernel namespaces assocs
-       io.files io.encodings.utf8 prettyprint 
-       help.lint
-       benchmark
-       tools.time
-       bootstrap.stage2
-       tools.test tools.vocabs
-       builder.util ;
-
-IN: builder.test
-
-: do-load ( -- )
-  try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
-
-: do-tests ( -- )
-  run-all-tests
-    [ keys "../test-all-vocabs" utf8 [ .              ] with-file-writer ]
-    [      "../test-failures"   utf8 [ test-failures. ] with-file-writer ]
-  bi ;
-
-: do-help-lint ( -- )
-  "" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
-
-: do-benchmarks ( -- )
-  run-benchmarks "../benchmarks" utf8 [ . ] with-file-writer ;
-
-: do-all ( -- )
-  bootstrap-time get   "../boot-time" utf8 [ . ] with-file-writer
-  [ do-load  ] benchmark "../load-time" utf8 [ . ] with-file-writer
-  [ do-tests ] benchmark "../test-time" utf8 [ . ] with-file-writer
-  do-help-lint
-  do-benchmarks ;
-
-MAIN: do-all
\ No newline at end of file
diff --git a/extra/builder/updates/updates.factor b/extra/builder/updates/updates.factor
deleted file mode 100644
index a8184550e0..0000000000
--- a/extra/builder/updates/updates.factor
+++ /dev/null
@@ -1,31 +0,0 @@
-
-USING: kernel io.launcher bootstrap.image bootstrap.image.download
-       builder.util builder.common ;
-
-IN: builder.updates
-
-: git-pull-cmd ( -- cmd )
-  {
-    "git"
-    "pull"
-    "--no-summary"
-    "git://factorcode.org/git/factor.git"
-    "master"
-  } ;
-
-: updates-available? ( -- ? )
-  git-id
-  git-pull-cmd try-process
-  git-id
-  = not ;
-
-: new-image-available? ( -- ? )
-  my-boot-image-name need-new-image?
-    [ download-my-image t ]
-    [ f ]
-  if ;
-
-: new-code-available? ( -- ? )
-  updates-available?
-  new-image-available?
-  or ;
\ No newline at end of file
diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor
deleted file mode 100644
index 32d1e45066..0000000000
--- a/extra/builder/util/util.factor
+++ /dev/null
@@ -1,106 +0,0 @@
-
-USING: kernel words namespaces classes parser continuations
-       io io.files io.launcher io.sockets
-       math math.parser
-       system
-       combinators sequences splitting quotations arrays strings tools.time
-       sequences.deep accessors assocs.lib
-       io.encodings.utf8
-       combinators.cleave calendar calendar.format eval ;
-
-IN: builder.util
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: minutes>ms ( min -- ms ) 60 * 1000 * ;
-
-: file>string ( file -- string ) utf8 file-contents ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: to-strings
-
-: to-string ( obj -- str )
-  dup class
-    {
-      { \ string    [ ] }
-      { \ quotation [ call ] }
-      { \ word      [ execute ] }
-      { \ fixnum    [ number>string ] }
-      { \ array     [ to-strings concat ] }
-    }
-  case ;
-
-: to-strings ( seq -- str )
-  dup [ string? ] all?
-    [ ]
-    [ [ to-string ] map flatten ]
-  if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: host-name* ( -- name ) host-name "." split first ;
-
-: datestamp ( -- string )
-  now
-    { year>> month>> day>> hour>> minute>> } <arr>
-  [ pad-00 ] map "-" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: milli-seconds>time ( n -- string )
-  1000 /i 60 /mod >r 60 /mod r> 3array [ pad-00 ] map ":" join ;
-
-: eval-file ( file -- obj ) utf8 file-contents eval ;
-
-: cat ( file -- ) utf8 file-contents print ;
-
-: run-or-bail ( desc quot -- )
-  [ [ try-process ] curry   ]
-  [ [ throw       ] compose ]
-  bi*
-  recover ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USING: bootstrap.image bootstrap.image.download io.streams.null ;
-
-: retrieve-image ( -- ) [ my-arch download-image ] with-null-stream ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: longer? ( seq seq -- ? ) [ length ] bi@ > ; 
-
-: maybe-tail* ( seq n -- seq )
-  2dup longer?
-    [ tail* ]
-    [ drop  ]
-  if ;
-
-: cat-n ( file n -- )
-  [ utf8 file-lines ] [ ] bi*
-  maybe-tail*
-  [ print ] each ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: prettyprint
-
-: to-file ( object file -- ) utf8 [ . ] with-file-writer ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
-
-: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: gnu-make ( -- string )
-  os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-id ( -- id )
-  { "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
-  " " split second ;

From 33a082c361e890874097ac9dfdf6e4d459c23bad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 10 Nov 2008 02:43:16 -0600
Subject: [PATCH 246/318] Fix reference to obsolete G: word

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

diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor
index 1d98dec87c..15913b46be 100644
--- a/core/generic/standard/standard-docs.factor
+++ b/core/generic/standard/standard-docs.factor
@@ -16,7 +16,7 @@ HELP: standard-combination
 { $examples
     "A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
     { $code
-        "G: build-string 1 standard-combination ;"
+        "GENERIC# build-string 1 ( elt str -- )"
         "M: string build-string swap push-all ;"
         "M: integer build-string push ;"
     }

From 5b7d40d9b48f7abd19949db6391466f37d59b0c2 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@oberon.local>
Date: Mon, 10 Nov 2008 02:58:05 -0600
Subject: [PATCH 247/318] We need to end the basic block after the ##prologue
 in the dispatch branch so that the GC check can go after the prologue

---
 basis/compiler/cfg/builder/builder.factor |  1 +
 basis/compiler/tests/templates.factor     | 11 +++++++++++
 2 files changed, 12 insertions(+)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 93daa601fe..17a5942af2 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -171,6 +171,7 @@ M: #if emit-node
             [
                 V{ } clone node-stack set
                 ##prologue
+                begin-basic-block
                 emit-nodes
                 basic-block get [
                     ##epilogue
diff --git a/basis/compiler/tests/templates.factor b/basis/compiler/tests/templates.factor
index de87ad8c00..0a109a15eb 100644
--- a/basis/compiler/tests/templates.factor
+++ b/basis/compiler/tests/templates.factor
@@ -219,3 +219,14 @@ TUPLE: my-tuple ;
 : bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
 
 [ { f f f } ] [ t bad-value-bug ] unit-test
+
+! PowerPC regression
+TUPLE: id obj ;
+
+: (gc-check-bug) ( a b -- c )
+    { [ id boa ] [ id boa ] } dispatch ;
+
+: gc-check-bug ( -- )
+    10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
+
+[ ] [ gc-check-bug ] unit-test

From ffe4bd6787125f6d94785510a480fc1d57e43067 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@oberon.local>
Date: Mon, 10 Nov 2008 03:18:58 -0600
Subject: [PATCH 248/318] Various updates

---
 basis/cpu/ppc/ppc.factor | 100 +++++++++++++++++++++------------------
 1 file changed, 53 insertions(+), 47 deletions(-)

diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 2be46d15ee..49caae4bb8 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -4,7 +4,8 @@ USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
 alien alien.c-types cpu.architecture cpu.ppc.assembler
 compiler.cfg.registers compiler.cfg.instructions
-compiler.constants compiler.codegen compiler.codegen.fixup ;
+compiler.constants compiler.codegen compiler.codegen.fixup
+compiler.cfg.intrinsics compiler.cfg.stack-frame ;
 IN: cpu.ppc
 
 ! PowerPC register assignments:
@@ -15,15 +16,19 @@ IN: cpu.ppc
 ! f0-f29: float vregs
 ! f30, f31: float scratch
 
+enable-float-intrinsics
+
+<< \ ##integer>float t frame-required? set-word-prop
+\ ##float>integer t frame-required? set-word-prop >>
+
 M: ppc machine-registers
     {
         { int-regs T{ range f 2 26 1 } }
-        { double-float-regs T{ range f 0 28 1 } }
+        { double-float-regs T{ range f 0 29 1 } }
     } ;
 
 : scratch-reg 28 ; inline
-: fp-scratch-reg-1 29 ; inline
-: fp-scratch-reg-2 30 ; inline
+: fp-scratch-reg 30 ; inline
 
 M: ppc two-operand? f ;
 
@@ -54,8 +59,16 @@ M: ppc %inc-d ( n -- ) ds-reg (%inc) ;
 M: ppc %inc-r ( n -- ) rs-reg (%inc) ;
 
 HOOK: reserved-area-size os ( -- n )
-HOOK: lr-save os ( -- n )
 
+! The start of the stack frame contains the size of this frame
+! as well as the currently executing XT
+: factor-area-size ( -- n ) 2 cells ; foldable
+: next-save ( n -- i ) cell - ;
+: xt-save ( n -- i ) 2 cells - ;
+
+! Next, we have the spill area as well as the FFI parameter area.
+! They overlap, since basic blocks with FFI calls will never
+! spill.
 : param@ ( n -- x ) reserved-area-size + ; inline
 
 : param-save-size ( -- n ) 8 cells ; foldable
@@ -63,19 +76,34 @@ HOOK: lr-save os ( -- n )
 : local@ ( n -- x )
     reserved-area-size param-save-size + + ; inline
 
-: factor-area-size ( -- n ) 2 cells ; foldable
+: spill-integer-base ( -- n )
+    stack-frame get spill-counts>> double-float-regs swap at
+    double-float-regs reg-size * ;
 
-: next-save ( n -- i ) cell - ;
+: spill-integer@ ( n -- offset )
+    cells spill-integer-base + param@ ;
 
-: xt-save ( n -- i ) 2 cells - ;
+: spill-float@ ( n -- offset )
+    double-float-regs reg-size * param@ ;
+
+! Some FP intrinsics need a temporary scratch area in the stack
+! frame, 8 bytes in size
+: scratch@ ( n -- offset )
+    stack-frame get total-size>>
+    factor-area-size -
+    param-save-size -
+    + ;
+
+! Finally we have the linkage area
+HOOK: lr-save os ( -- n )
 
 M: ppc stack-frame-size ( stack-frame -- i )
     [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
     [ params>> ]
     [ return>> ]
     tri + +
-    reserved-area-size +
     param-save-size +
+    reserved-area-size +
     factor-area-size +
     4 cells align ;
 
@@ -198,19 +226,19 @@ M: ppc %div-float FDIV ;
 
 M:: ppc %integer>float ( dst src -- )
     HEX: 4330 scratch-reg LIS
-    scratch-reg 1 0 param@ STW
+    scratch-reg 1 0 scratch@ STW
     scratch-reg src MR
     scratch-reg dup HEX: 8000 XORIS
-    scratch-reg 1 cell param@ STW
-    fp-scratch-reg-2 1 0 param@ LFD
+    scratch-reg 1 4 scratch@ STW
+    dst 1 0 scratch@ LFD
     scratch-reg 4503601774854144.0 %load-indirect
-    fp-scratch-reg-2 scratch-reg float-offset LFD
-    fp-scratch-reg-2 fp-scratch-reg-2 fp-scratch-reg-2 FSUB ;
+    fp-scratch-reg scratch-reg float-offset LFD
+    dst dst fp-scratch-reg FSUB ;
 
 M:: ppc %float>integer ( dst src -- )
-    fp-scratch-reg-1 src FCTIWZ
-    fp-scratch-reg-2 1 0 param@ STFD
-    dst 1 4 param@ LWZ ;
+    fp-scratch-reg src FCTIWZ
+    fp-scratch-reg 1 0 scratch@ STFD
+    dst 1 4 scratch@ LWZ ;
 
 M: ppc %copy ( dst src -- ) MR ;
 
@@ -218,6 +246,10 @@ M: ppc %copy-float ( dst src -- ) FMR ;
 
 M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
 
+M:: ppc %box-float ( dst src temp -- )
+    dst 16 float temp %allot
+    src dst float-offset STFD ;
+
 M:: ppc %unbox-any-c-ptr ( dst src temp -- )
     [
         { "is-byte-array" "end" "start" } [ define-label ] each
@@ -349,11 +381,6 @@ M: ppc %gc
     "end" resolve-label ;
 
 M: ppc %prologue ( n -- )
-    #! We use a volatile register (r11) here for scratch. Because
-    #! callback bodies have a prologue too, we cannot assume
-    #! that c_to_factor saved all non-volatile registers, so
-    #! we have to respect the C calling convention. Also, we
-    #! cannot touch any param-regs either.
     0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
     0 MFLR
     1 1 pick neg ADDI
@@ -410,32 +437,11 @@ M: ppc %compare-branch (%compare) %branch ;
 M: ppc %compare-imm-branch (%compare-imm) %branch ;
 M: ppc %compare-float-branch (%compare-float) %branch ;
 
-: spill-integer-base ( stack-frame -- n )
-    [ params>> ] [ return>> ] bi + ;
+M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ;
+M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ;
 
-: stack@ 1 swap ; inline
-
-: spill-integer@ ( n -- reg offset )
-    cells
-    stack-frame get spill-integer-base
-    + stack@ ;
-
-: spill-float-base ( stack-frame -- n )
-    [ spill-counts>> int-regs swap at int-regs reg-size * ]
-    [ params>> ]
-    [ return>> ]
-    tri + + ;
-
-: spill-float@ ( n -- reg offset )
-    double-float-regs reg-size *
-    stack-frame get spill-float-base
-    + stack@ ;
-
-M: ppc %spill-integer ( src n -- ) spill-integer@ STW ;
-M: ppc %reload-integer ( dst n -- ) spill-integer@ LWZ ;
-
-M: ppc %spill-float ( src n -- ) spill-float@ STFD ;
-M: ppc %reload-float ( dst n -- ) spill-float@ LFD ;
+M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ;
+M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ;
 
 M: ppc %loop-entry ;
 

From 17be33fb013b2fd94f7d4efe7dac5ca7f39bc835 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 10 Nov 2008 03:35:21 -0600
Subject: [PATCH 249/318] ui.gadgets.labelled: Simplify '<title-bar>'

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

diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor
index 8cf13c8367..37b1d251e8 100644
--- a/basis/ui/gadgets/labelled/labelled.factor
+++ b/basis/ui/gadgets/labelled/labelled.factor
@@ -39,7 +39,7 @@ M: labelled-gadget focusable-child* content>> ;
 
 : <title-bar> ( title quot -- gadget )
     <frame>
-        swap dup [ <close-box> @left grid-add ] [ drop ] if
+        swap [ <close-box> @left grid-add ] when*
         swap <title-label> @center grid-add ;
 
 TUPLE: closable-gadget < frame content ;

From eeb53283d4c1ec4ed86b9b2d2ca53315a45d4ccf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 10 Nov 2008 05:07:25 -0600
Subject: [PATCH 250/318] Update code for builder removal

---
 basis/tools/test/test-docs.factor                   | 2 +-
 {extra => unmaintained}/size-of/size-of.factor      | 0
 {extra => unmaintained}/update/backup/backup.factor | 0
 {extra => unmaintained}/update/latest/latest.factor | 0
 {extra => unmaintained}/update/update.factor        | 0
 5 files changed, 1 insertion(+), 1 deletion(-)
 rename {extra => unmaintained}/size-of/size-of.factor (100%)
 rename {extra => unmaintained}/update/backup/backup.factor (100%)
 rename {extra => unmaintained}/update/latest/latest.factor (100%)
 rename {extra => unmaintained}/update/update.factor (100%)

diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor
index 4b2521d19c..02c0ad126d 100644
--- a/basis/tools/test/test-docs.factor
+++ b/basis/tools/test/test-docs.factor
@@ -17,7 +17,7 @@ ARTICLE: "tools.test.run" "Running unit tests"
 { $subsection test-all } ;
 
 ARTICLE: "tools.test.failure" "Handling test failures"
-"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Sometimes, you want to develop a tool which inspects the test failures and takes some kind of action instead; one example is " { $vocab-link "builder" } "."
+"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "."
 $nl
 "The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:"
 { $list
diff --git a/extra/size-of/size-of.factor b/unmaintained/size-of/size-of.factor
similarity index 100%
rename from extra/size-of/size-of.factor
rename to unmaintained/size-of/size-of.factor
diff --git a/extra/update/backup/backup.factor b/unmaintained/update/backup/backup.factor
similarity index 100%
rename from extra/update/backup/backup.factor
rename to unmaintained/update/backup/backup.factor
diff --git a/extra/update/latest/latest.factor b/unmaintained/update/latest/latest.factor
similarity index 100%
rename from extra/update/latest/latest.factor
rename to unmaintained/update/latest/latest.factor
diff --git a/extra/update/update.factor b/unmaintained/update/update.factor
similarity index 100%
rename from extra/update/update.factor
rename to unmaintained/update/update.factor

From d8a3439bc24a4aab986c826376eeb50f6ee4b2da Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 10 Nov 2008 05:08:30 -0600
Subject: [PATCH 251/318] Fix indentation

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

diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index 8c63e15a4d..d1429c4006 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -73,7 +73,7 @@ scroller H{
 
 : find-scroller* ( gadget -- scroller/f )
     dup find-scroller
-        { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
+    { [ nip ] [ viewport>> gadget-child swap child? ] [ nip ] }
     2&& ;
 
 : scroll>rect ( rect gadget -- )

From 9be9538230014e62f71fe671f043a25c0aaf5586 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Mon, 10 Nov 2008 12:38:01 -0500
Subject: [PATCH 252/318] Update Project Euler using line

---
 extra/project-euler/project-euler.factor | 15 ++++++++-------
 1 file changed, 8 insertions(+), 7 deletions(-)

diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index d85e7e206d..1e808e6321 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: definitions io io.files kernel math math.parser project-euler.ave-time
-    sequences vocabs vocabs.loader prettyprint
+USING: definitions io io.files kernel math math.parser
+    prettyprint project-euler.ave-time sequences vocabs vocabs.loader
     project-euler.001 project-euler.002 project-euler.003 project-euler.004
     project-euler.005 project-euler.006 project-euler.007 project-euler.008
     project-euler.009 project-euler.010 project-euler.011 project-euler.012
@@ -15,11 +15,12 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time
     project-euler.041 project-euler.042 project-euler.043 project-euler.044
     project-euler.045 project-euler.046 project-euler.047 project-euler.048
     project-euler.052 project-euler.053 project-euler.055 project-euler.056
-    project-euler.059 project-euler.067 project-euler.075 project-euler.076
-    project-euler.079 project-euler.092 project-euler.097 project-euler.100
-    project-euler.116 project-euler.117 project-euler.134 project-euler.148
-    project-euler.150 project-euler.151 project-euler.164 project-euler.169
-    project-euler.173 project-euler.175 project-euler.186 project-euler.190 ;
+    project-euler.059 project-euler.067 project-euler.071 project-euler.075
+    project-euler.076 project-euler.079 project-euler.092 project-euler.097
+    project-euler.100 project-euler.116 project-euler.117 project-euler.134
+    project-euler.148 project-euler.150 project-euler.151 project-euler.164
+    project-euler.169 project-euler.173 project-euler.175 project-euler.186
+    project-euler.190 ;
 IN: project-euler
 
 <PRIVATE

From db7cbed3a5d8b83b2b03b2c0eb710037047219e0 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Mon, 10 Nov 2008 12:51:43 -0500
Subject: [PATCH 253/318] Move ratio mediant word to project-euler.common

---
 extra/project-euler/071/071.factor       | 5 +----
 extra/project-euler/common/common.factor | 8 ++++++--
 2 files changed, 7 insertions(+), 6 deletions(-)

diff --git a/extra/project-euler/071/071.factor b/extra/project-euler/071/071.factor
index 1fc08c3548..feecd997fa 100644
--- a/extra/project-euler/071/071.factor
+++ b/extra/project-euler/071/071.factor
@@ -1,6 +1,6 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ratios sequences ;
+USING: kernel math project-euler.common sequences ;
 IN: project-euler.071
 
 ! http://projecteuler.net/index.php?section=problems&id=71
@@ -37,9 +37,6 @@ IN: project-euler.071
 : penultimate ( seq -- elt )
     dup length 2 - swap nth ;
 
-: mediant ( a/c b/d -- [a+b]/[c+d] )
-    [ >fraction ] bi@ swapd [ + ] 2bi@ / ;
-
 PRIVATE>
 
 : euler071 ( -- answer )
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index 8176414153..35d9c65b53 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -1,8 +1,8 @@
 ! Copyright (c) 2007-2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel make math math.functions math.matrices math.miller-rabin
-    math.order math.parser math.primes.factors math.ranges sequences
-    sequences.lib sorting strings unicode.case ;
+    math.order math.parser math.primes.factors math.ranges math.ratios
+    sequences sequences.lib sorting strings unicode.case ;
 IN: project-euler.common
 
 ! A collection of words used by more than one Project Euler solution
@@ -14,6 +14,7 @@ IN: project-euler.common
 ! cartesian-product - #4, #27, #29, #32, #33, #43, #44, #56
 ! log10 - #25, #134
 ! max-path - #18, #67
+! mediant - #71, #73
 ! nth-triangle - #12, #42
 ! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
 ! palindrome? - #4, #36, #55
@@ -60,6 +61,9 @@ PRIVATE>
 : log10 ( m -- n )
     log 10 log / ;
 
+: mediant ( a/c b/d -- (a+b)/(c+d) )
+    2>fraction [ + ] 2bi@ / ;
+
 : max-path ( triangle -- n )
     dup length 1 > [
         2 cut* first2 max-children [ + ] 2map suffix max-path

From 6189bfd1f08954d6748001f0c7e2c73f859caafb Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 10 Nov 2008 17:01:14 -0800
Subject: [PATCH 254/318] bring cairo bindings back from the dead

---
 basis/opengl/opengl.factor                | 10 +++----
 extra/opengl/gadgets/gadgets.factor       |  2 +-
 unmaintained/cairo/cairo.factor           |  2 +-
 unmaintained/cairo/ffi/ffi.factor         |  2 +-
 unmaintained/cairo/gadgets/gadgets.factor | 21 +++++++-------
 unmaintained/cairo/samples/samples.factor | 34 ++++++++++++++++-------
 6 files changed, 43 insertions(+), 28 deletions(-)

diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index bae05f4244..5d9baf644d 100644
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -16,17 +16,17 @@ IN: opengl
 : fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
     [ first2 [ >fixnum ] bi@ ] bi@ ;
 
-: gl-color ( color -- ) first4 glColor4d ; inline
+: color>raw ( object -- r g b a )
+    >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
+
+: gl-color ( color -- ) color>raw glColor4d ; inline
 
 : gl-clear-color ( color -- )
-    first4 glClearColor ;
+    color>raw glClearColor ;
 
 : gl-clear ( color -- )
     gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
 
-: color>raw ( object -- r g b a )
-    >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
-
 : set-color ( object -- ) color>raw glColor4d ;
 : set-clear-color ( object -- ) color>raw glClearColor ;
 
diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor
index 9e670c04ab..cfedf32079 100644
--- a/extra/opengl/gadgets/gadgets.factor
+++ b/extra/opengl/gadgets/gadgets.factor
@@ -6,7 +6,7 @@ fry assocs
 destructors sequences ui.render colors ;
 IN: opengl.gadgets
 
-TUPLE: texture-gadget ;
+TUPLE: texture-gadget < gadget ;
 
 GENERIC: render* ( gadget -- texture dims )
 GENERIC: cache-key* ( gadget -- key )
diff --git a/unmaintained/cairo/cairo.factor b/unmaintained/cairo/cairo.factor
index 46d3e42c2b..aa7d1159a6 100755
--- a/unmaintained/cairo/cairo.factor
+++ b/unmaintained/cairo/cairo.factor
@@ -33,4 +33,4 @@ SYMBOL: cairo
     >r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
 
 : with-cairo-from-surface ( cairo_surface quot -- )
-    '[ cairo_create , with-cairo ] with-surface ; inline
+    '[ cairo_create _ with-cairo ] with-surface ; inline
diff --git a/unmaintained/cairo/ffi/ffi.factor b/unmaintained/cairo/ffi/ffi.factor
index 451806c0a7..db18320fee 100644
--- a/unmaintained/cairo/ffi/ffi.factor
+++ b/unmaintained/cairo/ffi/ffi.factor
@@ -10,7 +10,7 @@ alien.c-types accessors sequences arrays ui.gadgets ;
 IN: cairo.ffi
 << "cairo" {
     { [ os winnt? ] [ "libcairo-2.dll" ] }
-    { [ os macosx? ] [ "libcairo.dylib" ] }
+    { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
     { [ os unix? ] [ "libcairo.so.2" ] }
 } cond "cdecl" add-library >>
 
diff --git a/unmaintained/cairo/gadgets/gadgets.factor b/unmaintained/cairo/gadgets/gadgets.factor
index c9fef618f8..d160740c44 100644
--- a/unmaintained/cairo/gadgets/gadgets.factor
+++ b/unmaintained/cairo/gadgets/gadgets.factor
@@ -3,7 +3,7 @@
 USING: sequences math opengl.gadgets kernel
 byte-arrays cairo.ffi cairo io.backend
 ui.gadgets accessors opengl.gl
-arrays ;
+arrays fry classes ;
 
 IN: cairo.gadgets
 
@@ -15,21 +15,22 @@ IN: cairo.gadgets
     [ cairo_image_surface_create_for_data ] 3bi
     r> with-cairo-from-surface ; inline
 
-TUPLE: cairo-gadget < texture-gadget dim quot ;
+TUPLE: cairo-gadget < texture-gadget ;
 
-: <cairo-gadget> ( dim quot -- gadget )
-    cairo-gadget construct-gadget
-        swap >>quot
+: <cairo-gadget> ( dim -- gadget )
+    cairo-gadget new-gadget
         swap >>dim ;
 
-M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
+M: cairo-gadget cache-key* [ dim>> ] [ class ] bi 2array ;
 
 : render-cairo ( dim quot -- bytes format )
     >r 2^-bounds r> copy-cairo GL_BGRA ; inline
 
-! M: cairo-gadget render*
-!     [ dim>> dup ] [ quot>> ] bi
-!     render-cairo render-bytes* ;
+GENERIC: render-cairo* ( gadget -- )
+
+M: cairo-gadget render*
+    [ dim>> dup ] [ '[ _ render-cairo* ] ] bi
+    render-cairo render-bytes* ;
 
 ! maybe also texture>png
 ! : cairo>png ( gadget path -- )
@@ -44,7 +45,7 @@ M: cairo-gadget cache-key* [ dim>> ] [ quot>> ] bi 2array ;
 
 TUPLE: png-gadget < texture-gadget path ;
 : <png> ( path -- gadget )
-    png-gadget construct-gadget
+    png-gadget new-gadget
         swap >>path ;
 
 M: png-gadget render*
diff --git a/unmaintained/cairo/samples/samples.factor b/unmaintained/cairo/samples/samples.factor
index 0e83381349..0f21142f2a 100644
--- a/unmaintained/cairo/samples/samples.factor
+++ b/unmaintained/cairo/samples/samples.factor
@@ -4,11 +4,13 @@
 ! these samples are a subset of the samples on
 ! http://cairographics.org/samples/
 USING: cairo cairo.ffi locals math.constants math
-io.backend kernel alien.c-types libc namespaces ;
+io.backend kernel alien.c-types libc namespaces
+cairo.gadgets ui.gadgets accessors ;
 
 IN: cairo.samples
 
-:: arc ( -- )
+TUPLE: arc-gadget < cairo-gadget ;
+M:: arc-gadget render-cairo* ( gadget -- )
     [let | xc [ 128.0 ]
            yc [ 128.0 ]
            radius [ 100.0 ]
@@ -32,7 +34,9 @@ IN: cairo.samples
         cr cairo_stroke
     ] ;
 
-: clip ( -- )
+TUPLE: clip-gadget < cairo-gadget ;
+M: clip-gadget render-cairo* ( gadget -- )
+    drop
     cr 128 128 76.8 0 2 pi * cairo_arc
     cr cairo_clip
     cr cairo_new_path
@@ -47,7 +51,8 @@ IN: cairo.samples
     cr 10 cairo_set_line_width
     cr cairo_stroke ;
 
-:: clip-image ( -- )
+TUPLE: clip-image-gadget < cairo-gadget ;
+M:: clip-image-gadget render-cairo* ( gadget -- )
     [let* | png [ "resource:misc/icons/Factor_128x128.png"
                   normalize-path cairo_image_surface_create_from_png ]
             w [ png cairo_image_surface_get_width ]
@@ -62,7 +67,8 @@ IN: cairo.samples
         png cairo_surface_destroy
     ] ;
 
-:: dash ( -- )
+TUPLE: dash-gadget < cairo-gadget ;
+M:: dash-gadget render-cairo* ( gadget -- )
     [let | dashes [ { 50 10 10 10 } >c-double-array ]
            ndash [ 4 ] |
         cr dashes ndash -50 cairo_set_dash
@@ -74,7 +80,8 @@ IN: cairo.samples
         cr cairo_stroke
     ] ;
 
-:: gradient ( -- )
+TUPLE: gradient-gadget < cairo-gadget ;
+M:: gradient-gadget render-cairo* ( gadget -- )
     [let | pat [ 0 0 0 256 cairo_pattern_create_linear ]
            radial [ 115.2 102.4 25.6 102.4 102.4 128.0
                     cairo_pattern_create_radial ] |
@@ -93,7 +100,9 @@ IN: cairo.samples
         radial cairo_pattern_destroy
     ] ;
 
-: text ( -- )
+TUPLE: text-gadget < cairo-gadget ;
+M: text-gadget render-cairo* ( gadget -- )
+    drop
     cr "Serif" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD
     cairo_select_font_face
     cr 50 cairo_set_font_size
@@ -115,7 +124,9 @@ IN: cairo.samples
     cr 70 165 5.12 0 2 pi * cairo_arc
     cr cairo_fill ;
 
-: utf8 ( -- )
+TUPLE: utf8-gadget < cairo-gadget ;
+M: utf8-gadget render-cairo* ( gadget -- )
+    drop
     cr "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_NORMAL
     cairo_select_font_face
     cr 50 cairo_set_font_size
@@ -141,7 +152,10 @@ IN: cairo.samples
  
  USING: quotations cairo.gadgets ui.gadgets.panes sequences ;
  : samples ( -- )
-    { arc clip clip-image dash gradient text utf8 }
-    [ { 256 256 } swap 1quotation <cairo-gadget> gadget. ] each ;
+    {
+        arc-gadget clip-gadget clip-image-gadget dash-gadget
+        gradient-gadget text-gadget utf8-gadget
+    }
+    [ new-gadget { 256 256 } >>dim gadget. ] each ;
  
  MAIN: samples

From 88e03204b9dc8ae5bc9497d2d9be5dec1c98154c Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 10 Nov 2008 17:05:31 -0800
Subject: [PATCH 255/318] bring cairo-demo back from the dead

---
 unmaintained/cairo-demo/cairo-demo.factor | 17 ++++++++---------
 1 file changed, 8 insertions(+), 9 deletions(-)

diff --git a/unmaintained/cairo-demo/cairo-demo.factor b/unmaintained/cairo-demo/cairo-demo.factor
index 29fb99a301..4f057ee57c 100644
--- a/unmaintained/cairo-demo/cairo-demo.factor
+++ b/unmaintained/cairo-demo/cairo-demo.factor
@@ -7,7 +7,7 @@
 
 
 USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
-           ui.gadgets opengl.gl ;
+           ui.gadgets opengl.gl accessors ;
 
 IN: cairo-demo
 
@@ -20,17 +20,16 @@ IN: cairo-demo
   cairo_image_surface_create_for_data ;
 
 
-TUPLE: cairo-gadget image-array cairo-t ;
+TUPLE: cairo-gadget < gadget image-array cairo-t ;
 
 M: cairo-gadget draw-gadget* ( gadget -- )
     0 0 glRasterPos2i
     1.0 -1.0 glPixelZoom
     >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
-    cairo-gadget-image-array glDrawPixels ;
+    image-array>> glDrawPixels ;
 
 : create-surface ( gadget -- cairo_surface_t )
-    make-image-array
-    [ swap set-cairo-gadget-image-array ] keep
+    make-image-array [ swap (>>image-array) ] keep
     convert-array-to-surface ;
 
 : init-cairo ( gadget -- cairo_t )
@@ -39,7 +38,7 @@ M: cairo-gadget draw-gadget* ( gadget -- )
 M: cairo-gadget pref-dim* drop { 384 256 0 } ;
 
 : draw-hello-world ( gadget -- )
-  cairo-gadget-cairo-t
+  cairo-t>>
   dup "Sans" CAIRO_FONT_SLANT_NORMAL CAIRO_FONT_WEIGHT_BOLD cairo_select_font_face
   dup 90.0 cairo_set_font_size
   dup 10.0 135.0 cairo_move_to
@@ -58,13 +57,13 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ;
   cairo_fill ;
 
 M: cairo-gadget graft* ( gadget -- )
-  dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
+  dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
 
 M: cairo-gadget ungraft* ( gadget -- )
-   cairo-gadget-cairo-t cairo_destroy ;
+   cairo-t>> cairo_destroy ;
 
 : <cairo-gadget> ( -- gadget )
-  cairo-gadget construct-gadget ;
+  cairo-gadget new-gadget ;
 
 : run ( -- )
   [

From c9b5934894bd49b02e3477eaa9b1f612a529f659 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 10 Nov 2008 17:07:04 -0800
Subject: [PATCH 256/318] change name of gadget in cairo-demo to avoid
 confusion with cairo.gadgets

---
 unmaintained/cairo-demo/cairo-demo.factor | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/unmaintained/cairo-demo/cairo-demo.factor b/unmaintained/cairo-demo/cairo-demo.factor
index 4f057ee57c..ea92e798a7 100644
--- a/unmaintained/cairo-demo/cairo-demo.factor
+++ b/unmaintained/cairo-demo/cairo-demo.factor
@@ -20,9 +20,9 @@ IN: cairo-demo
   cairo_image_surface_create_for_data ;
 
 
-TUPLE: cairo-gadget < gadget image-array cairo-t ;
+TUPLE: cairo-demo-gadget < gadget image-array cairo-t ;
 
-M: cairo-gadget draw-gadget* ( gadget -- )
+M: cairo-demo-gadget draw-gadget* ( gadget -- )
     0 0 glRasterPos2i
     1.0 -1.0 glPixelZoom
     >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
@@ -35,7 +35,7 @@ M: cairo-gadget draw-gadget* ( gadget -- )
 : init-cairo ( gadget -- cairo_t )
    create-surface cairo_create ;
 
-M: cairo-gadget pref-dim* drop { 384 256 0 } ;
+M: cairo-demo-gadget pref-dim* drop { 384 256 0 } ;
 
 : draw-hello-world ( gadget -- )
   cairo-t>>
@@ -56,18 +56,18 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ;
   dup 70.0 165.0 5.12 0 pi 2 * cairo_arc
   cairo_fill ;
 
-M: cairo-gadget graft* ( gadget -- )
+M: cairo-demo-gadget graft* ( gadget -- )
   dup dup init-cairo swap (>>cairo-t) draw-hello-world ;
 
-M: cairo-gadget ungraft* ( gadget -- )
+M: cairo-demo-gadget ungraft* ( gadget -- )
    cairo-t>> cairo_destroy ;
 
-: <cairo-gadget> ( -- gadget )
-  cairo-gadget new-gadget ;
+: <cairo-demo-gadget> ( -- gadget )
+  cairo-demo-gadget new-gadget ;
 
 : run ( -- )
   [
-        <cairo-gadget> "Hello World from Factor!" open-window
+        <cairo-demo-gadget> "Hello World from Factor!" open-window
   ] with-ui ;
 
 MAIN: run

From ab366cd1ca31b61eda94ca6f985237c88a24c6fe Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Mon, 10 Nov 2008 17:07:59 -0800
Subject: [PATCH 257/318] Move cairo vocabs back into extra/

---
 {unmaintained => extra}/cairo-demo/authors.txt       | 0
 {unmaintained => extra}/cairo-demo/cairo-demo.factor | 0
 {unmaintained => extra}/cairo/authors.txt            | 0
 {unmaintained => extra}/cairo/cairo.factor           | 0
 {unmaintained => extra}/cairo/ffi/ffi.factor         | 0
 {unmaintained => extra}/cairo/gadgets/gadgets.factor | 0
 {unmaintained => extra}/cairo/samples/samples.factor | 0
 {unmaintained => extra}/cairo/summary.txt            | 0
 {unmaintained => extra}/cairo/tags.txt               | 0
 9 files changed, 0 insertions(+), 0 deletions(-)
 rename {unmaintained => extra}/cairo-demo/authors.txt (100%)
 rename {unmaintained => extra}/cairo-demo/cairo-demo.factor (100%)
 rename {unmaintained => extra}/cairo/authors.txt (100%)
 rename {unmaintained => extra}/cairo/cairo.factor (100%)
 rename {unmaintained => extra}/cairo/ffi/ffi.factor (100%)
 rename {unmaintained => extra}/cairo/gadgets/gadgets.factor (100%)
 rename {unmaintained => extra}/cairo/samples/samples.factor (100%)
 rename {unmaintained => extra}/cairo/summary.txt (100%)
 rename {unmaintained => extra}/cairo/tags.txt (100%)

diff --git a/unmaintained/cairo-demo/authors.txt b/extra/cairo-demo/authors.txt
similarity index 100%
rename from unmaintained/cairo-demo/authors.txt
rename to extra/cairo-demo/authors.txt
diff --git a/unmaintained/cairo-demo/cairo-demo.factor b/extra/cairo-demo/cairo-demo.factor
similarity index 100%
rename from unmaintained/cairo-demo/cairo-demo.factor
rename to extra/cairo-demo/cairo-demo.factor
diff --git a/unmaintained/cairo/authors.txt b/extra/cairo/authors.txt
similarity index 100%
rename from unmaintained/cairo/authors.txt
rename to extra/cairo/authors.txt
diff --git a/unmaintained/cairo/cairo.factor b/extra/cairo/cairo.factor
similarity index 100%
rename from unmaintained/cairo/cairo.factor
rename to extra/cairo/cairo.factor
diff --git a/unmaintained/cairo/ffi/ffi.factor b/extra/cairo/ffi/ffi.factor
similarity index 100%
rename from unmaintained/cairo/ffi/ffi.factor
rename to extra/cairo/ffi/ffi.factor
diff --git a/unmaintained/cairo/gadgets/gadgets.factor b/extra/cairo/gadgets/gadgets.factor
similarity index 100%
rename from unmaintained/cairo/gadgets/gadgets.factor
rename to extra/cairo/gadgets/gadgets.factor
diff --git a/unmaintained/cairo/samples/samples.factor b/extra/cairo/samples/samples.factor
similarity index 100%
rename from unmaintained/cairo/samples/samples.factor
rename to extra/cairo/samples/samples.factor
diff --git a/unmaintained/cairo/summary.txt b/extra/cairo/summary.txt
similarity index 100%
rename from unmaintained/cairo/summary.txt
rename to extra/cairo/summary.txt
diff --git a/unmaintained/cairo/tags.txt b/extra/cairo/tags.txt
similarity index 100%
rename from unmaintained/cairo/tags.txt
rename to extra/cairo/tags.txt

From 262e9632e624edd68a9a444d8effe7aef1658ccf Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 10 Nov 2008 19:17:41 -0600
Subject: [PATCH 258/318] Remove 'unmaintained/update' (moving back to 'extra')

---
 unmaintained/update/backup/backup.factor | 28 -----------
 unmaintained/update/latest/latest.factor | 53 --------------------
 unmaintained/update/update.factor        | 64 ------------------------
 3 files changed, 145 deletions(-)
 delete mode 100644 unmaintained/update/backup/backup.factor
 delete mode 100644 unmaintained/update/latest/latest.factor
 delete mode 100644 unmaintained/update/update.factor

diff --git a/unmaintained/update/backup/backup.factor b/unmaintained/update/backup/backup.factor
deleted file mode 100644
index 0dcf853b98..0000000000
--- a/unmaintained/update/backup/backup.factor
+++ /dev/null
@@ -1,28 +0,0 @@
-
-USING: namespaces debugger io.files bootstrap.image builder.util ;
-
-IN: update.backup
-
-: backup-boot-image ( -- )
-  my-boot-image-name
-  { "boot." my-arch "-" [ "datestamp" get ] ".image" } to-string  
-  move-file ;
-
-: backup-image ( -- )
-  "factor.image"
-  { "factor" "-" [ "datestamp" get ] ".image" } to-string
-  move-file ;
-
-: backup-vm ( -- )
-  "factor"
-  { "factor" "-" [ "datestamp" get ] } to-string
-  move-file ;
-
-: backup ( -- )
-  datestamp "datestamp" set
-    [
-      backup-boot-image
-      backup-image
-      backup-vm
-    ]
-  try ;
diff --git a/unmaintained/update/latest/latest.factor b/unmaintained/update/latest/latest.factor
deleted file mode 100644
index df057422f9..0000000000
--- a/unmaintained/update/latest/latest.factor
+++ /dev/null
@@ -1,53 +0,0 @@
-
-USING: kernel namespaces system io.files bootstrap.image http.client
-       builder.util update update.backup ;
-
-IN: update.latest
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-pull-master ( -- )
-  image parent-directory
-    [
-      { "git" "pull" "git://factorcode.org/git/factor.git" "master" }
-      run-command
-    ]
-  with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: remote-latest-image ( -- url )
-  { "http://factorcode.org/images/latest/" my-boot-image-name } to-string ;
-
-: download-latest-image ( -- ) remote-latest-image download ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rebuild-latest ( -- )
-  image parent-directory
-    [
-      backup
-      download-latest-image
-      make-clean
-      make
-      boot
-    ]
-  with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: update-latest ( -- )
-  image parent-directory
-    [
-      git-id
-      git-pull-master
-      git-id
-      = not
-        [ rebuild-latest ]
-      when
-    ]
-  with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: update-latest
\ No newline at end of file
diff --git a/unmaintained/update/update.factor b/unmaintained/update/update.factor
deleted file mode 100644
index 1d25a9792e..0000000000
--- a/unmaintained/update/update.factor
+++ /dev/null
@@ -1,64 +0,0 @@
-
-USING: kernel system sequences io.files io.launcher bootstrap.image
-       http.client
-       builder.util builder.release.branch ;
-
-IN: update
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run-command ( cmd -- ) to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-pull-clean ( -- )
-  image parent-directory
-    [
-      { "git" "pull" "git://factorcode.org/git/factor.git" branch-name }
-      run-command
-    ]
-  with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: remote-clean-image ( -- url )
-  { "http://factorcode.org/images/clean/" platform "/" my-boot-image-name }
-  to-string ;
-
-: download-clean-image ( -- ) remote-clean-image download ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-clean ( -- ) { gnu-make "clean" } run-command ;
-: make       ( -- ) { gnu-make         } run-command ;
-: boot       ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: rebuild ( -- )
-  image parent-directory
-    [
-      download-clean-image
-      make-clean
-      make
-      boot
-    ]
-  with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: update ( -- )
-  image parent-directory
-    [
-      git-id
-      git-pull-clean
-      git-id
-      = not
-        [ rebuild ]
-      when
-    ]
-  with-directory ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: update
\ No newline at end of file

From 7104cd4fe8e63f89495f5f25e3f748690c87f903 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 10 Nov 2008 19:20:08 -0600
Subject: [PATCH 259/318] Fix 'extra/update'

---
 extra/update/backup/backup.factor | 28 +++++++++++++
 extra/update/latest/latest.factor | 53 +++++++++++++++++++++++++
 extra/update/update.factor        | 66 +++++++++++++++++++++++++++++++
 extra/update/util/util.factor     | 62 +++++++++++++++++++++++++++++
 4 files changed, 209 insertions(+)
 create mode 100644 extra/update/backup/backup.factor
 create mode 100644 extra/update/latest/latest.factor
 create mode 100644 extra/update/update.factor
 create mode 100644 extra/update/util/util.factor

diff --git a/extra/update/backup/backup.factor b/extra/update/backup/backup.factor
new file mode 100644
index 0000000000..0c7b442ffa
--- /dev/null
+++ b/extra/update/backup/backup.factor
@@ -0,0 +1,28 @@
+
+USING: namespaces debugger io.files bootstrap.image update.util ;
+
+IN: update.backup
+
+: backup-boot-image ( -- )
+  my-boot-image-name
+  { "boot." my-arch "-" [ "datestamp" get ] ".image" } to-string  
+  move-file ;
+
+: backup-image ( -- )
+  "factor.image"
+  { "factor" "-" [ "datestamp" get ] ".image" } to-string
+  move-file ;
+
+: backup-vm ( -- )
+  "factor"
+  { "factor" "-" [ "datestamp" get ] } to-string
+  move-file ;
+
+: backup ( -- )
+  datestamp "datestamp" set
+    [
+      backup-boot-image
+      backup-image
+      backup-vm
+    ]
+  try ;
diff --git a/extra/update/latest/latest.factor b/extra/update/latest/latest.factor
new file mode 100644
index 0000000000..7cc2fac853
--- /dev/null
+++ b/extra/update/latest/latest.factor
@@ -0,0 +1,53 @@
+
+USING: kernel namespaces system io.files bootstrap.image http.client
+       update update.backup update.util ;
+
+IN: update.latest
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-pull-master ( -- )
+  image parent-directory
+    [
+      { "git" "pull" "git://factorcode.org/git/factor.git" "master" }
+      run-command
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-latest-image ( -- url )
+  { "http://factorcode.org/images/latest/" my-boot-image-name } to-string ;
+
+: download-latest-image ( -- ) remote-latest-image download ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rebuild-latest ( -- )
+  image parent-directory
+    [
+      backup
+      download-latest-image
+      make-clean
+      make
+      boot
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update-latest ( -- )
+  image parent-directory
+    [
+      git-id
+      git-pull-master
+      git-id
+      = not
+        [ rebuild-latest ]
+      when
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: update-latest
\ No newline at end of file
diff --git a/extra/update/update.factor b/extra/update/update.factor
new file mode 100644
index 0000000000..c6a5671345
--- /dev/null
+++ b/extra/update/update.factor
@@ -0,0 +1,66 @@
+
+USING: kernel system sequences io.files io.launcher bootstrap.image
+       http.client
+       update.util ;
+
+       ! builder.util builder.release.branch ;
+
+IN: update
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-command ( cmd -- ) to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-pull-clean ( -- )
+  image parent-directory
+    [
+      { "git" "pull" "git://factorcode.org/git/factor.git" branch-name }
+      run-command
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-clean-image ( -- url )
+  { "http://factorcode.org/images/clean/" platform "/" my-boot-image-name }
+  to-string ;
+
+: download-clean-image ( -- ) remote-clean-image download ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-clean ( -- ) { gnu-make "clean" } run-command ;
+: make       ( -- ) { gnu-make         } run-command ;
+: boot       ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rebuild ( -- )
+  image parent-directory
+    [
+      download-clean-image
+      make-clean
+      make
+      boot
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update ( -- )
+  image parent-directory
+    [
+      git-id
+      git-pull-clean
+      git-id
+      = not
+        [ rebuild ]
+      when
+    ]
+  with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: update
\ No newline at end of file
diff --git a/extra/update/util/util.factor b/extra/update/util/util.factor
new file mode 100644
index 0000000000..b638b61528
--- /dev/null
+++ b/extra/update/util/util.factor
@@ -0,0 +1,62 @@
+
+USING: kernel classes strings quotations words math math.parser arrays
+       combinators.cleave
+       accessors
+       system prettyprint splitting
+       sequences combinators sequences.deep
+       io
+       io.launcher
+       io.encodings.utf8
+       calendar
+       calendar.format ;
+
+IN: update.util
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: to-strings
+
+: to-string ( obj -- str )
+  dup class
+    {
+      { \ string    [ ] }
+      { \ quotation [ call ] }
+      { \ word      [ execute ] }
+      { \ fixnum    [ number>string ] }
+      { \ array     [ to-strings concat ] }
+    }
+  case ;
+
+: to-strings ( seq -- str )
+  dup [ string? ] all?
+    [ ]
+    [ [ to-string ] map flatten ]
+  if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
+
+: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: branch-name ( -- string ) "clean-" platform append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gnu-make ( -- string )
+  os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-id ( -- id )
+  { "git" "show" } utf8 <process-reader> [ readln ] with-input-stream
+  " " split second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: datestamp ( -- string )
+  now
+    { year>> month>> day>> hour>> minute>> } <arr>
+  [ pad-00 ] map "-" join ;

From 78d9452b7ef05851baee92363cbc34a71cc7bd43 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 10 Nov 2008 20:05:50 -0600
Subject: [PATCH 260/318] basis/bootstrap/stage2: Show core bootstrap time in
 report

---
 basis/bootstrap/stage2.factor | 17 ++++++++++++++---
 1 file changed, 14 insertions(+), 3 deletions(-)

diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
index 3b6c04329c..67c6c9487d 100644
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@@ -8,6 +8,8 @@ definitions assocs compiler.errors compiler.units
 math.parser generic sets debugger command-line ;
 IN: bootstrap.stage2
 
+SYMBOL: core-bootstrap-time
+
 SYMBOL: bootstrap-time
 
 : default-image-name ( -- string )
@@ -30,7 +32,14 @@ SYMBOL: bootstrap-time
 : count-words ( pred -- )
     all-words swap count number>string write ;
 
-: print-report ( time -- )
+: print-report ( -- )
+    core-bootstrap-time get
+    1000 /i
+    60 /mod swap
+    "Core bootstrap completed in " write number>string write
+    " minutes and " write number>string write " seconds." print
+
+    bootstrap-time get
     1000 /i
     60 /mod swap
     "Bootstrap completed in " write number>string write
@@ -46,7 +55,7 @@ SYMBOL: bootstrap-time
 
 [
     ! We time bootstrap
-    millis >r
+    millis
 
     default-image-name "output-image" set-global
 
@@ -71,6 +80,8 @@ SYMBOL: bootstrap-time
     [
         load-components
 
+        millis over - core-bootstrap-time set-global
+
         run-bootstrap-init
     ] with-compiler-errors
     :errors
@@ -92,7 +103,7 @@ SYMBOL: bootstrap-time
             ] [ print-error 1 exit ] recover
         ] set-boot-quot
 
-        millis r> - dup bootstrap-time set-global
+        millis swap - bootstrap-time set-global
         print-report
 
         "output-image" get save-image-and-exit

From 2489ac5205997307e704168d9d8b373358820ef0 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 10 Nov 2008 21:27:48 -0600
Subject: [PATCH 261/318] bootstrap.stage2: Factor out 'print-time'

---
 basis/bootstrap/stage2.factor | 15 ++++++---------
 1 file changed, 6 insertions(+), 9 deletions(-)

diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
index 67c6c9487d..d25394e978 100644
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@@ -32,18 +32,15 @@ SYMBOL: bootstrap-time
 : count-words ( pred -- )
     all-words swap count number>string write ;
 
-: print-report ( -- )
-    core-bootstrap-time get
+: print-time ( time -- )
     1000 /i
     60 /mod swap
-    "Core bootstrap completed in " write number>string write
-    " minutes and " write number>string write " seconds." print
+    number>string write
+    " minutes and " write number>string write " seconds." print ;
 
-    bootstrap-time get
-    1000 /i
-    60 /mod swap
-    "Bootstrap completed in " write number>string write
-    " minutes and " write number>string write " seconds." print
+: print-report ( -- )
+    "Core bootstrap completed in " write core-bootstrap-time get print-time
+    "Bootstrap completed in "      write bootstrap-time      get print-time
 
     [ compiled>> ] count-words " compiled words" print
     [ symbol? ] count-words " symbol words" print

From 8ace93a75f9c62cc78b9569a6656724333589944 Mon Sep 17 00:00:00 2001
From: Eric Mertens <emertens@gmail.com>
Date: Mon, 10 Nov 2008 19:34:36 -0800
Subject: [PATCH 262/318] add project-euler.203

---
 extra/project-euler/203/203-tests.factor | 5 +++++
 extra/project-euler/203/203.factor       | 9 +++++++++
 2 files changed, 14 insertions(+)
 create mode 100644 extra/project-euler/203/203-tests.factor
 create mode 100644 extra/project-euler/203/203.factor

diff --git a/extra/project-euler/203/203-tests.factor b/extra/project-euler/203/203-tests.factor
new file mode 100644
index 0000000000..6c49c2f958
--- /dev/null
+++ b/extra/project-euler/203/203-tests.factor
@@ -0,0 +1,5 @@
+USING: project-euler.203 tools.test ;
+IN: project-euler.203.tests
+
+[ 105 ] [ 8 solve ] unit-test
+[ 34029210557338 ] [ 51 solve ] unit-test
diff --git a/extra/project-euler/203/203.factor b/extra/project-euler/203/203.factor
new file mode 100644
index 0000000000..9a2916649e
--- /dev/null
+++ b/extra/project-euler/203/203.factor
@@ -0,0 +1,9 @@
+USING: fry kernel math math.primes.factors sequences sets ;
+IN: project-euler.203
+
+: iterate ( n initial quot -- results ) swapd '[ @ dup ] replicate nip ; inline
+: (generate) ( seq -- seq ) [ 0 prefix ] [ 0 suffix ] bi [ + ] 2map ;
+: generate ( n -- seq ) 1- { 1 } [ (generate) ] iterate concat prune ;
+: squarefree ( n -- ? ) factors duplicates empty? ;
+: solve ( n -- n ) generate [ squarefree ] filter sum ;
+: euler203 ( -- n ) 51 solve ;

From 3b204ff971dbbc05f1f47442b62a7ecc6f863d22 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Mon, 10 Nov 2008 22:56:37 -0500
Subject: [PATCH 263/318] Solution to Project Euler problem 73

---
 extra/project-euler/073/073-tests.factor |  4 ++
 extra/project-euler/073/073.factor       | 52 ++++++++++++++++++++++++
 extra/project-euler/project-euler.factor | 12 +++---
 3 files changed, 62 insertions(+), 6 deletions(-)
 create mode 100644 extra/project-euler/073/073-tests.factor
 create mode 100644 extra/project-euler/073/073.factor

diff --git a/extra/project-euler/073/073-tests.factor b/extra/project-euler/073/073-tests.factor
new file mode 100644
index 0000000000..6389150c39
--- /dev/null
+++ b/extra/project-euler/073/073-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.073 tools.test ;
+IN: project-euler.073.tests
+
+[ 5066251 ] [ euler073 ] unit-test
diff --git a/extra/project-euler/073/073.factor b/extra/project-euler/073/073.factor
new file mode 100644
index 0000000000..68dcd01e0d
--- /dev/null
+++ b/extra/project-euler/073/073.factor
@@ -0,0 +1,52 @@
+! Copyright (c) 2008 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel locals make math project-euler.common sequences ;
+IN: project-euler.073
+
+! http://projecteuler.net/index.php?section=problems&id=73
+
+! DESCRIPTION
+! -----------
+
+! Consider the fraction, n/d, where n and d are positive integers. If n<d and
+! HCF(n,d) = 1, it is called a reduced proper fraction.
+
+! If we list the set of reduced proper fractions for d <= 8 in ascending order of
+! size, we get:
+
+!     1/8, 1/7, 1/6, 1/5, 1/4, 2/7, 1/3, 3/8, 2/5, 3/7, 1/2, 4/7, 3/5, 5/8,
+!     2/3, 5/7, 3/4, 4/5, 5/6, 6/7, 7/8
+
+! It can be seen that there are 3 fractions between 1/3 and 1/2.
+
+! How many fractions lie between 1/3 and 1/2 in the sorted set of reduced
+! proper fractions for d <= 10,000?
+
+
+! SOLUTION
+! --------
+
+! Use the properties of a Farey sequence and mediants to recursively generate
+! the next fraction until the denominator is as close to 1000000 as possible
+! without going over.
+
+<PRIVATE
+
+:: (euler073) ( limit lo hi -- )
+    [let | m [ lo hi mediant ] |
+        m denominator limit <= [
+            m ,
+            limit lo m (euler073)
+            limit m hi (euler073)
+        ] when
+    ] ;
+
+PRIVATE>
+
+: euler073 ( -- answer )
+    [ 10000 1/3 1/2 (euler073) ] { } make length ;
+
+! [ euler073 ] 10 ave-time
+! 20506 ms ave run time - 937.07 SD (10 trials)
+
+MAIN: euler073
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index 1e808e6321..036167865f 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -15,12 +15,12 @@ USING: definitions io io.files kernel math math.parser
     project-euler.041 project-euler.042 project-euler.043 project-euler.044
     project-euler.045 project-euler.046 project-euler.047 project-euler.048
     project-euler.052 project-euler.053 project-euler.055 project-euler.056
-    project-euler.059 project-euler.067 project-euler.071 project-euler.075
-    project-euler.076 project-euler.079 project-euler.092 project-euler.097
-    project-euler.100 project-euler.116 project-euler.117 project-euler.134
-    project-euler.148 project-euler.150 project-euler.151 project-euler.164
-    project-euler.169 project-euler.173 project-euler.175 project-euler.186
-    project-euler.190 ;
+    project-euler.059 project-euler.067 project-euler.071 project-euler.073
+    project-euler.075 project-euler.076 project-euler.079 project-euler.092
+    project-euler.097 project-euler.100 project-euler.116 project-euler.117
+    project-euler.134 project-euler.148 project-euler.150 project-euler.151
+    project-euler.164 project-euler.169 project-euler.173 project-euler.175
+    project-euler.186 project-euler.190 ;
 IN: project-euler
 
 <PRIVATE

From 8e155a830625892048f2575e3bc8bf354742c378 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Mon, 10 Nov 2008 23:26:38 -0500
Subject: [PATCH 264/318] Cleanup formatting of Project Euler problem 215

---
 extra/project-euler/215/215-tests.factor |  2 +-
 extra/project-euler/215/215.factor       | 46 +++++++++++++++++++++---
 extra/project-euler/project-euler.factor |  2 +-
 3 files changed, 43 insertions(+), 7 deletions(-)

diff --git a/extra/project-euler/215/215-tests.factor b/extra/project-euler/215/215-tests.factor
index ddd87cc2ff..9d265b70d2 100644
--- a/extra/project-euler/215/215-tests.factor
+++ b/extra/project-euler/215/215-tests.factor
@@ -1,4 +1,4 @@
-USING: project-euler.215 tools.test ;
+USING: project-euler.215 project-euler.215.private tools.test ;
 IN: project-euler.215.tests
 
 [ 8 ] [ 9 3 solve ] unit-test
diff --git a/extra/project-euler/215/215.factor b/extra/project-euler/215/215.factor
index 056de72e50..fc09b37515 100644
--- a/extra/project-euler/215/215.factor
+++ b/extra/project-euler/215/215.factor
@@ -1,6 +1,33 @@
+! Copyright (c) 2008 Eric Mertens.
+! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel locals math ;
 IN: project-euler.215
 
+! http://projecteuler.net/index.php?section=problems&id=215
+
+! DESCRIPTION
+! -----------
+
+! Consider the problem of building a wall out of 2x1 and 3x1 bricks
+! (horizontalvertical dimensions) such that, for extra strength, the gaps
+! between horizontally-adjacent bricks never line up in consecutive layers,
+! i.e. never form a "running crack".
+
+! For example, the following 93 wall is not acceptable due to the running crack
+! shown in red:
+
+!     See problem site for image...
+
+! There are eight ways of forming a crack-free 9x3 wall, written W(9,3) = 8.
+
+! Calculate W(32,10).
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
 TUPLE: block two three ;
 TUPLE: end { ways integer } ;
 
@@ -11,7 +38,8 @@ C: <end> end
 
 : failure? ( t -- ? ) ways>> 0 = ; inline
 
-: choice ( t p q -- t t ) [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline
+: choice ( t p q -- t t )
+    [ [ two>> ] [ three>> ] bi ] 2dip bi* ; inline
 
 GENERIC: merge ( t t -- t )
 GENERIC# block-merge 1 ( t t -- t )
@@ -43,14 +71,22 @@ M: end h2 dup failure? [ <failure> <block> ] unless ;
 : next-row ( t -- t ) [ h-1 ] [ h1 ] choice swap <block> ;
 
 : first-row ( n -- t )
-  [ <failure> <success> <failure> ] dip
-  1- [| a b c | b c <block> a b ] times 2drop ;
+    [ <failure> <success> <failure> ] dip
+    1- [| a b c | b c <block> a b ] times 2drop ;
 
 GENERIC: total ( t -- n )
 M: block total [ total ] dup choice + ;
 M: end   total ways>> ;
 
 : solve ( width height -- ways )
-  [ first-row ] dip 1- [ next-row ] times total ;
+    [ first-row ] dip 1- [ next-row ] times total ;
 
-: euler215 ( -- ways ) 32 10 solve ;
+PRIVATE>
+
+: euler215 ( -- answer )
+    32 10 solve ;
+
+! [ euler215 ] 100 ave-time
+! 208 ms ave run time - 9.06 SD (100 trials)
+
+MAIN: euler215
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index 036167865f..9549505bf6 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -20,7 +20,7 @@ USING: definitions io io.files kernel math math.parser
     project-euler.097 project-euler.100 project-euler.116 project-euler.117
     project-euler.134 project-euler.148 project-euler.150 project-euler.151
     project-euler.164 project-euler.169 project-euler.173 project-euler.175
-    project-euler.186 project-euler.190 ;
+    project-euler.186 project-euler.190 project-euler.215 ;
 IN: project-euler
 
 <PRIVATE

From f0c61b9499d750847300d7b88fbd99fd577cad85 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 00:28:37 -0600
Subject: [PATCH 265/318] Rewrite OpenGL rendering code - Don't use
 glPolygonMode to draw outline rectangles - Use vertex arrays instead of
 glBegin/glVertex/glEnd - Remove dead code from opengl vocabulary -
 draw-interior and draw-boundary are now called with origin get [ ... ]
 with-translation

---
 basis/opengl/opengl-docs.factor               |  33 ----
 basis/opengl/opengl.factor                    | 146 ++++++++----------
 basis/ui/gadgets/buttons/buttons.factor       |  97 ++++++++----
 basis/ui/gadgets/editors/editors.factor       |   6 +-
 basis/ui/gadgets/grid-lines/grid-lines.factor |  17 +-
 basis/ui/gadgets/labelled/labelled.factor     |   4 +-
 basis/ui/gadgets/labels/labels.factor         |   2 +-
 basis/ui/gadgets/lists/lists.factor           |   8 +-
 basis/ui/gadgets/panes/panes.factor           |   8 +-
 basis/ui/gadgets/theme/theme.factor           |  30 ++--
 basis/ui/gadgets/worlds/worlds.factor         |   4 +-
 basis/ui/render/render.factor                 | 122 ++++++++++-----
 12 files changed, 256 insertions(+), 221 deletions(-)

diff --git a/basis/opengl/opengl-docs.factor b/basis/opengl/opengl-docs.factor
index 87981789a7..6752c5126c 100644
--- a/basis/opengl/opengl-docs.factor
+++ b/basis/opengl/opengl-docs.factor
@@ -9,14 +9,6 @@ HELP: gl-color
 HELP: gl-error
 { $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ;
 
-HELP: do-state
-  {
-    $values
-      { "mode" { "One of the " { $link "opengl-geometric-primitives" } } }
-      { "quot" quotation }
-  }
-{ $description "Wraps a quotation in " { $link glBegin } "/" { $link glEnd } " calls." } ;
-
 HELP: do-enabled
 { $values { "what" integer } { "quot" quotation } }
 { $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ;
@@ -25,10 +17,6 @@ HELP: do-matrix
 { $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } }
 { $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ;
 
-HELP: gl-vertex
-{ $values { "point" "a pair of integers" } }
-{ $description "Wrapper for " { $link glVertex2d } " taking a point object." } ;
-
 HELP: gl-line
 { $values { "a" "a pair of integers" } { "b" "a pair of integers" } }
 { $description "Draws a line between two points." } ;
@@ -41,22 +29,6 @@ HELP: gl-rect
 { $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
 { $description "Draws the outline of a rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ;
 
-HELP: rect-vertices
-{ $values { "lower-left" "A pair of numbers indicating the lower-left coordinates of the rectangle." } { "upper-right" "The upper-right coordinates of the rectangle." } }
-{ $description "Emits" { $link glVertex2d } " calls outlining the axis-aligned rectangle from " { $snippet "lower-left" } " to " { $snippet "upper-right" } " on the z=0 plane in counterclockwise order." } ;
-
-HELP: gl-fill-poly
-{ $values { "points" "a sequence of pairs of integers" } }
-{ $description "Draws a filled polygon." } ;
-
-HELP: gl-poly
-{ $values { "points" "a sequence of pairs of integers" } }
-{ $description "Draws the outline of a polygon." } ;
-
-HELP: gl-gradient
-{ $values { "direction" "an orientation specifier" } { "colors" "a sequence of color specifiers" } { "dim" "a pair of integers" } }
-{ $description "Draws a rectangle with top-left corner " { $snippet "{ 0 0 }" } " and dimensions " { $snippet "dim" } ", filled with a smoothly shaded transition between the colors in " { $snippet "colors" } "." } ;
-
 HELP: gen-texture
 { $values { "id" integer } }
 { $description "Wrapper for " { $link glGenTextures } " to handle the common case of generating a single texture ID." } ;
@@ -131,12 +103,10 @@ $nl
 { $subsection "opengl-low-level" }
 "Wrappers:"
 { $subsection gl-color }
-{ $subsection gl-vertex }
 { $subsection gl-translate }
 { $subsection gen-texture }
 { $subsection bind-texture-unit }
 "Combinators:"
-{ $subsection do-state }
 { $subsection do-enabled }
 { $subsection do-attribs }
 { $subsection do-matrix }
@@ -146,9 +116,6 @@ $nl
 { $subsection gl-line }
 { $subsection gl-fill-rect }
 { $subsection gl-rect }
-{ $subsection gl-fill-poly }
-{ $subsection gl-poly }
-{ $subsection gl-gradient }
 ;
 
 ABOUT: "gl-utilities"
diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index 5d9baf644d..7cf141ca6a 100644
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -2,44 +2,31 @@
 ! Portions copyright (C) 2007 Eduardo Cavazos.
 ! Portions copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-
 USING: alien alien.c-types continuations kernel libc math macros
-       namespaces math.vectors math.constants math.functions
-       math.parser opengl.gl opengl.glu combinators arrays sequences
-       splitting words byte-arrays assocs colors accessors ;
-
+namespaces math.vectors math.constants math.functions
+math.parser opengl.gl opengl.glu combinators arrays sequences
+splitting words byte-arrays assocs colors accessors
+generalizations locals memoize ;
 IN: opengl
 
-: coordinates ( point1 point2 -- x1 y2 x2 y2 )
-    [ first2 ] bi@ ;
-
-: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
-    [ first2 [ >fixnum ] bi@ ] bi@ ;
-
 : color>raw ( object -- r g b a )
-    >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ;
+    >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
 
 : gl-color ( color -- ) color>raw glColor4d ; inline
 
-: gl-clear-color ( color -- )
-    color>raw glClearColor ;
+: gl-clear-color ( color -- ) color>raw glClearColor ;
 
 : gl-clear ( color -- )
     gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
 
-: set-color ( object -- ) color>raw glColor4d ;
-: set-clear-color ( object -- ) color>raw glClearColor ;
-
 : gl-error ( -- )
     glGetError dup zero? [
         "GL error: " over gluErrorString append throw
     ] unless drop ;
 
-: do-state ( mode quot -- )
-    swap glBegin call glEnd ; inline
-
 : do-enabled ( what quot -- )
     over glEnable dip glDisable ; inline
+
 : do-enabled-client-state ( what quot -- )
     over glEnableClientState dip glDisableClientState ; inline
 
@@ -48,6 +35,7 @@ IN: opengl
 
 : (all-enabled) ( seq quot -- )
     over [ glEnable ] each dip [ glDisable ] each ; inline
+
 : (all-enabled-client-state) ( seq quot -- )
     [ dup [ glEnableClientState ] each ] dip
     dip
@@ -55,6 +43,7 @@ IN: opengl
 
 MACRO: all-enabled ( seq quot -- )
     >r words>values r> [ (all-enabled) ] 2curry ;
+
 MACRO: all-enabled-client-state ( seq quot -- )
     >r words>values r> [ (all-enabled-client-state) ] 2curry ;
 
@@ -62,37 +51,46 @@ MACRO: all-enabled-client-state ( seq quot -- )
     swap [ glMatrixMode glPushMatrix call ] keep
     glMatrixMode glPopMatrix ; inline
 
-: gl-vertex ( point -- )
-    dup length {
-        { 2 [ first2 glVertex2d ] }
-        { 3 [ first3 glVertex3d ] }
-        { 4 [ first4 glVertex4d ] }
-    } case ;
-
-: gl-normal ( normal -- ) first3 glNormal3d ;
-
 : gl-material ( face pname params -- )
     >c-float-array glMaterialfv ;
 
+: gl-vertex-pointer ( seq -- )
+    [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline
+
+: gl-color-pointer ( seq -- )
+    [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline
+
+: gl-texture-coord-pointer ( seq -- )
+    [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
+
+: line-vertices ( a b -- )
+    append >c-float-array gl-vertex-pointer ;
+
 : gl-line ( a b -- )
-    GL_LINES [ gl-vertex gl-vertex ] do-state ;
+    line-vertices GL_LINES 0 2 glDrawArrays ;
 
-: gl-fill-rect ( loc ext -- )
-    coordinates glRectd ;
+: (rectangle-vertices) ( dim -- vertices )
+    {
+        [ drop 0 0 ]
+        [ first 0 ]
+        [ first2 ]
+        [ second 0 swap ]
+    } cleave 8 narray >c-float-array ;
 
-: gl-rect ( loc ext -- )
-    GL_FRONT_AND_BACK GL_LINE glPolygonMode
-    >r { 0.5 0.5 } v+ r> { 0.5 0.5 } v- gl-fill-rect
-    GL_FRONT_AND_BACK GL_FILL glPolygonMode ;
+: rectangle-vertices ( dim -- )
+    (rectangle-vertices) gl-vertex-pointer ;
 
-: (gl-poly) ( points state -- )
-    [ [ gl-vertex ] each ] do-state ;
+: (gl-rect) ( -- )
+    GL_LINE_LOOP 0 4 glDrawArrays ;
 
-: gl-fill-poly ( points -- )
-    dup length 2 > GL_POLYGON GL_LINES ? (gl-poly) ;
+: gl-rect ( dim -- )
+    rectangle-vertices (gl-rect) ;
 
-: gl-poly ( points -- )
-    GL_LINE_LOOP (gl-poly) ;
+: (gl-fill-rect) ( -- )
+    GL_QUADS 0 4 glDrawArrays ;
+
+: gl-fill-rect ( dim -- )
+    rectangle-vertices (gl-fill-rect) ;
 
 : circle-steps ( steps -- angles )
     dup length v/n 2 pi * v*n ;
@@ -109,35 +107,24 @@ MACRO: all-enabled-client-state ( seq quot -- )
 : circle-points ( loc dim steps -- points )
     circle-steps unit-circle adjust-points scale-points ;
 
-: gl-circle ( loc dim steps -- )
-    circle-points gl-poly ;
-
-: gl-fill-circle ( loc dim steps -- )
-    circle-points gl-fill-poly ;
-
-: prepare-gradient ( direction dim -- v1 v2 )
-    tuck v* [ v- ] keep ;
-
-: gl-gradient ( direction colors dim -- )
-    GL_QUAD_STRIP [
-        swap >r prepare-gradient r>
-        [ length dup 1- v/n ] keep [
-            >r >r 2dup r> r> set-color v*n
-            dup gl-vertex v+ gl-vertex
-        ] 2each 2drop
-    ] do-state ;
+: circle-vertices ( loc dim steps -- vertices )
+    circle-points concat >c-float-array ;
 
 : (gen-gl-object) ( quot -- id )
     >r 1 0 <uint> r> keep *uint ; inline
+
 : gen-texture ( -- id )
     [ glGenTextures ] (gen-gl-object) ;
+
 : gen-gl-buffer ( -- id )
     [ glGenBuffers ] (gen-gl-object) ;
 
 : (delete-gl-object) ( id quot -- )
     >r 1 swap <uint> r> call ; inline
+
 : delete-texture ( id -- )
     [ glDeleteTextures ] (delete-gl-object) ;
+
 : delete-gl-buffer ( id -- )
     [ glDeleteBuffers ] (delete-gl-object) ;
 
@@ -205,35 +192,21 @@ TUPLE: sprite loc dim dim2 dlist texture ;
 
 : gl-translate ( point -- ) first2 0.0 glTranslated ;
 
-<PRIVATE
+MEMO: (rect-texture-coords) ( -- seq )
+    { 0 0 1 0 1 1 0 1 } >c-float-array ;
 
-: top-left drop 0 0 glTexCoord2i 0.0 0.0 glVertex2d ; inline
-
-: top-right 1 0 glTexCoord2i first 0.0 glVertex2d ; inline
-
-: bottom-left 0 1 glTexCoord2i second 0.0 swap glVertex2d ; inline
-
-: bottom-right 1 1 glTexCoord2i gl-vertex ; inline
-
-PRIVATE>
-
-: four-sides ( dim -- )
-    dup top-left dup top-right dup bottom-right bottom-left ;
+: rect-texture-coords ( -- )
+    (rect-texture-coords) gl-texture-coord-pointer ;
 
 : draw-sprite ( sprite -- )
-    dup loc>> gl-translate
-    GL_TEXTURE_2D over texture>> glBindTexture
-    init-texture
-    GL_QUADS [ dim2>> four-sides ] do-state
-    GL_TEXTURE_2D 0 glBindTexture ;
-
-: rect-vertices ( lower-left upper-right -- )
-    GL_QUADS [
-        over first2 glVertex2d
-        dup first pick second glVertex2d
-        dup first2 glVertex2d
-        swap first swap second glVertex2d
-    ] do-state ;
+    GL_TEXTURE_COORD_ARRAY [
+        dup loc>> gl-translate
+        GL_TEXTURE_2D over texture>> glBindTexture
+        init-texture rect-texture-coords
+        dim2>> rectangle-vertices
+        (gl-fill-rect)
+        GL_TEXTURE_2D 0 glBindTexture
+    ] do-enabled-client-state ;
 
 : make-sprite-dlist ( sprite -- id )
     GL_MODELVIEW [
@@ -256,6 +229,9 @@ PRIVATE>
 : with-translation ( loc quot -- )
     GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline
 
+: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
+    [ first2 [ >fixnum ] bi@ ] bi@ ;
+
 : gl-set-clip ( loc dim -- )
     fix-coordinates glScissor ;
 
diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor
index 4ad9e14874..9f3e3a8520 100644
--- a/basis/ui/gadgets/buttons/buttons.factor
+++ b/basis/ui/gadgets/buttons/buttons.factor
@@ -1,12 +1,11 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel math models namespaces sequences
-       strings quotations assocs combinators classes colors
-       classes.tuple opengl math.vectors
-       ui.commands ui.gadgets ui.gadgets.borders
-       ui.gadgets.labels ui.gadgets.theme
-       ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
-       ui.render math.geometry.rect ;
+strings quotations assocs combinators classes colors
+classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
+ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
+ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
+ui.render math.geometry.rect locals alien.c-types ;
 
 IN: ui.gadgets.buttons
 
@@ -62,10 +61,10 @@ C: <button-paint> button-paint
     } cond ;
 
 M: button-paint draw-interior
-    button-paint draw-interior ;
+    button-paint dup [ draw-interior ] [ 2drop ] if ;
 
 M: button-paint draw-boundary
-    button-paint draw-boundary ;
+    button-paint dup [ draw-boundary ] [ 2drop ] if ;
 
 : align-left ( button -- button )
     { 0 1/2 } >>align ; inline
@@ -103,17 +102,34 @@ repeat-button H{
     #! the mouse is held down.
     repeat-button new-button bevel-button-theme ;
 
-TUPLE: checkmark-paint color ;
+TUPLE: checkmark-paint < caching-pen color last-vertices ;
 
-C: <checkmark-paint> checkmark-paint
+: <checkmark-paint> ( color -- paint )
+    checkmark-paint new swap >>color ;
+
+<PRIVATE
+
+: checkmark-points ( dim -- points )
+    {
+        [ { 0 0 } v* ]
+        [ { 1 1 } v* ]
+        [ { 0 1 } v* ]
+        [ { 1 0 } v* ]
+    } cleave 4array ;
+
+: checkmark-vertices ( dim -- vertices )
+    checkmark-points concat >c-float-array ;
+
+PRIVATE>
+
+M: checkmark-paint recompute-pen
+    swap dim>> checkmark-vertices >>last-vertices drop ;
 
 M: checkmark-paint draw-interior
-    color>> set-color
-    origin get [
-        rect-dim
-        { 0 0 } over gl-line
-        dup { 0 1 } v* swap { 1 0 } v* gl-line
-    ] with-translation ;
+    [ compute-pen ]
+    [ color>> gl-color ]
+    [ last-vertices>> gl-vertex-pointer ] tri
+    GL_LINES 0 4 glDrawArrays ;
 
 : checkmark-theme ( gadget -- gadget )
     f
@@ -148,30 +164,47 @@ TUPLE: checkbox < button ;
 M: checkbox model-changed
     swap value>> >>selected? relayout-1 ;
 
-TUPLE: radio-paint color ;
+TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ;
 
-C: <radio-paint> radio-paint
+: <radio-paint> ( color -- paint ) radio-paint new swap >>color ;
+
+<PRIVATE
+
+: circle-steps 12 ;
+
+PRIVATE>
+
+M: radio-paint recompute-pen
+    swap dim>>
+    [ { 4 4 } swap { 8 8 } v- 12 circle-vertices >>interior-vertices ]
+    [ { 1 1 } swap { 2 2 } v- 12 circle-vertices >>boundary-vertices ] bi
+    drop ;
+
+<PRIVATE
+
+: (radio-paint) ( gadget paint -- )
+    [ compute-pen ] [ color>> gl-color ] bi ;
+
+PRIVATE>
 
 M: radio-paint draw-interior
-    color>> set-color
-    origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ;
+    [ (radio-paint) ] [ interior-vertices>> gl-vertex-pointer ] bi
+    GL_POLYGON 0 circle-steps glDrawArrays ;
 
 M: radio-paint draw-boundary
-    color>> set-color
-    origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ;
+    [ (radio-paint) ] [ boundary-vertices>> gl-vertex-pointer ] bi
+    GL_LINE_LOOP 0 circle-steps glDrawArrays ;
 
-: radio-knob-theme ( gadget -- gadget )
-    f
-    f
-    black <radio-paint>
-    black <radio-paint>
-    <button-paint> >>interior
-    black <radio-paint> >>boundary ;
+:: radio-knob-theme ( gadget -- gadget )
+    [let | radio-paint [ black <radio-paint> ] |
+        gadget
+        f f radio-paint radio-paint <button-paint> >>interior
+        radio-paint >>boundary
+        { 16 16 } >>dim
+    ] ;
 
 : <radio-knob> ( -- gadget )
-    <gadget>
-    radio-knob-theme
-    { 16 16 } >>dim ;
+    <gadget> radio-knob-theme ;
 
 TUPLE: radio-control < button value ;
 
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index a1026ef35a..4a5545f23c 100644
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -127,7 +127,7 @@ M: editor ungraft*
 : draw-caret ( -- )
     editor get focused?>> [
         editor get
-        dup caret-color>> set-color
+        dup caret-color>> gl-color
         dup caret-loc origin get v+
         swap caret-dim over v+
         [ { 0.5 -0.5 } v+ ] bi@ gl-line
@@ -171,7 +171,7 @@ M: editor ungraft*
 
 : draw-lines ( -- )
     \ first-visible-line get [
-        editor get dup color>> set-color
+        editor get dup color>> gl-color
         dup visible-lines
         [ draw-line 1 translate-lines ] with each
     ] with-editor-translation ;
@@ -190,7 +190,7 @@ M: editor ungraft*
     (draw-selection) ;
 
 : draw-selection ( -- )
-    editor get selection-color>> set-color
+    editor get selection-color>> gl-color
     editor get selection-start/end
     over first [
         2dup [
diff --git a/basis/ui/gadgets/grid-lines/grid-lines.factor b/basis/ui/gadgets/grid-lines/grid-lines.factor
index f4266adba1..0356e7fd4d 100644
--- a/basis/ui/gadgets/grid-lines/grid-lines.factor
+++ b/basis/ui/gadgets/grid-lines/grid-lines.factor
@@ -23,13 +23,10 @@ SYMBOL: grid-dim
     ] with each ;
 
 M: grid-lines draw-boundary
-    origin get [
-        -0.5 -0.5 0.0 glTranslated
-        color>> set-color [
-            dup grid set
-            dup rect-dim half-gap v- grid-dim set
-            compute-grid
-            { 0 1 } draw-grid-lines
-            { 1 0 } draw-grid-lines
-        ] with-scope
-    ] with-translation ;
+    color>> gl-color [
+        dup grid set
+        dup rect-dim half-gap v- grid-dim set
+        compute-grid
+        { 0 1 } draw-grid-lines
+        { 1 0 } draw-grid-lines
+    ] with-scope ;
diff --git a/basis/ui/gadgets/labelled/labelled.factor b/basis/ui/gadgets/labelled/labelled.factor
index 37b1d251e8..79a485b711 100644
--- a/basis/ui/gadgets/labelled/labelled.factor
+++ b/basis/ui/gadgets/labelled/labelled.factor
@@ -30,10 +30,10 @@ M: labelled-gadget focusable-child* content>> ;
 
 : title-theme ( gadget -- gadget )
     { 1 0 } >>orientation
-    T{ gradient f {
+    {
         T{ rgba f 0.65 0.65 1.0 1.0 }
         T{ rgba f 0.65 0.45 1.0 1.0 }
-    } } >>interior ;
+    } <gradient> >>interior ;
 
 : <title-label> ( text -- label ) <label> title-theme ;
 
diff --git a/basis/ui/gadgets/labels/labels.factor b/basis/ui/gadgets/labels/labels.factor
index 6c38b6183d..6e56b48c8b 100644
--- a/basis/ui/gadgets/labels/labels.factor
+++ b/basis/ui/gadgets/labels/labels.factor
@@ -34,7 +34,7 @@ M: label pref-dim*
     [ font>> open-font ] [ text>> ] bi text-dim ;
 
 M: label draw-gadget*
-    [ color>> set-color ]
+    [ color>> gl-color ]
     [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
 
 M: label gadget-text* label-string % ;
diff --git a/basis/ui/gadgets/lists/lists.factor b/basis/ui/gadgets/lists/lists.factor
index 17fe68721d..ec46638c91 100644
--- a/basis/ui/gadgets/lists/lists.factor
+++ b/basis/ui/gadgets/lists/lists.factor
@@ -56,8 +56,12 @@ M: list model-changed
 
 M: list draw-gadget*
     origin get [
-        dup color>> set-color
-        selected-rect [ rect-extent gl-fill-rect ] when*
+        dup color>> gl-color
+        selected-rect [
+            dup loc>> [
+                dim>> gl-fill-rect
+            ] with-translation
+        ] when*
     ] with-translation ;
 
 M: list focusable-child* drop t ;
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index f100a72f06..ef5745809e 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/basis/ui/gadgets/panes/panes.factor
@@ -63,7 +63,11 @@ GENERIC: draw-selection ( loc obj -- )
     >r clip get over intersects? r> [ drop ] if ; inline
 
 M: gadget draw-selection ( loc gadget -- )
-    swap offset-rect [ rect-extent gl-fill-rect ] if-fits ;
+    swap offset-rect [
+        dup loc>> [
+            dim>> gl-fill-rect
+        ] with-translation
+    ] if-fits ;
 
 M: node draw-selection ( loc node -- )
     2dup value>> swap offset-rect [
@@ -74,7 +78,7 @@ M: node draw-selection ( loc node -- )
 
 M: pane draw-gadget*
     dup gadget-selection? [
-        dup selection-color>> set-color
+        dup selection-color>> gl-color
         origin get over rect-loc v- swap selected-children
         [ draw-selection ] with each
     ] [
diff --git a/basis/ui/gadgets/theme/theme.factor b/basis/ui/gadgets/theme/theme.factor
index 5e4a2fbf4c..fa36e61d90 100644
--- a/basis/ui/gadgets/theme/theme.factor
+++ b/basis/ui/gadgets/theme/theme.factor
@@ -17,44 +17,44 @@ IN: ui.gadgets.theme
 
 : selection-color ( -- color ) light-purple ;
 
-: plain-gradient
-    T{ gradient f {
+: plain-gradient ( -- gradient )
+    {
         T{ gray f 0.94 1.0 }
         T{ gray f 0.83 1.0 }
         T{ gray f 0.83 1.0 }
         T{ gray f 0.62 1.0 }
-    } } ;
+    } <gradient> ;
 
-: rollover-gradient
-    T{ gradient f {
+: rollover-gradient ( -- gradient )
+    {
         T{ gray f 1.0  1.0 }
         T{ gray f 0.9  1.0 }
         T{ gray f 0.9  1.0 }
         T{ gray f 0.75 1.0 }
-    } } ;
+    } <gradient> ;
 
-: pressed-gradient
-    T{ gradient f {
+: pressed-gradient ( -- gradient )
+    {
         T{ gray f 0.75 1.0 }
         T{ gray f 0.9  1.0 }
         T{ gray f 0.9  1.0 }
         T{ gray f 1.0  1.0 }
-    } } ;
+    } <gradient> ;
 
-: selected-gradient
-    T{ gradient f {
+: selected-gradient ( -- gradient )
+    {
         T{ gray f 0.65 1.0 }
         T{ gray f 0.8  1.0 }
         T{ gray f 0.8  1.0 }
         T{ gray f 1.0  1.0 }
-    } } ;
+    } <gradient> ;
 
-: lowered-gradient
-    T{ gradient f {
+: lowered-gradient ( -- gradient )
+    {
         T{ gray f 0.37 1.0 }
         T{ gray f 0.43 1.0 }
         T{ gray f 0.5  1.0 }
-    } } ;
+    } <gradient> ;
 
 : sans-serif-font { "sans-serif" plain 12 } ;
 
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index 6f901c37ee..ec108b4514 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -83,6 +83,7 @@ SYMBOL: ui-error-hook
 [ rethrow ] ui-error-hook set-global
 
 : draw-world ( world -- )
+    [
     dup draw-world? [
         dup world [
             [
@@ -94,7 +95,8 @@ SYMBOL: ui-error-hook
         ] with-variable
     ] [
         drop
-    ] if ;
+    ] if USE: prettyprint
+    ] USE: tools.time benchmark global [ "timings" get-global push ] bind ;
 
 world H{
     { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }
diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor
index 9aacf1c724..b786a5e1fe 100644
--- a/basis/ui/render/render.factor
+++ b/basis/ui/render/render.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien arrays hashtables io kernel math namespaces opengl
-opengl.gl opengl.glu sequences strings io.styles vectors
-combinators math.vectors ui.gadgets colors
-math.order math.geometry.rect ;
+USING: accessors alien alien.c-types arrays hashtables io kernel
+math namespaces opengl opengl.gl opengl.glu sequences strings
+io.styles vectors combinators math.vectors ui.gadgets colors
+math.order math.geometry.rect locals ;
 IN: ui.render
 
 SYMBOL: clip
@@ -21,7 +21,7 @@ SYMBOL: viewport-translation
 : init-clip ( clip-rect rect -- )
     GL_SCISSOR_TEST glEnable
     [ rect-intersect ] keep
-    rect-dim dup { 0 1 } v* viewport-translation set
+    dim>> dup { 0 1 } v* viewport-translation set
     { 0 0 } over gl-viewport
     0 swap first2 0 gluOrtho2D
     clip set
@@ -31,12 +31,13 @@ SYMBOL: viewport-translation
     GL_SMOOTH glShadeModel
     GL_BLEND glEnable
     GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
+    GL_VERTEX_ARRAY glEnableClientState
     init-matrices
     init-clip
     ! white gl-clear is broken w.r.t window resizing
     ! Linux/PPC Radeon 9200
-    white set-color
-    clip get rect-extent gl-fill-rect ;
+    white gl-color
+    clip get dim>> gl-fill-rect ;
 
 GENERIC: draw-gadget* ( gadget -- )
 
@@ -60,10 +61,15 @@ DEFER: draw-gadget
 : (draw-gadget) ( gadget -- )
     [
         dup translate
-        dup dup interior>> draw-interior
+        dup interior>> [
+            origin get [ dupd draw-interior ] with-translation
+        ] when*
         dup draw-gadget*
         dup visible-children [ draw-gadget ] each
-        dup boundary>> draw-boundary
+        dup boundary>> [
+            origin get [ dupd draw-boundary ] with-translation
+        ] when*
+        drop
     ] with-scope ;
 
 : >absolute ( rect -- rect )
@@ -84,51 +90,97 @@ DEFER: draw-gadget
         [ [ (draw-gadget) ] with-clipping ]
     } cond ;
 
-! Pen paint properties
-M: f draw-interior 2drop ;
-M: f draw-boundary 2drop ;
+! A pen that caches vertex arrays, etc
+TUPLE: caching-pen last-dim ;
+
+GENERIC: recompute-pen ( gadget pen -- )
+
+: compute-pen ( gadget pen -- )
+    2dup [ dim>> ] [ last-dim>> ] bi* = [
+        2drop
+    ] [
+        [ swap dim>> >>last-dim drop ] [ recompute-pen ] 2bi
+    ] if ;
 
 ! Solid fill/border
-TUPLE: solid color ;
+TUPLE: solid < caching-pen color last-vertices ;
 
-C: <solid> solid
+: <solid> ( color -- solid ) solid new swap >>color ;
+
+M: solid recompute-pen
+    swap dim>> (rectangle-vertices) >>last-vertices drop ;
+
+<PRIVATE
 
 ! Solid pen
-: (solid) ( gadget paint -- loc dim )
-    color>> set-color rect-dim >r origin get dup r> v+ ;
+: (solid) ( gadget pen -- )
+    [ compute-pen ]
+    [ color>> gl-color ]
+    [ last-vertices>> gl-vertex-pointer ] tri ;
 
-M: solid draw-interior (solid) gl-fill-rect ;
+PRIVATE>
 
-M: solid draw-boundary (solid) gl-rect ;
+M: solid draw-interior (solid) (gl-fill-rect) ;
+
+M: solid draw-boundary (solid) (gl-rect) ;
 
 ! Gradient pen
-TUPLE: gradient colors ;
+TUPLE: gradient < caching-pen colors last-vertices last-colors ;
 
-C: <gradient> gradient
+: <gradient> ( colors -- gradient ) gradient new swap >>colors ;
+
+<PRIVATE
+
+:: gradient-vertices ( direction dim colors -- seq )
+    direction dim v* dim over v- swap
+    colors length dup 1- v/n [ v*n ] with map
+    [ dup rot v+ 2array ] with map
+    concat concat >c-float-array ;
+
+: gradient-colors ( colors -- seq )
+    [ color>raw 4array dup 2array ] map concat concat >c-float-array ;
+
+M: gradient recompute-pen ( gadget gradient -- )
+    tuck
+    [ [ orientation>> ] [ dim>> ] bi ] [ colors>> ] bi*
+    [ gradient-vertices >>last-vertices ]
+    [ gradient-colors >>last-colors ] bi
+    drop ;
+
+: draw-gradient ( colors -- )
+    GL_COLOR_ARRAY [
+        [ GL_QUAD_STRIP 0 ] dip length 2 * glDrawArrays
+    ] do-enabled-client-state ;
+
+PRIVATE>
 
 M: gradient draw-interior
-    origin get [
-        over orientation>>
-        swap colors>>
-        rot rect-dim
-        gl-gradient
-    ] with-translation ;
+    {
+        [ compute-pen ]
+        [ last-vertices>> gl-vertex-pointer ]
+        [ last-colors>> gl-color-pointer ]
+        [ colors>> draw-gradient ]
+    } cleave ;
 
 ! Polygon pen
-TUPLE: polygon color points ;
+TUPLE: polygon color vertex-array count ;
 
-C: <polygon> polygon
+: <polygon> ( color points -- polygon )
+    [ concat >c-float-array ] [ length ] bi polygon boa ;
 
-: draw-polygon ( polygon quot -- )
-    origin get [
-        >r dup color>> set-color points>> r> call
-    ] with-translation ; inline
+: draw-polygon ( polygon mode -- )
+    swap
+    [ color>> gl-color ]
+    [ vertex-array>> gl-vertex-pointer ]
+    [ 0 swap count>> glDrawArrays ]
+    tri ;
 
 M: polygon draw-boundary
-    [ gl-poly ] draw-polygon drop ;
+    GL_LINE_LOOP draw-polygon drop ;
 
 M: polygon draw-interior
-    [ gl-fill-poly ] draw-polygon drop ;
+    dup count>> 2 > GL_POLYGON GL_LINES ?
+    draw-polygon drop ;
 
 : arrow-up    { { 3 0 } { 6 6 } { 0 6 } } ;
 : arrow-right { { 0 0 } { 6 3 } { 0 6 } } ;

From c645613afd47fa8f3f4f6c29c0652c619ee2c307 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Tue, 11 Nov 2008 01:26:02 -0600
Subject: [PATCH 266/318] boids/ui/deploy.factor: Use input/output level 2

---
 extra/boids/ui/deploy.factor | 15 +++++++++------
 1 file changed, 9 insertions(+), 6 deletions(-)

diff --git a/extra/boids/ui/deploy.factor b/extra/boids/ui/deploy.factor
index 168c5d9ace..8b3c0baf76 100755
--- a/extra/boids/ui/deploy.factor
+++ b/extra/boids/ui/deploy.factor
@@ -1,12 +1,15 @@
 USING: tools.deploy.config ;
-V{
-    { deploy-ui? t }
-    { deploy-io 1 }
-    { deploy-reflection 1 }
-    { deploy-compiler? t }
+H{
     { deploy-math? t }
     { deploy-word-props? f }
     { deploy-c-types? f }
-    { "stop-after-last-window?" t }
+    { deploy-ui? t }
+    { deploy-io 2 }
+    { deploy-threads? t }
+    { deploy-word-defs? f }
+    { deploy-compiler? t }
+    { deploy-unicode? f }
     { deploy-name "Boids" }
+    { "stop-after-last-window?" t }
+    { deploy-reflection 1 }
 }

From 1ca40efa126475c4969859da34f0a935e1c0534e Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 6 Nov 2008 20:01:31 -0500
Subject: [PATCH 267/318] Adding coreset to extra/coroutines, plus docs and
 tests

---
 extra/coroutines/coroutines-docs.factor  | 8 +++++++-
 extra/coroutines/coroutines-tests.factor | 2 ++
 extra/coroutines/coroutines.factor       | 9 +++++++--
 3 files changed, 16 insertions(+), 3 deletions(-)

diff --git a/extra/coroutines/coroutines-docs.factor b/extra/coroutines/coroutines-docs.factor
index 327c60e017..3b2c5033e0 100644
--- a/extra/coroutines/coroutines-docs.factor
+++ b/extra/coroutines/coroutines-docs.factor
@@ -46,7 +46,13 @@ HELP: coyield*
 HELP: coterminate
 { $values { "v" "an object" } }
 { $description "Terminate the current coroutine, leaving the value v on the stack when control is passed to the " { $link coresume } " caller. Resuming a terminated coroutine is a no-op." }
-{ $see-also coyield }
+{ $see-also coyield coreset }
+;
+
+HELP: coreset
+{ $values { "v" "an object" } }
+{ $description "Reset the current coroutine, leaving the value v on the stack when control is passed to the " { $link coresume } " caller. When the coroutine is resumed, it will continue at the beginning of the coroutine." }
+{ $see-also coyield coterminate }
 ;
 
 HELP: current-coro
diff --git a/extra/coroutines/coroutines-tests.factor b/extra/coroutines/coroutines-tests.factor
index 6710452b22..5c443891cb 100644
--- a/extra/coroutines/coroutines-tests.factor
+++ b/extra/coroutines/coroutines-tests.factor
@@ -17,3 +17,5 @@ test1 dup *coresume . dup *coresume . dup *coresume . dup *coresume 2drop
   [ [ coyield* ] each ] cocreate ;
 
 { "c" "b" "a" } [ test3 { "a" "b" "c" } over coresume >r dup *coresume >r *coresume r> r> ] unit-test
+
+{ 4+2/3 } [ [ 1+ coyield 2 * coyield 3 / coreset ] cocreate 1 5 [ over coresume ] times nip ] unit-test
\ No newline at end of file
diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor
index dc594abd2d..59b703600c 100644
--- a/extra/coroutines/coroutines.factor
+++ b/extra/coroutines/coroutines.factor
@@ -6,7 +6,7 @@ IN: coroutines
 
 SYMBOL: current-coro
 
-TUPLE: coroutine resumecc exitcc ;
+TUPLE: coroutine resumecc exitcc originalcc ;
 
 : cocreate ( quot -- co )
   coroutine new
@@ -14,7 +14,7 @@ TUPLE: coroutine resumecc exitcc ;
   [ swapd , , \ bind , 
     "Coroutine has terminated illegally." , \ throw ,
   ] [ ] make
-  >>resumecc ;
+  [ >>resumecc ] [ >>originalcc ] bi ;
 
 : coresume ( v co -- result )
   [ 
@@ -43,3 +43,8 @@ TUPLE: coroutine resumecc exitcc ;
   current-coro get
   [ ] >>resumecc
   exitcc>> continue-with ;
+
+: coreset ( v --  )
+  current-coro get dup
+  originalcc>> >>resumecc
+  exitcc>> continue-with ;
\ No newline at end of file

From e149088f2f04f915cebc5b8b4f02577e6b190f93 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 6 Nov 2008 20:03:04 -0500
Subject: [PATCH 268/318] Changing extra/advice to use coreset instead of
 coterminate

---
 extra/advice/advice-tests.factor | 36 ++++++++++++++++++++++++++------
 extra/advice/advice.factor       | 10 ++++++---
 2 files changed, 37 insertions(+), 9 deletions(-)

diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor
index 17b60c8fb1..b359d5596f 100644
--- a/extra/advice/advice-tests.factor
+++ b/extra/advice/advice-tests.factor
@@ -23,18 +23,42 @@ IN: advice.tests
 \ bar make-advised
 
   { 11 } [
-     [ 2 * ] "double" \ bar advise-before
-     5 bar
+    [ 2 * ] "double" \ bar advise-before
+    5 bar
   ] unit-test 
 
   { 11/3 } [
-      [ 3 / ] "third" \ bar advise-after
-      5 bar
+    [ 3 / ] "third" \ bar advise-after
+     5 bar
   ] unit-test
 
   { -2 } [
-      [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
-      5 bar
+    [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+    5 bar
   ] unit-test
+
+: add ( a b -- c ) + ;
+\ add make-advised
+
+  { 10 } [
+    [ [ 2 * ] bi@ ] "double-args" \ add advise-before
+    2 3 add
+  ] unit-test 
+
+  { 21 } [
+    [ 3 * ad-do-it 1- ] "around1" \ add advise-around
+    2 3 add
+  ] unit-test 
+
+  { 9 } [
+    [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+    2 3 add
+  ] unit-test
+
+  { 5 } [
+      \ add unadvise
+      2 3 add
+  ] unit-test
+
  
  ] with-scope
\ No newline at end of file
diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor
index 6a7d46f935..b164c2c1a9 100644
--- a/extra/advice/advice.factor
+++ b/extra/advice/advice.factor
@@ -3,6 +3,8 @@
 USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
 IN: advice
 
+! TODO: What should be the order in which the advice is called?
+
 SYMBOLS: before after around advised ;
 
 <PRIVATE
@@ -17,7 +19,7 @@ PRIVATE>
     after advise ;
 
 : advise-around ( quot name word --  )
-    [ \ coterminate suffix ] 2dip
+    [ \ coreset suffix cocreate ] 2dip
     around advise ;
 
 : get-advice ( word type -- seq )
@@ -30,7 +32,7 @@ PRIVATE>
     after get-advice [ call ] each ;
 
 : call-around ( main word --  )
-    around get-advice [ cocreate ] map tuck 
+    around get-advice tuck 
     [ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
 
 : remove-advice ( name word loc --  )
@@ -46,4 +48,6 @@ PRIVATE>
     [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
     [ { before after around } [ H{ } clone swap set-word-prop ] with each ] 
     [ t advised set-word-prop ] tri ;
-    
\ No newline at end of file
+
+: unadvise ( word --  )
+    [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
\ No newline at end of file

From 8cc2f8264cbc74749b587277aa1278c3c3778c5e Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Thu, 6 Nov 2008 20:09:51 -0500
Subject: [PATCH 269/318] Adding name to authors of coroutines

---
 extra/coroutines/authors.txt             | 1 +
 extra/coroutines/coroutines-docs.factor  | 2 +-
 extra/coroutines/coroutines-tests.factor | 2 +-
 extra/coroutines/coroutines.factor       | 2 +-
 4 files changed, 4 insertions(+), 3 deletions(-)

diff --git a/extra/coroutines/authors.txt b/extra/coroutines/authors.txt
index 7edcfdd138..1a2b8570c4 100644
--- a/extra/coroutines/authors.txt
+++ b/extra/coroutines/authors.txt
@@ -1,2 +1,3 @@
 Chris Double
 Clemens F. Hofreither
+James Cash
diff --git a/extra/coroutines/coroutines-docs.factor b/extra/coroutines/coroutines-docs.factor
index 3b2c5033e0..6c6bffa64d 100644
--- a/extra/coroutines/coroutines-docs.factor
+++ b/extra/coroutines/coroutines-docs.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
 USING: help.markup help.syntax ;
 IN: coroutines
 
diff --git a/extra/coroutines/coroutines-tests.factor b/extra/coroutines/coroutines-tests.factor
index 5c443891cb..e07e9725d0 100644
--- a/extra/coroutines/coroutines-tests.factor
+++ b/extra/coroutines/coroutines-tests.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: coroutines.tests
 USING: coroutines kernel sequences prettyprint tools.test math ;
diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor
index 59b703600c..096e214bd2 100644
--- a/extra/coroutines/coroutines.factor
+++ b/extra/coroutines/coroutines.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
+! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither, 2008 James Cash.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel hashtables namespaces make continuations quotations
 accessors ;

From b68d3c94a7196035350bbcd7a269276525885327 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 01:44:53 -0500
Subject: [PATCH 270/318] Adding linked-assocs

---
 basis/linked-assocs/authors.txt               |  2 +
 basis/linked-assocs/linked-assocs-docs.factor |  3 ++
 .../linked-assocs/linked-assocs-tests.factor  | 26 +++++++++++++
 basis/linked-assocs/linked-assocs.factor      | 38 +++++++++++++++++++
 basis/linked-assocs/summary.txt               |  1 +
 basis/linked-assocs/tags.txt                  |  1 +
 6 files changed, 71 insertions(+)
 create mode 100644 basis/linked-assocs/authors.txt
 create mode 100644 basis/linked-assocs/linked-assocs-docs.factor
 create mode 100644 basis/linked-assocs/linked-assocs-tests.factor
 create mode 100644 basis/linked-assocs/linked-assocs.factor
 create mode 100644 basis/linked-assocs/summary.txt
 create mode 100644 basis/linked-assocs/tags.txt

diff --git a/basis/linked-assocs/authors.txt b/basis/linked-assocs/authors.txt
new file mode 100644
index 0000000000..35a4db1737
--- /dev/null
+++ b/basis/linked-assocs/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+James Cash
diff --git a/basis/linked-assocs/linked-assocs-docs.factor b/basis/linked-assocs/linked-assocs-docs.factor
new file mode 100644
index 0000000000..74a5fb52ff
--- /dev/null
+++ b/basis/linked-assocs/linked-assocs-docs.factor
@@ -0,0 +1,3 @@
+IN: linked-assocs
+USING: help.markup help.syntax ;
+
diff --git a/basis/linked-assocs/linked-assocs-tests.factor b/basis/linked-assocs/linked-assocs-tests.factor
new file mode 100644
index 0000000000..3ac590041b
--- /dev/null
+++ b/basis/linked-assocs/linked-assocs-tests.factor
@@ -0,0 +1,26 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences assocs tools.test linked-assocs ;
+IN: linked-assocs.test
+
+{ { 1 2 3 } } [
+    <linked-hash> 1 "b" pick set-at
+                  2 "c" pick set-at
+                  3 "a" pick set-at
+    values
+] unit-test
+
+{ 2 t } [
+    <linked-hash> 1 "b" pick set-at
+                  2 "c" pick set-at
+                  3 "a" pick set-at
+    "c" swap at*
+] unit-test
+
+{ { 2 3 4 } { "c" "a" "d" } } [
+    <linked-hash> 1 "a" pick set-at
+                  2 "c" pick set-at
+                  3 "a" pick set-at
+                  4 "d" pick set-at
+    [ values ] [ keys ] bi 
+] unit-test 
\ No newline at end of file
diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor
new file mode 100644
index 0000000000..f9849324df
--- /dev/null
+++ b/basis/linked-assocs/linked-assocs.factor
@@ -0,0 +1,38 @@
+! Copyright (C) 2008 Slava Pestov, James Cash.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs arrays kernel deques dlists sequences hashtables fry ;
+IN: linked-assocs
+
+TUPLE: linked-assoc assoc dlist ;
+
+: <linked-hash> ( -- assoc )
+    0 <hashtable> <dlist> linked-assoc boa ;
+
+M: linked-assoc assoc-size assoc>> assoc-size ;
+
+M: linked-assoc at* assoc>> at* tuck [ obj>> ] when swap ;
+
+<PRIVATE
+: add-to-dlist ( value key lassoc -- node )
+    [ swap 2array ] dip dlist>> push-back* ;
+
+: remove-from-dlist ( key dlist -- )
+    swap '[ _ = ] delete-node-if ;
+PRIVATE>
+
+M: linked-assoc set-at
+    [ add-to-dlist ] 2keep
+    assoc>> set-at ;
+
+M: linked-assoc delete-at
+    [ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ]
+    [ assoc>> delete-at ]
+    2bi ;
+
+: dlist>seq ( dlist -- seq )
+    [ ] pusher [ dlist-each ] dip ;
+
+M: linked-assoc >alist
+    dlist>> dlist>seq ;
+
+INSTANCE: linked-assoc assoc
diff --git a/basis/linked-assocs/summary.txt b/basis/linked-assocs/summary.txt
new file mode 100644
index 0000000000..54b0d14d4c
--- /dev/null
+++ b/basis/linked-assocs/summary.txt
@@ -0,0 +1 @@
+Assocs that yield items in insertion order
diff --git a/basis/linked-assocs/tags.txt b/basis/linked-assocs/tags.txt
new file mode 100644
index 0000000000..031765c41b
--- /dev/null
+++ b/basis/linked-assocs/tags.txt
@@ -0,0 +1 @@
+assocs

From b3acebc350b646cfc1f4a93ce0e72cbf1b59466f Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 02:18:03 -0500
Subject: [PATCH 271/318] linked-assocs passes tests

---
 basis/linked-assocs/linked-assocs.factor | 23 ++++++++++-------------
 1 file changed, 10 insertions(+), 13 deletions(-)

diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor
index f9849324df..ee29869dfd 100644
--- a/basis/linked-assocs/linked-assocs.factor
+++ b/basis/linked-assocs/linked-assocs.factor
@@ -10,25 +10,22 @@ TUPLE: linked-assoc assoc dlist ;
 
 M: linked-assoc assoc-size assoc>> assoc-size ;
 
-M: linked-assoc at* assoc>> at* tuck [ obj>> ] when swap ;
-
-<PRIVATE
-: add-to-dlist ( value key lassoc -- node )
-    [ swap 2array ] dip dlist>> push-back* ;
-
-: remove-from-dlist ( key dlist -- )
-    swap '[ _ = ] delete-node-if ;
-PRIVATE>
-
-M: linked-assoc set-at
-    [ add-to-dlist ] 2keep
-    assoc>> set-at ;
+M: linked-assoc at* assoc>> at* tuck [ obj>> ] when second swap ;
 
 M: linked-assoc delete-at
     [ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ]
     [ assoc>> delete-at ]
     2bi ;
 
+<PRIVATE
+: add-to-dlist ( value key lassoc -- node )
+    [ swap 2array ] dip dlist>> push-back* ;
+PRIVATE>
+
+M: linked-assoc set-at
+    [ 2dup assoc>> key? [ 2dup delete-at  ] when add-to-dlist ] 2keep
+    assoc>> set-at ;
+
 : dlist>seq ( dlist -- seq )
     [ ] pusher [ dlist-each ] dip ;
 

From 41b7853e082e121a276ac91c57394db8bc81e5c9 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 12:21:32 -0500
Subject: [PATCH 272/318] Adding more assoc protocol methods to linked-assocs,
 bugfixes

---
 basis/linked-assocs/linked-assocs.factor | 12 +++++++++---
 1 file changed, 9 insertions(+), 3 deletions(-)

diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor
index ee29869dfd..215b414e4b 100644
--- a/basis/linked-assocs/linked-assocs.factor
+++ b/basis/linked-assocs/linked-assocs.factor
@@ -10,12 +10,11 @@ TUPLE: linked-assoc assoc dlist ;
 
 M: linked-assoc assoc-size assoc>> assoc-size ;
 
-M: linked-assoc at* assoc>> at* tuck [ obj>> ] when second swap ;
+M: linked-assoc at* assoc>> at* tuck [ obj>> second ] when swap ;
 
 M: linked-assoc delete-at
     [ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ]
-    [ assoc>> delete-at ]
-    2bi ;
+    [ assoc>> delete-at ] 2bi ;
 
 <PRIVATE
 : add-to-dlist ( value key lassoc -- node )
@@ -32,4 +31,11 @@ M: linked-assoc set-at
 M: linked-assoc >alist
     dlist>> dlist>seq ;
 
+M: linked-assoc clear-assoc
+    [ assoc>> clear-assoc ] [ dlist>> clear-deque ] bi ;
+
+M: linked-assoc clone 
+    [ assoc>> clone ] [ dlist>> clone ] bi
+    linked-assoc boa ;
+
 INSTANCE: linked-assoc assoc

From 143567c9178f55cd5ac0d7d16248df383dbcc360 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 12:21:50 -0500
Subject: [PATCH 273/318] More tests for linked-assocs

---
 .../linked-assocs/linked-assocs-tests.factor  | 29 +++++++++++++++++--
 1 file changed, 26 insertions(+), 3 deletions(-)

diff --git a/basis/linked-assocs/linked-assocs-tests.factor b/basis/linked-assocs/linked-assocs-tests.factor
index 3ac590041b..64d5c60481 100644
--- a/basis/linked-assocs/linked-assocs-tests.factor
+++ b/basis/linked-assocs/linked-assocs-tests.factor
@@ -17,10 +17,33 @@ IN: linked-assocs.test
     "c" swap at*
 ] unit-test
 
-{ { 2 3 4 } { "c" "a" "d" } } [
+{ { 2 3 4 } { "c" "a" "d" } 3 } [
     <linked-hash> 1 "a" pick set-at
                   2 "c" pick set-at
                   3 "a" pick set-at
                   4 "d" pick set-at
-    [ values ] [ keys ] bi 
-] unit-test 
\ No newline at end of file
+    [ values ] [ keys ] [ assoc-size ] tri
+] unit-test 
+
+{ f 1 } [
+    <linked-hash> 1 "c" pick set-at
+                  2 "b" pick set-at
+    "c" over delete-at
+    "c" over at swap assoc-size
+] unit-test 
+
+{ { } 0 } [
+    <linked-hash> 1 "a" pick set-at
+                  2 "c" pick set-at
+                  3 "a" pick set-at
+                  4 "d" pick set-at
+    dup clear-assoc [ keys ] [ assoc-size ] bi
+] unit-test
+
+{ { } { 1 2 3 } } [
+    <linked-hash> dup clone
+    1 "c" pick set-at
+    2 "q" pick set-at
+    3 "a" pick set-at
+    [ values ] bi@
+] unit-test

From d9076407fb75c31d697572292a237e8307198d7b Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 12:22:06 -0500
Subject: [PATCH 274/318] Writing docs for linked-assocs

---
 basis/linked-assocs/linked-assocs-docs.factor | 22 ++++++++++++++++++-
 1 file changed, 21 insertions(+), 1 deletion(-)

diff --git a/basis/linked-assocs/linked-assocs-docs.factor b/basis/linked-assocs/linked-assocs-docs.factor
index 74a5fb52ff..8f73bdfd36 100644
--- a/basis/linked-assocs/linked-assocs-docs.factor
+++ b/basis/linked-assocs/linked-assocs-docs.factor
@@ -1,3 +1,23 @@
 IN: linked-assocs
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax assocs ;
 
+HELP: linked-assoc
+{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assocs and a dlist.  The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ;
+
+HELP: <linked-hash>
+{ $values { "assoc" "A new linked-assoc" } }
+{ $description "Creates a new, empty linked assoc." } ;
+
+ARTICLE: "linked-assocs" "Linked assocs"
+"A " { $emphasis "linked assoc" } " is an assoc which combines a hash table and a dlist to form a structure which has the insertion and retrieval characteristics of a hash table, but with the ability to get the items in insertion order."
+$nl
+"Linked assocs implement the following methods from the assoc protocol:"
+{ $subsection at* }
+{ $subsection assoc-size }
+{ $subsection >alist }
+{ $subsection set-at }
+{ $subsection delete-at }
+{ $subsection clear-assoc }
+{ $subsection >alist } ;
+
+ABOUT: "linked-assocs"
\ No newline at end of file

From cc877bf79b786c3a822ec91aeafc669586505e14 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 13:33:42 -0500
Subject: [PATCH 275/318] Fixing identation in advice-tests

---
 extra/advice/advice-tests.factor | 119 +++++++++++++++++++------------
 1 file changed, 74 insertions(+), 45 deletions(-)

diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor
index b359d5596f..ece4cb52a7 100644
--- a/extra/advice/advice-tests.factor
+++ b/extra/advice/advice-tests.factor
@@ -1,64 +1,93 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math tools.test advice parser namespaces ;
+USING: kernel sequences io io.streams.string math tools.test advice math.parser
+parser namespaces multiline eval words assocs ;
 IN: advice.tests
 
 [
-: foo "foo" ; 
-\ foo make-advised
+    [ ad-do-it ] must-fail
+    
+    : foo "foo" ; 
+    \ foo make-advised
  
-  { "bar" "foo" } [
-     [ "bar" ] "barify" \ foo advise-before
-     foo ] unit-test
+    { "bar" "foo" } [
+        [ "bar" ] "barify" \ foo advise-before
+        foo
+    ] unit-test
  
-  { "bar" "foo" "baz" } [
-      [ "baz" ] "bazify" \ foo advise-after
-      foo ] unit-test
+    { "bar" "foo" "baz" } [
+        [ "baz" ] "bazify" \ foo advise-after
+        foo
+    ] unit-test
  
-  { "foo" "baz" } [
-     "barify" \ foo before remove-advice
-     foo ] unit-test
+    { "foo" "baz" } [
+        "barify" \ foo before remove-advice
+        foo
+    ] unit-test
  
-: bar ( a -- b ) 1+ ;
-\ bar make-advised
+    : bar ( a -- b ) 1+ ;
+    \ bar make-advised
 
-  { 11 } [
-    [ 2 * ] "double" \ bar advise-before
-    5 bar
-  ] unit-test 
+    { 11 } [
+        [ 2 * ] "double" \ bar advise-before
+        5 bar
+    ] unit-test 
 
-  { 11/3 } [
-    [ 3 / ] "third" \ bar advise-after
-     5 bar
-  ] unit-test
+    { 11/3 } [
+        [ 3 / ] "third" \ bar advise-after
+        5 bar
+    ] unit-test
 
-  { -2 } [
-    [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
-    5 bar
-  ] unit-test
+    { -2 } [
+        [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+        5 bar
+    ] unit-test
 
-: add ( a b -- c ) + ;
-\ add make-advised
+    : add ( a b -- c ) + ;
+    \ add make-advised
 
-  { 10 } [
-    [ [ 2 * ] bi@ ] "double-args" \ add advise-before
-    2 3 add
-  ] unit-test 
+    { 10 } [
+        [ [ 2 * ] bi@ ] "double-args" \ add advise-before
+        2 3 add
+    ] unit-test 
 
-  { 21 } [
-    [ 3 * ad-do-it 1- ] "around1" \ add advise-around
-    2 3 add
-  ] unit-test 
+    { 21 } [
+        [ 3 * ad-do-it 1- ] "around1" \ add advise-around
+        2 3 add
+    ] unit-test 
 
-  { 9 } [
-    [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
-    2 3 add
-  ] unit-test
+    { 9 } [
+        [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+        2 3 add
+    ] unit-test
 
-  { 5 } [
-      \ add unadvise
-      2 3 add
-  ] unit-test
+    { { "around1" "around2" } } [
+        \ add around word-prop keys
+    ] unit-test
 
+    { 5 f } [
+        \ add unadvise
+        2 3 add \ add advised?
+    ] unit-test
+
+    : quux ( a b -- c ) * ;
+
+    { f t 3+3/4 } [
+        <" USING: advice kernel math ;
+           IN: advice.tests
+           \ quux advised?
+           ADVISE: quux halve before [ 2 / ] bi@ ;
+           \ quux advised? 
+           3 5 quux"> eval
+    ] unit-test
+
+    { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
+        <" USING: advice kernel math math.parser io io.streams.string ; IN: advice.tests
+           ADVISE: quux log around
+           2dup [ number>string write " " write ] bi@
+           ad-do-it 
+           dup number>string write ;
+           [ 3 5 quux ] with-string-writer"> eval
+    ] unit-test 
  
- ] with-scope
\ No newline at end of file
+] with-scope
\ No newline at end of file

From ec7bc276dc429a87c2fa0b0719c6e8c5c8f3db3a Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Sat, 8 Nov 2008 13:38:56 -0500
Subject: [PATCH 276/318] Adding documentation for ad-do-it

---
 extra/advice/advice-docs.factor | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/extra/advice/advice-docs.factor b/extra/advice/advice-docs.factor
index 7b523e9a8c..2c470d04b3 100644
--- a/extra/advice/advice-docs.factor
+++ b/extra/advice/advice-docs.factor
@@ -1,5 +1,5 @@
 IN: advice
-USING: help.markup help.syntax tools.annotations words ;
+USING: help.markup help.syntax tools.annotations words coroutines ;
 
 HELP: make-advised
 { $values { "word" "a word to annotate in preparation of advising" } }
@@ -16,6 +16,11 @@ HELP: advised?
 { $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
 { $description "Determines whether or not the given word has any advice on it." } ;
 
+HELP: ad-do-it
+{ $values { "input" "an object" } { "output" "an object" } }
+{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished.  This word should only be called from inside advice." }
+{ $see-also coyield } ;
+
 ARTICLE: "advice" "Advice"
 "Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
 

From 44bfc0f802e18eaf3c0dce1dc22b5e603821a97f Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 01:31:22 -0500
Subject: [PATCH 277/318] More work on advice, cleaning it up (TESTS FAIL)

---
 extra/advice/advice.factor | 54 ++++++++++++++++++++++----------------
 1 file changed, 32 insertions(+), 22 deletions(-)

diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor
index b164c2c1a9..383812e602 100644
--- a/extra/advice/advice.factor
+++ b/extra/advice/advice.factor
@@ -1,26 +1,31 @@
 ! Copyright (C) 2008 James Cash
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences symbols fry words assocs tools.annotations coroutines ;
+USING: kernel sequences symbols fry words assocs linked-assocs tools.annotations
+coroutines lexer parser quotations arrays namespaces continuations ;
 IN: advice
 
-! TODO: What should be the order in which the advice is called?
+SYMBOLS: before after around advised in-advice? ;
 
-SYMBOLS: before after around advised ;
+: advised? ( word -- ? )
+    advised word-prop ;
+
+DEFER: make-advised
 
 <PRIVATE
-: advise ( quot name word loc --  )
-    word-prop set-at ;
+: init-around-co ( quot -- coroutine )
+    \ coreset suffix cocreate ;
 PRIVATE>
-    
-: advise-before ( quot name word --  )
-    before advise ;
-    
-: advise-after ( quot name word --  )
-    after advise ;
 
-: advise-around ( quot name word --  )
-    [ \ coreset suffix cocreate ] 2dip
-    around advise ;
+: advise ( quot name word loc --  )
+    dup around eq? [ [ init-around-co ] 3dip ] when
+    over advised? [ over make-advised ] unless
+    word-prop set-at ;
+    
+: advise-before ( quot name word --  ) before advise ;
+    
+: advise-after ( quot name word --  ) after advise ;
+
+: advise-around ( quot name word --  ) around advise ;
 
 : get-advice ( word type -- seq )
     word-prop values ;
@@ -32,22 +37,27 @@ PRIVATE>
     after get-advice [ call ] each ;
 
 : call-around ( main word --  )
-    around get-advice tuck 
-    [ [ coresume ] each ] [ call ] [ reverse [ coresume ] each ] tri* ;
+    t in-advice? [
+        around get-advice tuck 
+        [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
+    ] with-variable ;
 
 : remove-advice ( name word loc --  )
     word-prop delete-at ;
 
 : ad-do-it ( input -- result )
-    coyield ;
-
-: advised? ( word -- ? )
-    advised word-prop ;
+    in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ;
     
 : make-advised ( word -- )
     [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
-    [ { before after around } [ H{ } clone swap set-word-prop ] with each ] 
+    [ { before after around } [ <linked-hash> swap set-word-prop ] with each ] 
     [ t advised set-word-prop ] tri ;
 
 : unadvise ( word --  )
-    [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
\ No newline at end of file
+    [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
+
+: ADVISE: ! word adname location => word adname quot loc
+    scan-word scan scan-word parse-definition swap [ spin ] dip advise ; parsing
+    
+: UNADVISE:    
+    scan-word parsed \ unadvise parsed ; parsing
\ No newline at end of file

From a5576bbb1d99eb0e9f0cf14e9e48e8af2c913bd5 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 02:04:25 -0500
Subject: [PATCH 278/318] Fixing extra space, replacing tuck ... swap with [
 ... ] keep

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

diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor
index 215b414e4b..54f4be7269 100644
--- a/basis/linked-assocs/linked-assocs.factor
+++ b/basis/linked-assocs/linked-assocs.factor
@@ -10,7 +10,7 @@ TUPLE: linked-assoc assoc dlist ;
 
 M: linked-assoc assoc-size assoc>> assoc-size ;
 
-M: linked-assoc at* assoc>> at* tuck [ obj>> second ] when swap ;
+M: linked-assoc at* assoc>> at* [ [ obj>> second ] when ] keep ;
 
 M: linked-assoc delete-at
     [ [ assoc>> ] [ dlist>> ] bi [ at ] dip '[ _ delete-node ] when* ]
@@ -22,7 +22,7 @@ M: linked-assoc delete-at
 PRIVATE>
 
 M: linked-assoc set-at
-    [ 2dup assoc>> key? [ 2dup delete-at  ] when add-to-dlist ] 2keep
+    [ 2dup assoc>> key? [ 2dup delete-at ] when add-to-dlist ] 2keep
     assoc>> set-at ;
 
 : dlist>seq ( dlist -- seq )

From da3399f31d4a3ebd9302e032176c9f3aa8e45f06 Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 02:04:40 -0500
Subject: [PATCH 279/318] More tests for linked-assocs

---
 basis/linked-assocs/linked-assocs-tests.factor | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

diff --git a/basis/linked-assocs/linked-assocs-tests.factor b/basis/linked-assocs/linked-assocs-tests.factor
index 64d5c60481..7a259ee59a 100644
--- a/basis/linked-assocs/linked-assocs-tests.factor
+++ b/basis/linked-assocs/linked-assocs-tests.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences assocs tools.test linked-assocs ;
+USING: kernel sequences assocs tools.test linked-assocs math ;
 IN: linked-assocs.test
 
 { { 1 2 3 } } [
@@ -47,3 +47,11 @@ IN: linked-assocs.test
     3 "a" pick set-at
     [ values ] bi@
 ] unit-test
+
+{ 9 } [
+    <linked-hash>
+    { [ 3 * ] [ 1- ] }          "first"   pick set-at
+    { [ [ 1- ] bi@ ] [ 2 / ] }  "second"  pick set-at
+    4 6 pick values [ first call ] each
+    + swap values <reversed> [ second call ] each
+] unit-test
\ No newline at end of file

From b693cd8ab1293d5478bfedc0713af7a1cf4f7a0f Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 02:31:37 -0500
Subject: [PATCH 280/318] Adding coreset to description in comments

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

diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor
index 096e214bd2..51276336e3 100644
--- a/extra/coroutines/coroutines.factor
+++ b/extra/coroutines/coroutines.factor
@@ -21,7 +21,7 @@ TUPLE: coroutine resumecc exitcc originalcc ;
     >>exitcc
     resumecc>> call
     #! At this point, the coroutine quotation must have terminated
-    #! normally (without calling coyield or coterminate). This shouldn't happen.
+    #! normally (without calling coyield, coreset, or coterminate). This shouldn't happen.
     f over
   ] callcc1 2nip ;
 

From 62e6a139c3ceda9a09f8ef7cfbf7c79751ec710b Mon Sep 17 00:00:00 2001
From: James Cash <james.nvc@gmail.com>
Date: Tue, 11 Nov 2008 02:31:53 -0500
Subject: [PATCH 281/318] Commenting out failing tests for push

---
 extra/advice/advice-tests.factor | 49 ++++++++++++++++----------------
 1 file changed, 25 insertions(+), 24 deletions(-)

diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor
index ece4cb52a7..be16150c2e 100644
--- a/extra/advice/advice-tests.factor
+++ b/extra/advice/advice-tests.factor
@@ -56,38 +56,39 @@ IN: advice.tests
         2 3 add
     ] unit-test 
 
-    { 9 } [
-        [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
-        2 3 add
-    ] unit-test
+!     { 9 } [
+!         [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+!         2 3 add
+!     ] unit-test
 
-    { { "around1" "around2" } } [
-        \ add around word-prop keys
-    ] unit-test
+!     { { "around1" "around2" } } [
+!         \ add around word-prop keys
+!     ] unit-test
 
     { 5 f } [
         \ add unadvise
         2 3 add \ add advised?
     ] unit-test
 
-    : quux ( a b -- c ) * ;
+!     : quux ( a b -- c ) * ;
 
-    { f t 3+3/4 } [
-        <" USING: advice kernel math ;
-           IN: advice.tests
-           \ quux advised?
-           ADVISE: quux halve before [ 2 / ] bi@ ;
-           \ quux advised? 
-           3 5 quux"> eval
-    ] unit-test
+!     { f t 3+3/4 } [
+!         <" USING: advice kernel math ;
+!            IN: advice.tests
+!            \ quux advised?
+!            ADVISE: quux halve before [ 2 / ] bi@ ;
+!            \ quux advised? 
+!            3 5 quux"> eval
+!     ] unit-test
 
-    { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
-        <" USING: advice kernel math math.parser io io.streams.string ; IN: advice.tests
-           ADVISE: quux log around
-           2dup [ number>string write " " write ] bi@
-           ad-do-it 
-           dup number>string write ;
-           [ 3 5 quux ] with-string-writer"> eval
-    ] unit-test 
+!     { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
+!         <" USING: advice kernel math math.parser io io.streams.string ;
+!            IN: advice.tests
+!            ADVISE: quux log around
+!            2dup [ number>string write " " write ] bi@
+!            ad-do-it 
+!            dup number>string write ;
+!            [ 3 5 quux ] with-string-writer"> eval
+!     ] unit-test 
  
 ] with-scope
\ No newline at end of file

From d579628d616546f17c38ab3a6cf3c53ea4e5c902 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 02:31:56 -0600
Subject: [PATCH 282/318] More OpenGL rendering tweaks

---
 basis/opengl/opengl.factor              | 33 ++++++++++++++++---------
 basis/ui/freetype/freetype.factor       |  1 +
 basis/ui/gadgets/buttons/buttons.factor | 10 ++++----
 basis/ui/gadgets/editors/editors.factor | 18 ++++++++------
 basis/ui/gadgets/worlds/worlds.factor   |  4 +--
 5 files changed, 40 insertions(+), 26 deletions(-)

diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index 7cf141ca6a..64326f340e 100644
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -69,7 +69,24 @@ MACRO: all-enabled-client-state ( seq quot -- )
 : gl-line ( a b -- )
     line-vertices GL_LINES 0 2 glDrawArrays ;
 
-: (rectangle-vertices) ( dim -- vertices )
+: (rect-vertices) ( dim -- vertices )
+    {
+        [ drop 0 1 ]
+        [ first 1- 1 ]
+        [ [ first 1- ] [ second ] bi ]
+        [ second 0 swap ]
+    } cleave 8 narray >c-float-array ;
+
+: rect-vertices ( dim -- )
+    (rect-vertices) gl-vertex-pointer ;
+
+: (gl-rect) ( -- )
+    GL_LINE_LOOP 0 4 glDrawArrays ;
+
+: gl-rect ( dim -- )
+    rect-vertices (gl-rect) ;
+
+: (fill-rect-vertices) ( dim -- vertices )
     {
         [ drop 0 0 ]
         [ first 0 ]
@@ -77,20 +94,14 @@ MACRO: all-enabled-client-state ( seq quot -- )
         [ second 0 swap ]
     } cleave 8 narray >c-float-array ;
 
-: rectangle-vertices ( dim -- )
-    (rectangle-vertices) gl-vertex-pointer ;
-
-: (gl-rect) ( -- )
-    GL_LINE_LOOP 0 4 glDrawArrays ;
-
-: gl-rect ( dim -- )
-    rectangle-vertices (gl-rect) ;
+: fill-rect-vertices ( dim -- )
+    (fill-rect-vertices) gl-vertex-pointer ;
 
 : (gl-fill-rect) ( -- )
     GL_QUADS 0 4 glDrawArrays ;
 
 : gl-fill-rect ( dim -- )
-    rectangle-vertices (gl-fill-rect) ;
+    fill-rect-vertices (gl-fill-rect) ;
 
 : circle-steps ( steps -- angles )
     dup length v/n 2 pi * v*n ;
@@ -203,7 +214,7 @@ MEMO: (rect-texture-coords) ( -- seq )
         dup loc>> gl-translate
         GL_TEXTURE_2D over texture>> glBindTexture
         init-texture rect-texture-coords
-        dim2>> rectangle-vertices
+        dim2>> fill-rect-vertices
         (gl-fill-rect)
         GL_TEXTURE_2D 0 glBindTexture
     ] do-enabled-client-state ;
diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor
index d2dfe56ed4..5a6118fb00 100644
--- a/basis/ui/freetype/freetype.factor
+++ b/basis/ui/freetype/freetype.factor
@@ -196,6 +196,7 @@ M: freetype-renderer string-height ( open-font string -- h )
 :: (draw-string) ( open-font sprites string loc -- )
     GL_TEXTURE_2D [
         loc [
+            -0.5 0.5 0.0 glTranslated
             string open-font string char-widths scan-sums [
                 [ open-font sprites ] 2dip draw-char
             ] 2each
diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor
index 9f3e3a8520..11fb69fc7d 100644
--- a/basis/ui/gadgets/buttons/buttons.factor
+++ b/basis/ui/gadgets/buttons/buttons.factor
@@ -111,8 +111,8 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ;
 
 : checkmark-points ( dim -- points )
     {
-        [ { 0 0 } v* ]
-        [ { 1 1 } v* ]
+        [ { 0 0 } v* { 0 1 } v+ ]
+        [ { 1 1 } v* { 0 1 } v+ ]
         [ { 0 1 } v* ]
         [ { 1 0 } v* ]
     } cleave 4array ;
@@ -170,14 +170,14 @@ TUPLE: radio-paint < caching-pen color interior-vertices boundary-vertices ;
 
 <PRIVATE
 
-: circle-steps 12 ;
+: circle-steps 8 ;
 
 PRIVATE>
 
 M: radio-paint recompute-pen
     swap dim>>
-    [ { 4 4 } swap { 8 8 } v- 12 circle-vertices >>interior-vertices ]
-    [ { 1 1 } swap { 2 2 } v- 12 circle-vertices >>boundary-vertices ] bi
+    [ { 4 4 } swap { 9 9 } v- circle-steps circle-vertices >>interior-vertices ]
+    [ { 1 1 } swap { 3 3 } v- circle-steps circle-vertices >>boundary-vertices ] bi
     drop ;
 
 <PRIVATE
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index 4a5545f23c..0d0611f532 100644
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -127,10 +127,12 @@ M: editor ungraft*
 : draw-caret ( -- )
     editor get focused?>> [
         editor get
-        dup caret-color>> gl-color
-        dup caret-loc origin get v+
-        swap caret-dim over v+
-        [ { 0.5 -0.5 } v+ ] bi@ gl-line
+        [ caret-color>> gl-color ]
+        [
+            dup caret-loc origin get v+
+            swap caret-dim over v+
+            gl-line
+        ] bi
     ] when ;
 
 : line-translation ( n -- loc )
@@ -180,12 +182,14 @@ M: editor ungraft*
     dup editor-mark* swap editor-caret* sort-pair ;
 
 : (draw-selection) ( x1 x2 -- )
-    2dup = [ 2 + ] when
-    0.0 swap editor get line-height glRectd ;
+    over -
+    dup 0 = [ 2 + ] when
+    [ 0.0 2array ] [ editor get line-height 2array ] bi*
+    swap [ gl-fill-rect ] with-translation ;
 
 : draw-selected-line ( start end n -- )
     [ start/end-on-line ] keep tuck
-    >r >r editor get offset>x r> r>
+    [ editor get offset>x ] 2dip
     editor get offset>x
     (draw-selection) ;
 
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index ec108b4514..6f901c37ee 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -83,7 +83,6 @@ SYMBOL: ui-error-hook
 [ rethrow ] ui-error-hook set-global
 
 : draw-world ( world -- )
-    [
     dup draw-world? [
         dup world [
             [
@@ -95,8 +94,7 @@ SYMBOL: ui-error-hook
         ] with-variable
     ] [
         drop
-    ] if USE: prettyprint
-    ] USE: tools.time benchmark global [ "timings" get-global push ] bind ;
+    ] if ;
 
 world H{
     { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }

From bb44effcb31e170617b49396932a9f516ec1fd2e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 02:35:27 -0600
Subject: [PATCH 283/318] Forgot to include this in the last patch

---
 basis/ui/render/render.factor | 21 +++++++++++++--------
 1 file changed, 13 insertions(+), 8 deletions(-)

diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor
index b786a5e1fe..71304aca0b 100644
--- a/basis/ui/render/render.factor
+++ b/basis/ui/render/render.factor
@@ -23,7 +23,7 @@ SYMBOL: viewport-translation
     [ rect-intersect ] keep
     dim>> dup { 0 1 } v* viewport-translation set
     { 0 0 } over gl-viewport
-    0 swap first2 0 gluOrtho2D
+    -0.5 swap first2 [ 0.5 - ] [ 0.5 + ] bi* 0.5 gluOrtho2D
     clip set
     do-clip ;
 
@@ -103,26 +103,31 @@ GENERIC: recompute-pen ( gadget pen -- )
     ] if ;
 
 ! Solid fill/border
-TUPLE: solid < caching-pen color last-vertices ;
+TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
 
 : <solid> ( color -- solid ) solid new swap >>color ;
 
 M: solid recompute-pen
-    swap dim>> (rectangle-vertices) >>last-vertices drop ;
+    swap dim>>
+    [ (fill-rect-vertices) >>interior-vertices ]
+    [ (rect-vertices) >>boundary-vertices ]
+    bi drop ;
 
 <PRIVATE
 
 ! Solid pen
 : (solid) ( gadget pen -- )
-    [ compute-pen ]
-    [ color>> gl-color ]
-    [ last-vertices>> gl-vertex-pointer ] tri ;
+    [ compute-pen ] [ color>> gl-color ] bi ;
 
 PRIVATE>
 
-M: solid draw-interior (solid) (gl-fill-rect) ;
+M: solid draw-interior
+    [ (solid) ] [ interior-vertices>> gl-vertex-pointer ] bi
+    (gl-fill-rect) ;
 
-M: solid draw-boundary (solid) (gl-rect) ;
+M: solid draw-boundary
+    [ (solid) ] [ boundary-vertices>> gl-vertex-pointer ] bi
+    (gl-rect) ;
 
 ! Gradient pen
 TUPLE: gradient < caching-pen colors last-vertices last-colors ;

From 18df06fde1871286953d1d93f24f262a42e8be75 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 03:10:41 -0600
Subject: [PATCH 284/318] Updating various apps in extra for GL words being
 moved around

---
 extra/automata/ui/ui.factor                   |  2 +-
 extra/bunny/model/model.factor                |  9 ++++---
 extra/bunny/outlined/outlined.factor          |  4 +--
 extra/cfdg/cfdg.factor                        | 12 ++++-----
 extra/jamshred/gl/gl.factor                   |  7 +++--
 extra/maze/maze.factor                        |  5 ++--
 extra/nehe/2/2.factor                         |  4 +--
 extra/nehe/3/3.factor                         |  4 +--
 extra/nehe/4/4.factor                         |  4 +--
 extra/nehe/5/5.factor                         |  4 +--
 extra/opengl/demo-support/demo-support.factor | 26 ++++++++++++++++---
 extra/opengl/gadgets/gadgets.factor           |  2 +-
 extra/processing/shapes/shapes.factor         | 10 +++----
 extra/spheres/spheres.factor                  |  7 ++---
 extra/springies/ui/ui.factor                  |  2 +-
 extra/tetris/gl/gl.factor                     |  8 +++---
 16 files changed, 68 insertions(+), 42 deletions(-)

diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor
index 037cf41118..cfb0462877 100644
--- a/extra/automata/ui/ui.factor
+++ b/extra/automata/ui/ui.factor
@@ -30,7 +30,7 @@ IN: automata.ui
 
 : draw-bitmap ( bitmap -- ) GL_POINTS glBegin (draw-bitmap) glEnd ;
 
-: display ( -- ) black set-color bitmap> draw-bitmap ;
+: display ( -- ) black gl-color bitmap> draw-bitmap ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
index 32312aed89..1bbaf796ad 100755
--- a/extra/bunny/model/model.factor
+++ b/extra/bunny/model/model.factor
@@ -1,7 +1,8 @@
-USING: accessors alien.c-types arrays combinators destructors http.client
-io io.encodings.ascii io.files kernel math math.matrices math.parser
-math.vectors opengl opengl.capabilities opengl.gl sequences sequences.lib
-splitting vectors words ;
+USING: accessors alien.c-types arrays combinators destructors
+http.client io io.encodings.ascii io.files kernel math
+math.matrices math.parser math.vectors opengl
+opengl.capabilities opengl.gl opengl.demo-support sequences
+sequences.lib splitting vectors words ;
 IN: bunny.model
 
 : numbers ( str -- seq )
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index cd67b8b33e..6117a0fdea 100755
--- a/extra/bunny/outlined/outlined.factor
+++ b/extra/bunny/outlined/outlined.factor
@@ -1,7 +1,7 @@
 USING: arrays bunny.model bunny.cel-shaded continuations
 destructors kernel math multiline opengl opengl.shaders
-opengl.framebuffers opengl.gl opengl.capabilities sequences
-ui.gadgets combinators accessors ;
+opengl.framebuffers opengl.gl opengl.demo-support
+opengl.capabilities sequences ui.gadgets combinators accessors ;
 IN: bunny.outlined
 
 STRING: outlined-pass1-fragment-shader-main-source
diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor
index 99d5dbbc48..102de8fd22 100644
--- a/extra/cfdg/cfdg.factor
+++ b/extra/cfdg/cfdg.factor
@@ -14,7 +14,7 @@ IN: cfdg
 
 SELF-SLOTS: hsva
 
-: clear-color ( color -- ) set-clear-color GL_COLOR_BUFFER_BIT glClear ;
+: clear-color ( color -- ) gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -49,7 +49,7 @@ VAR: color-stack
 
 : push-color ( -- ) self> color-stack> push   self> clone >self ;
 
-: pop-color ( -- ) color-stack> pop dup >self set-color ;
+: pop-color ( -- ) color-stack> pop dup >self gl-color ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -80,11 +80,11 @@ VAR: threshold
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : circle ( -- )
-  self> set-color
+  self> gl-color
   gluNewQuadric dup 0 0.5 20 10 gluDisk gluDeleteQuadric ;
 
 : triangle ( -- )
-  self> set-color
+  self> gl-color
   GL_POLYGON glBegin
     0    0.577 glVertex2d
     0.5 -0.289 glVertex2d
@@ -92,7 +92,7 @@ VAR: threshold
   glEnd ;
 
 : square ( -- )
-  self> set-color
+  self> gl-color
   GL_POLYGON glBegin
     -0.5  0.5 glVertex2d
      0.5  0.5 glVertex2d
@@ -192,7 +192,7 @@ SYMBOL: dlist
 
   set-initial-color
 
-  self> set-color
+  self> gl-color
 
   start-shape> call
       
diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor
index 6c553147a1..7bd6eb7fbc 100644
--- a/extra/jamshred/gl/gl.factor
+++ b/extra/jamshred/gl/gl.factor
@@ -1,6 +1,9 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences float-arrays ;
+USING: accessors alien.c-types jamshred.game jamshred.oint
+jamshred.player jamshred.tunnel kernel math math.constants
+math.functions math.vectors opengl opengl.gl opengl.glu
+opengl.demo-support sequences float-arrays ;
 IN: jamshred.gl
 
 : min-vertices 6 ; inline
@@ -43,7 +46,7 @@ IN: jamshred.gl
     dup [ / pi 2 * * ] curry map ;
 
 : draw-segment-vertex ( segment theta -- )
-    over color>> set-color segment-vertex-and-normal
+    over color>> gl-color segment-vertex-and-normal
     gl-normal gl-vertex ;
 
 : draw-vertex-pair ( theta next-segment segment -- )
diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor
index 07f7b74265..40e12a97c9 100644
--- a/extra/maze/maze.factor
+++ b/extra/maze/maze.factor
@@ -1,7 +1,7 @@
 ! From http://www.ffconsultancy.com/ocaml/maze/index.html
 USING: sequences namespaces math math.vectors opengl opengl.gl
-arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
-math.order math.geometry.rect ;
+opengl.demo-support arrays kernel random ui ui.gadgets
+ui.gadgets.canvas ui.render math.order math.geometry.rect ;
 IN: maze
 
 : line-width 8 ;
@@ -41,6 +41,7 @@ SYMBOL: visited
     ] if ;
 
 : draw-maze ( n -- )
+    -0.5 0.5 0 glTranslated
     line-width 2 - glLineWidth
     line-width 2 - glPointSize
     1.0 1.0 1.0 1.0 glColor4d
diff --git a/extra/nehe/2/2.factor b/extra/nehe/2/2.factor
index d9560c92f6..29d4ccffc1 100644
--- a/extra/nehe/2/2.factor
+++ b/extra/nehe/2/2.factor
@@ -1,5 +1,5 @@
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render ;
 IN: nehe.2
 
 TUPLE: nehe2-gadget < gadget ;
diff --git a/extra/nehe/3/3.factor b/extra/nehe/3/3.factor
index 8a2149e370..75f2e573cc 100644
--- a/extra/nehe/3/3.factor
+++ b/extra/nehe/3/3.factor
@@ -1,5 +1,5 @@
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render ;
 IN: nehe.3
 
 TUPLE: nehe3-gadget < gadget ;
diff --git a/extra/nehe/4/4.factor b/extra/nehe/4/4.factor
index 5a7988c934..4c1545b4ae 100644
--- a/extra/nehe/4/4.factor
+++ b/extra/nehe/4/4.factor
@@ -1,5 +1,5 @@
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render threads accessors ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render threads accessors ;
 IN: nehe.4
 
 TUPLE: nehe4-gadget < gadget rtri rquad thread quit? ;
diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor
index deaba97c7c..59170ff964 100755
--- a/extra/nehe/5/5.factor
+++ b/extra/nehe/5/5.factor
@@ -1,5 +1,5 @@
-USING: arrays kernel math opengl opengl.gl opengl.glu ui
-ui.gadgets ui.render threads accessors ;
+USING: arrays kernel math opengl opengl.gl opengl.glu
+opengl.demo-support ui ui.gadgets ui.render threads accessors ;
 IN: nehe.5
 
 TUPLE: nehe5-gadget < gadget rtri rquad thread quit? ;
diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor
index 2bf2abae95..cd781508a7 100755
--- a/extra/opengl/demo-support/demo-support.factor
+++ b/extra/opengl/demo-support/demo-support.factor
@@ -1,6 +1,6 @@
-USING: arrays kernel math math.functions
-math.order math.vectors namespaces opengl opengl.gl sequences ui
-ui.gadgets ui.gestures ui.render accessors ;
+USING: arrays kernel math math.functions math.order math.vectors
+namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
+ui.render accessors combinators ;
 IN: opengl.demo-support
 
 : FOV 2.0 sqrt 1+ ; inline
@@ -74,6 +74,26 @@ M: demo-gadget pref-dim* ( gadget -- dim )
 : drag-yaw-pitch ( -- yaw pitch )
     last-drag-rel MOUSE-MOTION-SCALE v*n first2 ;
 
+: gl-vertex ( point -- )
+    dup length {
+        { 2 [ first2 glVertex2d ] }
+        { 3 [ first3 glVertex3d ] }
+        { 4 [ first4 glVertex4d ] }
+    } case ;
+
+: gl-normal ( normal -- ) first3 glNormal3d ;
+
+: do-state ( mode quot -- )
+    swap glBegin call glEnd ; inline
+
+: rect-vertices ( lower-left upper-right -- )
+    GL_QUADS [
+        over first2 glVertex2d
+        dup first pick second glVertex2d
+        dup first2 glVertex2d
+        swap first swap second glVertex2d
+    ] do-state ;
+
 demo-gadget H{
     { T{ key-down f f "LEFT"  } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] }
     { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP     swap yaw-demo-gadget ] }
diff --git a/extra/opengl/gadgets/gadgets.factor b/extra/opengl/gadgets/gadgets.factor
index cfedf32079..758bfe280e 100644
--- a/extra/opengl/gadgets/gadgets.factor
+++ b/extra/opengl/gadgets/gadgets.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Matthew Willis.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: locals math.functions math namespaces
-opengl.gl accessors kernel opengl ui.gadgets
+opengl.gl opengl.demo-support accessors kernel opengl ui.gadgets
 fry assocs
 destructors sequences ui.render colors ;
 IN: opengl.gadgets
diff --git a/extra/processing/shapes/shapes.factor b/extra/processing/shapes/shapes.factor
index f577010544..a530be64fa 100644
--- a/extra/processing/shapes/shapes.factor
+++ b/extra/processing/shapes/shapes.factor
@@ -2,7 +2,7 @@
 USING: kernel namespaces arrays sequences grouping
        alien.c-types
        math math.vectors math.geometry.rect
-       opengl.gl opengl.glu opengl generalizations vars
+       opengl.gl opengl.glu opengl.demo-support opengl generalizations vars
        combinators.cleave colors ;
 
 IN: processing.shapes
@@ -19,13 +19,13 @@ T{ rgba f 1 1 1 1 } fill-color   set-global
 
 : fill-mode ( -- )
   GL_FRONT_AND_BACK GL_FILL glPolygonMode
-  fill-color> set-color ;
+  fill-color> gl-color ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : stroke-mode ( -- )
   GL_FRONT_AND_BACK GL_LINE glPolygonMode
-  stroke-color> set-color ;
+  stroke-color> gl-color ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -105,8 +105,8 @@ T{ rgba f 1 1 1 1 } fill-color   set-global
 
 : ellipse ( center dim -- )
   GL_FRONT_AND_BACK GL_FILL glPolygonMode
-  [ stroke-color> set-color                                 gl-ellipse ]
-  [ fill-color> set-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
+  [ stroke-color> gl-color                                 gl-ellipse ]
+  [ fill-color> gl-color gl-get-line-width 2 * dup 2array v- gl-ellipse ] 2bi ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor
index f119956db6..06468b8751 100755
--- a/extra/spheres/spheres.factor
+++ b/extra/spheres/spheres.factor
@@ -1,6 +1,7 @@
-USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers
-opengl multiline ui.gadgets accessors sequences ui.render ui math locals
-arrays generalizations combinators opengl.capabilities ui.gadgets.worlds ;
+USING: kernel opengl opengl.demo-support opengl.gl
+opengl.shaders opengl.framebuffers opengl.capabilities multiline
+ui.gadgets accessors sequences ui.render ui math locals arrays
+generalizations combinators ui.gadgets.worlds ;
 IN: spheres
 
 STRING: plane-vertex-shader
diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor
index 423a68cf0d..07865f38e0 100644
--- a/extra/springies/ui/ui.factor
+++ b/extra/springies/ui/ui.factor
@@ -25,7 +25,7 @@ IN: springies.ui
 
 ! : display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
 
-: display ( -- ) set-projection black set-color draw-nodes draw-springs ;
+: display ( -- ) set-projection black gl-color draw-nodes draw-springs ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
diff --git a/extra/tetris/gl/gl.factor b/extra/tetris/gl/gl.factor
index d47f027293..a9b00ffb7c 100644
--- a/extra/tetris/gl/gl.factor
+++ b/extra/tetris/gl/gl.factor
@@ -6,22 +6,22 @@ IN: tetris.gl
 #! OpenGL rendering for tetris
 
 : draw-block ( block -- )
-    dup { 1 1 } v+ gl-fill-rect ;
+    [ { 1 1 } gl-fill-rect ] with-translation ;
 
 : draw-piece-blocks ( piece -- )
     piece-blocks [ draw-block ] each ;
 
 : draw-piece ( piece -- )
-    dup tetromino>> colour>> set-color draw-piece-blocks ;
+    dup tetromino>> colour>> gl-color draw-piece-blocks ;
 
 : draw-next-piece ( piece -- )
     dup tetromino>> colour>>
-    clone 0.2 >>alpha set-color draw-piece-blocks ;
+    clone 0.2 >>alpha gl-color draw-piece-blocks ;
 
 ! TODO: move implementation specific stuff into tetris-board
 : (draw-row) ( x y row -- )
     >r over r> nth dup
-    [ set-color 2array draw-block ] [ 3drop ] if ;
+    [ gl-color 2array draw-block ] [ 3drop ] if ;
 
 : draw-row ( y row -- )
     dup length -rot [ (draw-row) ] 2curry each ;

From 43335d9c36e4b74e7e4dd30e0afd69aa07cf5b61 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 08:30:14 -0600
Subject: [PATCH 285/318] Intervals now use a special singleton for the full
 interval to eliminate FP math in the common case; fix a bug in value-info<=

---
 .../tree/propagation/info/info-tests.factor   |  4 ++
 .../tree/propagation/info/info.factor         |  6 +--
 basis/math/intervals/intervals-tests.factor   | 36 +++++++++-----
 basis/math/intervals/intervals.factor         | 48 ++++++++++++-------
 4 files changed, 61 insertions(+), 33 deletions(-)

diff --git a/basis/compiler/tree/propagation/info/info-tests.factor b/basis/compiler/tree/propagation/info/info-tests.factor
index 24f4ca59dc..2c3314994b 100644
--- a/basis/compiler/tree/propagation/info/info-tests.factor
+++ b/basis/compiler/tree/propagation/info/info-tests.factor
@@ -70,3 +70,7 @@ TUPLE: test-tuple { x read-only } ;
     f f 3 <literal-info> 3array test-tuple <tuple-info> dup
     object-info value-info-intersect =
 ] unit-test
+
+[ t ] [
+    null-info 3 <literal-info> value-info<=
+] unit-test
diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index d1d8189f7a..11111fd11e 100644
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -34,7 +34,7 @@ slots ;
 
 : null-info T{ value-info f null empty-interval } ; inline
 
-: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline
+: object-info T{ value-info f object full-interval } ; inline
 
 : class-interval ( class -- interval )
     dup real class<=
@@ -43,7 +43,7 @@ slots ;
 : interval>literal ( class interval -- literal literal? )
     #! If interval has zero length and the class is sufficiently
     #! precise, we can turn it into a literal
-    dup empty-interval eq? [
+    dup special-interval? [
         2drop f f
     ] [
         dup from>> first {
@@ -243,7 +243,7 @@ DEFER: (value-info-union)
 : literals<= ( info1 info2 -- ? )
     {
         { [ dup literal?>> not ] [ 2drop t ] }
-        { [ over literal?>> not ] [ 2drop f ] }
+        { [ over literal?>> not ] [ drop class>> null-class? ] }
         [ [ literal>> ] bi@ eql? ]
     } cond ;
 
diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor
index 0fdcb51291..8c29171a57 100644
--- a/basis/math/intervals/intervals-tests.factor
+++ b/basis/math/intervals/intervals-tests.factor
@@ -95,6 +95,10 @@ IN: math.intervals.tests
 
 [ empty-interval ] [ 0 5 (a,b] empty-interval interval-intersect ] unit-test
 
+[ t ] [
+    0 1 (a,b) full-interval interval-intersect 0 1 (a,b) =
+] unit-test
+
 [ t ] [
     empty-interval empty-interval interval-subset?
 ] unit-test
@@ -209,22 +213,28 @@ IN: math.intervals.tests
 
 ! Interval random tester
 : random-element ( interval -- n )
-    dup to>> first over from>> first tuck - random +
-    2dup swap interval-contains? [
-        nip
+    dup full-interval eq? [
+        drop 32 random-bits 31 2^ -
     ] [
-        drop random-element
+        dup to>> first over from>> first tuck - random +
+        2dup swap interval-contains? [
+            nip
+        ] [
+            drop random-element
+        ] if
     ] if ;
 
 : random-interval ( -- interval )
-    2000 random 1000 - dup 2 1000 random + +
-    1 random zero? [ [ neg ] bi@ swap ] when
-    4 random {
-        { 0 [ [a,b] ] }
-        { 1 [ [a,b) ] }
-        { 2 [ (a,b) ] }
-        { 3 [ (a,b] ] }
-    } case ;
+    10 random 0 = [ full-interval ] [
+        2000 random 1000 - dup 2 1000 random + +
+        1 random zero? [ [ neg ] bi@ swap ] when
+        4 random {
+            { 0 [ [a,b] ] }
+            { 1 [ [a,b) ] }
+            { 2 [ (a,b) ] }
+            { 3 [ (a,b] ] }
+        } case
+    ] if ;
 
 : random-unary-op ( -- pair )
     {
@@ -263,7 +273,7 @@ IN: math.intervals.tests
         { bitand interval-bitand }
         { bitor interval-bitor }
         { bitxor interval-bitxor }
-        { shift interval-shift }
+        ! { shift interval-shift }
         { min interval-min }
         { max interval-max }
     }
diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor
index 33430e83c3..54ee0ac894 100644
--- a/basis/math/intervals/intervals.factor
+++ b/basis/math/intervals/intervals.factor
@@ -7,6 +7,8 @@ IN: math.intervals
 
 SYMBOL: empty-interval
 
+SYMBOL: full-interval
+
 TUPLE: interval { from read-only } { to read-only } ;
 
 : <interval> ( from to -- int )
@@ -46,8 +48,7 @@ TUPLE: interval { from read-only } { to read-only } ;
 
 : (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
 
-: [-inf,inf] ( -- interval )
-    T{ interval f { -1./0. t } { 1./0. t } } ; inline
+: [-inf,inf] ( -- interval ) full-interval ; inline
 
 : compare-endpoints ( p1 p2 quot -- ? )
     >r over first over first r> call [
@@ -99,8 +100,10 @@ TUPLE: interval { from read-only } { to read-only } ;
 
 : do-empty-interval ( i1 i2 quot -- i3 )
     {
-        { [ pick empty-interval eq? ] [ drop drop ] }
+        { [ pick empty-interval eq? ] [ 2drop ] }
         { [ over empty-interval eq? ] [ drop nip ] }
+        { [ pick full-interval eq? ] [ 2drop ] }
+        { [ over full-interval eq? ] [ drop nip ] }
         [ call ]
     } cond ; inline
 
@@ -112,8 +115,10 @@ TUPLE: interval { from read-only } { to read-only } ;
 
 : interval-intersect ( i1 i2 -- i3 )
     {
-        { [ dup empty-interval eq? ] [ nip ] }
         { [ over empty-interval eq? ] [ drop ] }
+        { [ dup empty-interval eq? ] [ nip ] }
+        { [ over full-interval eq? ] [ nip ] }
+        { [ dup full-interval eq? ] [ drop ] }
         [
             [ interval>points ] bi@ swapd
             [ [ swap endpoint< ] most ]
@@ -127,8 +132,10 @@ TUPLE: interval { from read-only } { to read-only } ;
 
 : interval-union ( i1 i2 -- i3 )
     {
-        { [ dup empty-interval eq? ] [ drop ] }
         { [ over empty-interval eq? ] [ nip ] }
+        { [ dup empty-interval eq? ] [ drop ] }
+        { [ over full-interval eq? ] [ drop ] }
+        { [ dup full-interval eq? ] [ nip ] }
         [ [ interval>points 2array ] bi@ append points>interval ]
     } cond ;
 
@@ -137,9 +144,11 @@ TUPLE: interval { from read-only } { to read-only } ;
 
 : interval-contains? ( x int -- ? )
     dup empty-interval eq? [ 2drop f ] [
-        [ from>> first2 [ >= ] [ > ] if ]
-        [ to>>   first2 [ <= ] [ < ] if ]
-        2bi and
+        dup full-interval eq? [ 2drop t ] [
+            [ from>> first2 [ >= ] [ > ] if ]
+            [ to>>   first2 [ <= ] [ < ] if ]
+            2bi and
+        ] if
     ] if ;
 
 : interval-zero? ( int -- ? )
@@ -160,8 +169,11 @@ TUPLE: interval { from read-only } { to read-only } ;
 
 : interval-sq ( i1 -- i2 ) dup interval* ;
 
+: special-interval? ( interval -- ? )
+    { empty-interval full-interval } memq? ;
+
 : interval-singleton? ( int -- ? )
-    dup empty-interval eq? [
+    dup special-interval? [
         drop f
     ] [
         interval>points
@@ -173,6 +185,7 @@ TUPLE: interval { from read-only } { to read-only } ;
 : interval-length ( int -- n )
     {
         { [ dup empty-interval eq? ] [ drop 0 ] }
+        { [ dup full-interval eq? ] [ drop 1/0. ] }
         [ interval>points [ first ] bi@ swap - ]
     } cond ;
 
@@ -211,7 +224,7 @@ TUPLE: interval { from read-only } { to read-only } ;
     [ [ interval-closure ] bi@ [ min ] interval-op ] do-empty-interval ;
 
 : interval-interior ( i1 -- i2 )
-    dup empty-interval eq? [
+    dup special-interval? [
         interval>points [ first ] bi@ (a,b)
     ] unless ;
 
@@ -249,6 +262,7 @@ TUPLE: interval { from read-only } { to read-only } ;
 : interval-abs ( i1 -- i2 )
     {
         { [ dup empty-interval eq? ] [ ] }
+        { [ dup full-interval eq? ] [ drop 0 [a,inf] ] }
         { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
         [ (interval-abs) points>interval ]
     } cond ;
@@ -292,7 +306,7 @@ SYMBOL: incomparable
 
 : interval< ( i1 i2 -- ? )
     {
-        { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
+        { [ 2dup [ special-interval? ] either? ] [ incomparable ] }
         { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
         { [ 2dup left-endpoint-< ] [ f ] }
         { [ 2dup right-endpoint-< ] [ f ] }
@@ -307,7 +321,7 @@ SYMBOL: incomparable
 
 : interval<= ( i1 i2 -- ? )
     {
-        { [ 2dup [ empty-interval eq? ] either? ] [ incomparable ] }
+        { [ 2dup [ special-interval? ] either? ] [ incomparable ] }
         { [ 2dup interval-intersect empty-interval eq? ] [ (interval<) ] }
         { [ 2dup right-endpoint-<= ] [ t ] }
         [ incomparable ]
@@ -360,27 +374,27 @@ SYMBOL: incomparable
     interval-bitor ;
 
 : assume< ( i1 i2 -- i3 )
-    dup empty-interval eq? [ drop ] [
+    dup special-interval? [ drop ] [
         to>> first [-inf,a) interval-intersect
     ] if ;
 
 : assume<= ( i1 i2 -- i3 )
-    dup empty-interval eq? [ drop ] [
+    dup special-interval? [ drop ] [
         to>> first [-inf,a] interval-intersect
     ] if ;
 
 : assume> ( i1 i2 -- i3 )
-    dup empty-interval eq? [ drop ] [
+    dup special-interval? [ drop ] [
         from>> first (a,inf] interval-intersect
     ] if ;
 
 : assume>= ( i1 i2 -- i3 )
-    dup empty-interval eq? [ drop ] [
+    dup special-interval? [ drop ] [
         from>> first [a,inf] interval-intersect
     ] if ;
 
 : integral-closure ( i1 -- i2 )
-    dup empty-interval eq? [
+    dup special-interval? [
         [ from>> first2 [ 1+ ] unless ]
         [ to>> first2 [ 1- ] unless ]
         bi [a,b]

From 7f9fbdaa4e9c02f4f07bf36a472d8f7616c3a219 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 08:38:03 -0600
Subject: [PATCH 286/318] cleanup pass didn't properly handle conditionals
 where both branches were dead

---
 basis/compiler/tree/cleanup/cleanup-tests.factor | 5 +++++
 basis/compiler/tree/cleanup/cleanup.factor       | 2 +-
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor
index b77a27800f..13847e55a2 100644
--- a/basis/compiler/tree/cleanup/cleanup-tests.factor
+++ b/basis/compiler/tree/cleanup/cleanup-tests.factor
@@ -500,3 +500,8 @@ cell-bits 32 = [
     [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
     [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
 ] unit-test
+
+[ ] [
+    [ { null } declare [ 1 ] [ 2 ] if ]
+    build-tree normalize propagate cleanup check-nodes
+] unit-test
diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index 4ca058b2e3..becac01cd5 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -102,7 +102,7 @@ M: #declare cleanup* drop f ;
     #! If only one branch is live we don't need to branch at
     #! all; just drop the condition value.
     dup live-children sift dup length {
-        { 0 [ 2drop f ] }
+        { 0 [ drop in-d>> #drop ] }
         { 1 [ first swap in-d>> #drop prefix ] }
         [ 2drop ]
     } case ;

From 5f4b2470722b3d4a709aba84be0d7178c781713f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 08:49:00 -0600
Subject: [PATCH 287/318] Propagation pass now uses a stack of hashtables for
 predicated constraints instead of cloning a hashtable. New strategy for
 recursive propagation; now converges with fewer iterations. ~15 sec bootstrap
 time improvement

---
 .../tree/propagation/branches/branches.factor |  4 +-
 .../constraints/constraints.factor            |  6 +--
 .../tree/propagation/info/info.factor         | 10 +++--
 .../tree/propagation/propagation-tests.factor |  4 +-
 .../tree/propagation/propagation.factor       |  6 +--
 .../propagation/recursive/recursive.factor    | 41 ++++++++++++++-----
 6 files changed, 48 insertions(+), 23 deletions(-)

diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor
index c76217f8ae..424cd8a01c 100644
--- a/basis/compiler/tree/propagation/branches/branches.factor
+++ b/basis/compiler/tree/propagation/branches/branches.factor
@@ -40,8 +40,8 @@ M: #dispatch live-branches
 SYMBOL: infer-children-data
 
 : copy-value-info ( -- )
-    value-infos [ clone ] change
-    constraints [ clone ] change ;
+    value-infos [ H{ } clone suffix ] change
+    constraints [ H{ } clone suffix ] change ;
 
 : no-value-info ( -- )
     value-infos off
diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor
index cfdf7f5169..2652547aad 100644
--- a/basis/compiler/tree/propagation/constraints/constraints.factor
+++ b/basis/compiler/tree/propagation/constraints/constraints.factor
@@ -32,7 +32,7 @@ TUPLE: true-constraint value ;
 
 M: true-constraint assume*
     [ \ f class-not <class-info> swap value>> refine-value-info ]
-    [ constraints get at [ assume ] when* ]
+    [ constraints get assoc-stack [ assume ] when* ]
     bi ;
 
 M: true-constraint satisfied?
@@ -44,7 +44,7 @@ TUPLE: false-constraint value ;
 
 M: false-constraint assume*
     [ \ f <class-info> swap value>> refine-value-info ]
-    [ constraints get at [ assume ] when* ]
+    [ constraints get assoc-stack [ assume ] when* ]
     bi ;
 
 M: false-constraint satisfied?
@@ -83,7 +83,7 @@ TUPLE: implication p q ;
 C: --> implication
 
 : assume-implication ( p q -- )
-    [ constraints get [ swap suffix ] change-at ]
+    [ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
 
 M: implication assume*
diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 11111fd11e..e89a9c6211 100644
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -262,17 +262,19 @@ DEFER: (value-info-union)
         ]
     } cond ;
 
-! Current value --> info mapping
+! Assoc stack of current value --> info mapping
 SYMBOL: value-infos
 
 : value-info ( value -- info )
-    resolve-copy value-infos get at null-info or ;
+    resolve-copy value-infos get assoc-stack null-info or ;
 
 : set-value-info ( info value -- )
-    resolve-copy value-infos get set-at ;
+    resolve-copy value-infos get peek set-at ;
 
 : refine-value-info ( info value -- )
-    resolve-copy value-infos get [ value-info-intersect ] change-at ;
+    resolve-copy value-infos get
+    [ assoc-stack value-info-intersect ] 2keep
+    peek set-at ;
 
 : value-literal ( value -- obj ? )
     value-info >literal< ;
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 101320f92c..760ff167aa 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -8,7 +8,7 @@ math.functions math.private strings layouts
 compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
-float-arrays system ;
+float-arrays system sorting ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -592,6 +592,8 @@ MIXIN: empty-mixin
 
 [ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
 
+[ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test
diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor
index d82ebed433..b9822d2c6b 100644
--- a/basis/compiler/tree/propagation/propagation.factor
+++ b/basis/compiler/tree/propagation/propagation.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences namespaces hashtables
+USING: accessors kernel sequences namespaces hashtables arrays
 compiler.tree
 compiler.tree.propagation.copy
 compiler.tree.propagation.info
@@ -17,7 +17,7 @@ IN: compiler.tree.propagation
 
 : propagate ( node -- node )
     H{ } clone copies set
-    H{ } clone constraints set
-    H{ } clone value-infos set
+    H{ } clone 1array value-infos set
+    H{ } clone 1array constraints set
     dup count-nodes
     dup (propagate) ;
diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index 53dce813a3..70cda11d3d 100644
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -17,9 +17,12 @@ IN: compiler.tree.propagation.recursive
     [ value-info<= ] 2all?
     [ drop ] [ label>> f >>fixed-point drop ] if ;
 
+: latest-input-infos ( node -- infos )
+    in-d>> [ value-info ] map ;
+
 : recursive-stacks ( #enter-recursive -- stacks initial )
     [ label>> calls>> [ node-input-infos ] map flip ]
-    [ in-d>> [ value-info ] map ] bi ;
+    [ latest-input-infos ] bi ;
 
 : generalize-counter-interval ( interval initial-interval -- interval' )
     {
@@ -46,14 +49,13 @@ IN: compiler.tree.propagation.recursive
     ] if ;
 
 : propagate-recursive-phi ( #enter-recursive -- )
-    [ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
-    [ node-output-infos check-fixed-point ]
-    [ out-d>> set-value-infos drop ]
-    3bi ;
+    [ recursive-stacks unify-recursive-stacks ] keep
+    out-d>> set-value-infos ;
 
 M: #recursive propagate-around ( #recursive -- )
+    constraints [ H{ } clone suffix ] change
     [
-        constraints [ clone ] change
+        constraints [ but-last H{ } clone suffix ] change
 
         child>>
         [ first compute-copy-equiv ]
@@ -62,6 +64,9 @@ M: #recursive propagate-around ( #recursive -- )
         tri
     ] until-fixed-point ;
 
+: recursive-phi-infos ( node -- infos )
+    label>> enter-recursive>> node-output-infos ;
+
 : generalize-return-interval ( info -- info' )
     dup [ literal?>> ] [ class>> null-class? ] bi or
     [ clone [-inf,inf] >>interval ] unless ;
@@ -70,12 +75,22 @@ M: #recursive propagate-around ( #recursive -- )
     [ generalize-return-interval ] map ;
 
 : return-infos ( node -- infos )
-    label>> [ return>> node-input-infos ] [ loop?>> ] bi
-    [ generalize-return ] unless ;
+    label>> return>> node-input-infos generalize-return ;
+
+: save-return-infos ( node infos -- )
+    swap out-d>> set-value-infos ;
 
 M: #call-recursive propagate-before ( #call-recursive -- )
-    [ ] [ return-infos ] [ node-output-infos ] tri
-    [ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;
+    [
+        [ ] [ latest-input-infos ] [ recursive-phi-infos ] tri
+        check-fixed-point
+    ]
+    [
+        dup label>> loop?>> [ drop ] [
+            [ ] [ return-infos ] [ node-output-infos ] tri
+            [ check-fixed-point ] [ drop save-return-infos ] 3bi
+        ] if
+    ] bi ;
 
 M: #call-recursive annotate-node
     dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
@@ -83,5 +98,11 @@ M: #call-recursive annotate-node
 M: #enter-recursive annotate-node
     dup out-d>> (annotate-node) ;
 
+M: #return-recursive propagate-before ( #return-recursive -- )
+    dup label>> loop?>> [ drop ] [
+        [ ] [ latest-input-infos ] [ node-input-infos ] tri
+        check-fixed-point
+    ] if ;
+
 M: #return-recursive annotate-node
     dup in-d>> (annotate-node) ;

From 792df37431152ff3e74db110d29f5ff133e5a1d8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 08:50:30 -0600
Subject: [PATCH 288/318] Update unit test

---
 .../tree/escape-analysis/escape-analysis-tests.factor         | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 4ed194e81d..9a226b954f 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -8,6 +8,7 @@ math.private kernel tools.test accessors slots.private
 quotations.private prettyprint classes.tuple.private classes
 classes.tuple namespaces
 compiler.tree.propagation.info stack-checker.errors
+compiler.tree.checker
 kernel.private ;
 
 \ escape-analysis must-infer
@@ -34,6 +35,7 @@ M: node count-unboxed-allocations* drop ;
     propagate
     cleanup
     escape-analysis
+    dup check-nodes
     0 swap [ count-unboxed-allocations* ] each-node ;
 
 [ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
@@ -307,7 +309,7 @@ C: <ro-box> ro-box
 : bleach-node ( quot: ( node -- ) -- )
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
 
-[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
+[ 3 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
 
 [ 0 ] [
     [ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]

From e49ee006d1a5a1843e2ea59ff209c793232b676c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 08:50:48 -0600
Subject: [PATCH 289/318] Fix loop combinator docs

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

diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index 61e10a9c00..71f3980a6c 100644
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -644,7 +644,7 @@ $nl
 HELP: loop
 { $values
      { "pred" quotation } }
-{ $description "Calls the quotation repeatedly until the output is true." }
+     { $description "Calls the quotation repeatedly until it outputs " { $link f } "." }
 { $examples "Loop until we hit a zero:"
     { $unchecked-example "USING: kernel random math io ; "
     " [ \"hi\" write bl 10 random zero? not ] loop"

From d50f4275d4fb1d769ce03c87e522f5780e391207 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 08:53:11 -0600
Subject: [PATCH 290/318] Fix help lint

---
 basis/opengl/opengl-docs.factor    | 8 ++++----
 basis/ui/render/render-docs.factor | 2 +-
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/basis/opengl/opengl-docs.factor b/basis/opengl/opengl-docs.factor
index 6752c5126c..b1ea89178b 100644
--- a/basis/opengl/opengl-docs.factor
+++ b/basis/opengl/opengl-docs.factor
@@ -22,12 +22,12 @@ HELP: gl-line
 { $description "Draws a line between two points." } ;
 
 HELP: gl-fill-rect
-{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
-{ $description "Draws a filled rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ;
+{ $values { "dim" "a pair of integers" } }
+{ $description "Draws a filled rectangle with the top-left corner at the origin and the given dimensions." } ;
 
 HELP: gl-rect
-{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
-{ $description "Draws the outline of a rectangle with top-left corner " { $snippet "loc" } " and bottom-right corner " { $snippet "ext" } "." } ;
+{ $values { "dim" "a pair of integers" } }
+{ $description "Draws the outline of a rectangle with the top-left corner at the origin and the given dimensions." } ;
 
 HELP: gen-texture
 { $values { "id" integer } }
diff --git a/basis/ui/render/render-docs.factor b/basis/ui/render/render-docs.factor
index fc16ed9345..294ee1c63d 100644
--- a/basis/ui/render/render-docs.factor
+++ b/basis/ui/render/render-docs.factor
@@ -52,7 +52,7 @@ HELP: polygon
 } ;
 
 HELP: <polygon>
-{ $values { "color" "a color specifier" } { "points" "a sequence of points" } }
+{ $values { "color" "a color specifier" } { "points" "a sequence of points" } { "polygon" polygon } }
 { $description "Creates a new instance of " { $link polygon } "." } ;
 
 HELP: <polygon-gadget>

From f04b32ea029346d4b0b0cd5d624ed882d9a9e414 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 09:10:33 -0600
Subject: [PATCH 291/318] Remove duplicated logic

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

diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index 70cda11d3d..7f10f87016 100644
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -80,16 +80,19 @@ M: #recursive propagate-around ( #recursive -- )
 : save-return-infos ( node infos -- )
     swap out-d>> set-value-infos ;
 
+: unless-loop ( node quot -- )
+    [ dup label>> loop?>> [ drop ] ] dip if ; inline
+
 M: #call-recursive propagate-before ( #call-recursive -- )
     [
         [ ] [ latest-input-infos ] [ recursive-phi-infos ] tri
         check-fixed-point
     ]
     [
-        dup label>> loop?>> [ drop ] [
+        [
             [ ] [ return-infos ] [ node-output-infos ] tri
             [ check-fixed-point ] [ drop save-return-infos ] 3bi
-        ] if
+        ] unless-loop
     ] bi ;
 
 M: #call-recursive annotate-node
@@ -99,10 +102,10 @@ M: #enter-recursive annotate-node
     dup out-d>> (annotate-node) ;
 
 M: #return-recursive propagate-before ( #return-recursive -- )
-    dup label>> loop?>> [ drop ] [
+    [
         [ ] [ latest-input-infos ] [ node-input-infos ] tri
         check-fixed-point
-    ] if ;
+    ] unless-loop ;
 
 M: #return-recursive annotate-node
     dup in-d>> (annotate-node) ;

From 2c4e3ce9dc521699ca9a20c0bec135f491f1412c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.(none)>
Date: Tue, 11 Nov 2008 10:19:42 -0600
Subject: [PATCH 292/318] check that the makefile exists and stop if it doesnt

---
 build-support/factor.sh | 20 ++++++++++++++++----
 1 file changed, 16 insertions(+), 4 deletions(-)

diff --git a/build-support/factor.sh b/build-support/factor.sh
index bd234afb5f..8d75b8cff2 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -176,7 +176,7 @@ find_os() {
         *FreeBSD*) OS=freebsd;;
         *OpenBSD*) OS=openbsd;;
         *DragonFly*) OS=dragonflybsd;;
-    	SunOS) OS=solaris;;
+        SunOS) OS=solaris;;
     esac
 }
 
@@ -264,7 +264,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 5
     fi
 }
@@ -339,9 +339,21 @@ cd_factor() {
     check_ret cd
 }
 
+check_makefile_exists() {
+    if [[ ! -e "Makefile" ]] ; then
+        echo ""
+        echo "***Makefile not found***"
+        echo "You are likely in the wrong directory."
+        echo "Run this script from your factor directory:"
+        echo "     ./build-support/factor.sh"
+        exit 6
+    fi
+}
+
 invoke_make() {
-   $MAKE $MAKE_OPTS $*
-   check_ret $MAKE
+    check_makefile_exists
+    $MAKE $MAKE_OPTS $*
+    check_ret $MAKE
 }
 
 make_clean() {

From 1d630b6cf2a872c42291920b5c52bb186dc7e139 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 10:51:15 -0600
Subject: [PATCH 293/318] Minor documentation fixes

---
 basis/help/tutorial/tutorial.factor           | 49 ++++++++-----------
 basis/io/encodings/string/string-docs.factor  |  3 +-
 .../servers/connection/connection-docs.factor |  9 +++-
 basis/locals/locals-docs.factor               | 36 +++++++++++++-
 basis/prettyprint/prettyprint-docs.factor     | 23 +++++++--
 basis/tools/crossref/crossref-docs.factor     |  4 +-
 core/generic/generic-docs.factor              |  5 +-
 core/io/encodings/encodings-docs.factor       |  4 +-
 core/namespaces/namespaces-docs.factor        |  5 +-
 core/sequences/sequences-docs.factor          |  3 +-
 10 files changed, 97 insertions(+), 44 deletions(-)

diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor
index cafa758c7e..afa16bbf8a 100644
--- a/basis/help/tutorial/tutorial.factor
+++ b/basis/help/tutorial/tutorial.factor
@@ -1,29 +1,24 @@
 USING: help.markup help.syntax ui.commands ui.operations
 ui.tools.search ui.tools.workspace editors vocabs.loader
 kernel sequences prettyprint tools.test tools.vocabs strings
-unicode.categories unicode.case ;
+unicode.categories unicode.case ui.tools.browser ;
 IN: help.tutorial
 
 ARTICLE: "first-program-start" "Creating a vocabulary for your first program"
 "Factor source code is organized into " { $link "vocabularies" } ". Before we can write our first program, we must create a vocabulary for it."
 $nl
-"Start by asking Factor for the path to your ``work'' directory, where you will place your own code:"
+"Start by loading the scaffold tool:"
+{ $code "USE: tools.scaffold" }
+"Then, ask the scaffold tool to create a new vocabulary named " { $snippet "palindrome" } ":"
+{ $code "\"resource:work\" \"palindrome\" scaffold-vocab" }
+"If you look at the output, you will see that a few files were created in your ``work'' directory. The following phrase will print the full path of your work directory:"
 { $code "\"work\" resource-path ." }
-"Open the work directory in your file manager, and create a subdirectory named " { $snippet "palindrome" } ". Inside this directory, create a file named " { $snippet "palindrome.factor" } " using your favorite text editor. Leave the file empty for now."
+"Open the work directory in your file manager, and open the subdirectory named " { $snippet "palindrome" } ". Inside this subdirectory you will see a file named " { $snippet "palindrome.factor" } ". We will be editing this file."
 $nl
-"Inside the Factor listener, type"
-{ $code "USE: palindrome" }
-"The source file should now load. Since it is empty, it does nothing. If you get an error message, make sure you created the directory and the file in the right place and gave them the right names."
-$nl
-"Now, we will start filling out this source file. Go back to your editor, and type:"
-{ $code
-    "! Copyright (C) 2008 <your name here>"
-    "! See http://factorcode.org/license.txt for BSD license."
-}
-"This is the standard header for Factor source files; it consists of two " { $link "syntax-comments" } "."
-$nl
-"Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
+"Notice that the file ends with an " { $link POSTPONE: IN: } " form telling Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:"
 { $code "IN: palindrome" }
+"We will add new definitions after the " { $link POSTPONE: IN: } " form."
+$nl
 "You are now ready to go on to the next section: " { $link "first-program-logic" } "." ;
 
 ARTICLE: "first-program-logic" "Writing some logic in your first program"
@@ -43,20 +38,16 @@ $nl
 $nl
 "When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
 $nl
-"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary by entering the following in the listener:"
-{ $code "\\ dup see" }
-"This shows the definition of " { $link dup } ", along with an " { $link POSTPONE: IN: } " form."
+"To add the word to the search path, first convince yourself that this word is in the " { $vocab-link "kernel" } " vocabulary. Enter " { $snippet "dup" } " in the listener's input area, and press " { $operation com-follow } ". This will open the documentation browser tool, viewing the help for the " { $link dup } " word. One of the subheadings in the help article will mention the word's vocabulary."
 $nl
-"Now, add the following at the start of the source file:"
+"So now, add the following at the start of the source file:"
 { $code "USING: kernel ;" }
-"Next, find out what vocabulary " { $link reverse } " lives in:"
-{ $code "\\ reverse see" }
+"Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the workspace listener's input area, and press " { $operation com-follow } "."
+$nl
 "It lives in the " { $vocab-link "sequences" } " vocabulary, so we add that to the search path:"
 { $code "USING: kernel sequences ;" }
-"Finally, check what vocabulary " { $link = } " lives in:"
-{ $code "\\ = see" }
-"It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
-
+"Finally, check what vocabulary " { $link = } " lives in, and confirm that it's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
+$nl
 "Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
 
 ARTICLE: "first-program-test" "Testing your first program"
@@ -81,9 +72,9 @@ $nl
 { $code "." }
 "What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
 $nl
-"Create a file named " { $snippet "palindrome-tests.factor" } " in the same directory as " { $snippet "palindrome.factor" } ". Now, we can run unit tests from the listener:"
-{ $code "\"palindrome\" test" }
-"We will add some unit tests corresponding to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
+"Open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
+$nl
+"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
 $nl
 "Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
 { $code
@@ -145,7 +136,7 @@ $nl
 ARTICLE: "first-program" "Your first program"
 "In this tutorial, we will write a simple Factor program which prompts the user to enter a word, and tests if it is a palindrome (that is, the word is spelled the same backwards and forwards)."
 $nl
-"In this tutorial, you will learn about basic Factor development tools, as well as application deployment."
+"In this tutorial, you will learn about basic Factor development tools. You may want to open a second workspace window by pressing " { $command workspace "workflow" workspace-window } "; this will allow you to read this tutorial and browse other documentation at the same time."
 { $subsection "first-program-start" }
 { $subsection "first-program-logic" }
 { $subsection "first-program-test" }
diff --git a/basis/io/encodings/string/string-docs.factor b/basis/io/encodings/string/string-docs.factor
index 0a35eee272..dc0f547301 100644
--- a/basis/io/encodings/string/string-docs.factor
+++ b/basis/io/encodings/string/string-docs.factor
@@ -4,7 +4,8 @@ USING: help.markup help.syntax byte-arrays strings ;
 IN: io.encodings.string
 
 ARTICLE: "io.encodings.string" "Encoding and decoding strings"
-"Strings can be encoded or decoded to and from byte arrays through an encoding with the following words:"
+"Strings can be encoded or decoded to and from byte arrays through an encoding by passing "
+{ $link "encodings-descriptors" } " to the following words:"
 { $subsection encode }
 { $subsection decode } ;
 
diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor
index 00711ce226..22c40da3d7 100644
--- a/basis/io/servers/connection/connection-docs.factor
+++ b/basis/io/servers/connection/connection-docs.factor
@@ -45,15 +45,20 @@ ARTICLE: "server-config-handler" "Client handler quotation"
 $nl
 "The two methods are equivalent, representing a functional versus an object-oriented approach to the problem." ;
 
+ARTICLE: "server-examples" "Threaded server examples"
+"The " { $vocab-link "time-server" } " vocabulary implements a simple threaded server which sends the current time to the client. The " { $vocab-link "concurrency.distributed" } ", " { $vocab-link "ftp.server" } ", and " { $vocab-link "http.server" } " vocabularies demonstrate more complex usage of the threaded server library." ;
+
 ARTICLE: "io.servers.connection" "Threaded servers"
 "The " { $vocab-link "io.servers.connection" } " vocabulary implements a generic server abstraction for " { $link "network-connection" } ". A set of threads listen for connections, and additional threads are spawned for each client connection. In addition to this basic functionality, it provides some advanced features such as logging, connection limits and secure socket support."
-{ $subsection threaded-server }
-{ $subsection "server-config" }
+{ $subsection "server-examples" }
 "Creating threaded servers with client handler quotations:"
 { $subsection <threaded-server> }
 "Client handlers can also be implemented by subclassing a threaded server; see " { $link "server-config-handler" } " for details:"
+{ $subsection threaded-server }
 { $subsection new-threaded-server }
 { $subsection handle-client* }
+"The server must be configured before it can be started." 
+{ $subsection "server-config" }
 "Starting the server:"
 { $subsection start-server }
 { $subsection start-server* }
diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor
index eb368936d4..35e0536530 100644
--- a/basis/locals/locals-docs.factor
+++ b/basis/locals/locals-docs.factor
@@ -1,5 +1,5 @@
 USING: help.syntax help.markup kernel macros prettyprint
-memoize ;
+memoize combinators arrays ;
 IN: locals
 
 HELP: [|
@@ -84,6 +84,39 @@ HELP: MEMO::
 
 { POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
 
+ARTICLE: "locals-literals" "Locals in array and hashtable literals"
+"Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables."
+$nl
+"The data types which receive this special handling are the following:"
+{ $list
+    { $link "arrays" }
+    { $link "hashtables" }
+    { $link "vectors" }
+    { $link "tuples" }
+}
+"This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:"
+{ $example
+    "IN: scratchpad"
+    "TUPLE: person first-name last-name ;"
+    ": ordinary-word-test ( -- tuple )"
+    "    T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
+    "ordinary-word-test ordinary-word-test eq? ."
+    "t"
+}
+"In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:"
+{ $example
+    "IN: scratchpad"
+    "TUPLE: person first-name last-name ;"
+    ":: ordinary-word-test ( -- tuple )"
+    "    T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
+    "ordinary-word-test ordinary-word-test eq? ."
+    "f"
+}
+"One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
+$nl
+"For example, here is an implementation of the " { $link 3array } " word which uses this feature:"
+{ $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
+
 ARTICLE: "locals-mutable" "Mutable locals"
 "In the list of bindings supplied to " { $link POSTPONE: :: } ", " { $link POSTPONE: [let } ", " { $link POSTPONE: [let* } " or " { $link POSTPONE: [| } ", a mutable binding may be introduced by suffixing its named with " { $snippet "!" } ". Mutable bindings are read by giving their name as usual; the suffix is not part of the binding's name. To write to a mutable binding, use the binding's name with the " { $snippet "!" } " suffix."
 $nl
@@ -139,6 +172,7 @@ $nl
 "Lambda abstractions:"
 { $subsection POSTPONE: [| }
 "Additional topics:"
+{ $subsection "locals-literals" }
 { $subsection "locals-mutable" }
 { $subsection "locals-limitations" }
 "Locals complement dynamically scoped variables implemented in the " { $vocab-link "namespaces" } " vocabulary." ;
diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor
index 44cf5f724f..159421c18c 100644
--- a/basis/prettyprint/prettyprint-docs.factor
+++ b/basis/prettyprint/prettyprint-docs.factor
@@ -1,6 +1,6 @@
 USING: prettyprint.backend prettyprint.config
 prettyprint.sections prettyprint.private help.markup help.syntax
-io kernel words definitions quotations strings ;
+io kernel words definitions quotations strings generic classes ;
 IN: prettyprint
 
 ARTICLE: "prettyprint-numbers" "Prettyprinting numbers"
@@ -150,6 +150,8 @@ $nl
 { $subsection pprint-cell }
 "Printing a definition (see " { $link "definitions" } "):"
 { $subsection see }
+"Printing the methods defined on a generic word or class (see " { $link "objects" } "):"
+{ $subsection see-methods }
 "More prettyprinter usage:"
 { $subsection "prettyprint-numbers" }
 { $subsection "prettyprint-stacks" }
@@ -167,17 +169,26 @@ HELP: with-pprint
 
 HELP: pprint
 { $values { "obj" object } }
-{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } ". Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
+{ $warning
+    "Unparsing a large object can take a long time and consume a lot of memory. If you need to print large objects, use " { $link pprint-short } " or set some " { $link "prettyprint-variables" } " to limit output size."
+} ;
 
 { pprint pprint* with-pprint } related-words
 
 HELP: .
 { $values { "obj" object } }
-{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Prettyprints an object to " { $link output-stream } " with a trailing line break. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
+{ $warning
+    "Printing a large object can take a long time and consume a lot of memory. If you need to print large objects, use " { $link short. } " or set some " { $link "prettyprint-variables" } " to limit output size."
+} ;
 
 HELP: unparse
 { $values { "obj" object } { "str" "Factor source string" } }
-{ $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." } ;
+{ $description "Outputs a prettyprinted string representation of an object. Output is influenced by many variables; see " { $link "prettyprint-variables" } "." }
+{ $warning
+    "Unparsing a large object can take a long time and consume a lot of memory. If you need to unparse large objects, use " { $link unparse-short } " or set some " { $link "prettyprint-variables" } " to limit output size."
+} ;
 
 HELP: pprint-short
 { $values { "obj" object } }
@@ -240,6 +251,10 @@ HELP: see
 { $values { "defspec" "a definition specifier" } }
 { $contract "Prettyprints a definition." } ;
 
+HELP: see-methods
+{ $values { "word" "a " { $link generic } " or a " { $link class } } }
+{ $contract "Prettyprints the methods defined on a generic word or class." } ;
+
 HELP: definer
 { $values { "defspec" "a definition specifier" } { "start" word } { "end" "a word or " { $link f } } }
 { $contract "Outputs the parsing words which delimit the definition." }
diff --git a/basis/tools/crossref/crossref-docs.factor b/basis/tools/crossref/crossref-docs.factor
index 477ea01ef6..b7ec0d07a2 100644
--- a/basis/tools/crossref/crossref-docs.factor
+++ b/basis/tools/crossref/crossref-docs.factor
@@ -1,10 +1,10 @@
-USING: help.markup help.syntax words definitions ;
+USING: help.markup help.syntax words definitions prettyprint ;
 IN: tools.crossref
 
 ARTICLE: "tools.crossref" "Cross-referencing tools" 
 { $subsection usage. }
 { $subsection apropos }
-{ $see-also "definitions" "words" } ;
+{ $see-also "definitions" "words" see see-methods } ;
 
 ABOUT: "tools.crossref"
 
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index becd855653..396b3e8f9a 100644
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -1,6 +1,6 @@
 USING: help.markup help.syntax words classes classes.algebra
 definitions kernel alien sequences math quotations
-generic.standard generic.math combinators ;
+generic.standard generic.math combinators prettyprint ;
 IN: generic
 
 ARTICLE: "method-order" "Method precedence"
@@ -46,7 +46,8 @@ $nl
 "Low-level method constructor:"
 { $subsection <method> }
 "A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
-{ $subsection method-spec } ;
+{ $subsection method-spec }
+{ $see-also see see-methods } ;
 
 ARTICLE: "method-combination" "Custom method combination"
 "Abstractly, a generic word can be thought of as a big chain of type conditional tests applied to the top of the stack, with methods as the bodies of each test. The " { $emphasis "method combination" } " is this control flow glue between the set of methods, and several aspects of it can be customized:"
diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor
index 92471acb5d..ba25e79509 100644
--- a/core/io/encodings/encodings-docs.factor
+++ b/core/io/encodings/encodings-docs.factor
@@ -5,8 +5,10 @@ ABOUT: "io.encodings"
 
 ARTICLE: "io.encodings" "I/O encodings"
 "Bytes can't be understood in isolation as text. They must be interpreted under a certain encoding. Factor provides utilities for dealing with encoded text by declaring that a stream has a particular encoding, and utilities to encode and decode strings."
-{ $subsection "encodings-constructors" }
 { $subsection "encodings-descriptors" }
+{ $subsection "encodings-constructors" }
+{ $subsection "io.encodings.string" }
+"New types of encodings can be defined:"
 { $subsection "encodings-protocol" } ;
 
 ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor
index f410148566..c84699539d 100644
--- a/core/namespaces/namespaces-docs.factor
+++ b/core/namespaces/namespaces-docs.factor
@@ -99,7 +99,10 @@ HELP: counter
 
 HELP: with-scope
 { $values { "quot" quotation } }
-{ $description "Calls the quotation in a new namespace. Any variables set by the quotation are discarded when it returns." } ;
+{ $description "Calls the quotation in a new namespace. Any variables set by the quotation are discarded when it returns." }
+{ $examples
+    { $example "USING: math namespaces prettyprint ;" "IN: scratchpad" "SYMBOL: x" "0 x set" "[ x [ 5 + ] change x get . ] with-scope x get ." "5\n0" }
+} ;
 
 HELP: with-variable
 { $values { "value" object } { "key" "a variable, by convention a symbol" } { "quot" quotation } }
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index a75b97c040..8cb7f1c088 100644
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -841,7 +841,8 @@ HELP: unclip
 
 HELP: unclip-slice
 { $values { "seq" sequence } { "rest-slice" slice } { "first" object } }
-{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
+{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." }
+{ $examples { $example "USING: math.order prettyprint sequences ;" "{ 3 -1 -10 5 7 } unclip-slice [ min ] reduce ." "-10" } } ;
 
 HELP: unclip-last
 { $values { "seq" sequence } { "butlast" sequence } { "last" object } }

From f1a1a4c1cb744edc1e40a7ed494ea5477faadace Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 10:56:58 -0600
Subject: [PATCH 294/318] Cloning a dlist did not clone its nodes, and so was
 useless

---
 basis/dlists/dlists-tests.factor | 7 +++++++
 basis/dlists/dlists.factor       | 8 ++++++++
 2 files changed, 15 insertions(+)

diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor
index 15022452ee..92b141dca8 100644
--- a/basis/dlists/dlists-tests.factor
+++ b/basis/dlists/dlists-tests.factor
@@ -77,3 +77,10 @@ IN: dlists.tests
 [ f ] [ <dlist> 3 over push-front 4 over push-back -1 swap deque-member? ] unit-test
 
 [ f ] [ <dlist> 0 swap deque-member? ] unit-test
+
+! Make sure clone does the right thing
+[ V{ 2 1 } V{ 2 1 3 } ] [
+    <dlist> 1 over push-front 2 over push-front
+    dup clone 3 over push-back
+    [ dlist>seq ] bi@
+] unit-test
diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
index 3b3cae2820..5072c3edfd 100644
--- a/basis/dlists/dlists.factor
+++ b/basis/dlists/dlists.factor
@@ -154,6 +154,14 @@ M: dlist clear-deque ( dlist -- )
 : dlist-each ( dlist quot -- )
     [ obj>> ] prepose dlist-each-node ; inline
 
+: dlist>seq ( dlist -- seq )
+    [ ] pusher [ dlist-each ] dip ;
+
 : 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
 
+M: dlist clone
+    <dlist> [
+        [ push-back ] curry dlist-each
+    ] keep ;
+
 INSTANCE: dlist deque

From 4c0f2cc3f564d5cae24bfbae23671b40fdb72f0c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 11:30:47 -0600
Subject: [PATCH 295/318] Move factor-2s from miller-rabin to math.functions;
 use it to make ^ more efficient

---
 basis/math/functions/functions-tests.factor |  3 ++
 basis/math/functions/functions.factor       | 37 +++++++++++++++++----
 extra/math/miller-rabin/miller-rabin.factor |  7 ----
 3 files changed, 34 insertions(+), 13 deletions(-)

diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor
index cbaf37daf8..a06a67e4a1 100644
--- a/basis/math/functions/functions-tests.factor
+++ b/basis/math/functions/functions-tests.factor
@@ -134,3 +134,6 @@ IN: math.functions.tests
 [ -4.0 ] [ -4.4 round ] unit-test
 [ 5.0 ] [ 4.5 round ] unit-test
 [ 4.0 ] [ 4.4 round ] unit-test
+
+[ 6 59967 ] [ 3837888 factor-2s ] unit-test
+[ 6 -59967 ] [ -3837888 factor-2s ] unit-test
diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
index 8516292e9d..0444998bec 100644
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel math.constants math.private
-math.libm combinators math.order ;
+math.libm combinators math.order math.ratios sequences ;
 IN: math.functions
 
 <PRIVATE
@@ -30,14 +30,35 @@ M: real sqrt
         2dup >r >r >r odd? r> call r> 2/ r> each-bit
     ] if ; inline recursive
 
-: ^n ( z w -- z^w )
-    1 swap [
-        [ dupd * ] when >r sq r>
-    ] each-bit nip ; inline
+: map-bits ( n quot: ( ? -- obj ) -- seq )
+    accumulator [ each-bit ] dip ; inline
+
+: factor-2s ( n -- r s )
+    #! factor an integer into 2^r * s
+    dup 0 = [ 1 ] [
+        0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while
+    ] if ; inline
+
+<PRIVATE
+
+GENERIC# ^n 1 ( z w -- z^w )
+
+: (^n) 1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline
+
+M: integer ^n
+    [ factor-2s ] dip [ (^n) ] keep rot * shift ;
+
+M: ratio ^n
+    [ >fraction ] dip tuck [ ^n ] 2bi@ / ;
+
+M: float ^n
+    (^n) ;
 
 : integer^ ( x y -- z )
     dup 0 > [ ^n ] [ neg ^n recip ] if ; inline
 
+PRIVATE>
+
 : >rect ( z -- x y )
     [ real-part ] [ imaginary-part ] bi ; inline
 
@@ -52,6 +73,8 @@ M: real sqrt
 
 : polar> ( abs arg -- z ) cis * ; inline
 
+<PRIVATE
+
 : ^mag ( w abs arg -- magnitude )
     >r >r >float-rect swap r> swap fpow r> rot * fexp /f ;
     inline
@@ -68,6 +91,8 @@ M: real sqrt
 : 0^ ( x -- z )
     dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
 
+PRIVATE>
+
 : ^ ( x y -- z )
     {
         { [ over zero? ] [ nip 0^ ] }
diff --git a/extra/math/miller-rabin/miller-rabin.factor b/extra/math/miller-rabin/miller-rabin.factor
index 3045a35836..def8a04738 100755
--- a/extra/math/miller-rabin/miller-rabin.factor
+++ b/extra/math/miller-rabin/miller-rabin.factor
@@ -11,13 +11,6 @@ IN: math.miller-rabin
 
 TUPLE: positive-even-expected n ;
 
-: (factor-2s) ( r s -- r s )
-    dup even? [ -1 shift [ 1+ ] dip (factor-2s) ] when ;
-
-: factor-2s ( n -- r s )
-    #! factor an integer into s * 2^r
-    0 swap (factor-2s) ;
-
 :: (miller-rabin) ( n trials -- ? )
     [let | r [ n 1- factor-2s drop ]
            s [ n 1- factor-2s nip ]

From fed799a32c402501e7635bfbeb6cef46bc90e8dc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 11:39:38 -0600
Subject: [PATCH 296/318] Fix circularity

---
 basis/math/functions/functions.factor | 5 ++++-
 basis/math/ratios/ratios.factor       | 3 ---
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
index 0444998bec..43efc35c27 100644
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@@ -1,9 +1,12 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel math.constants math.private
-math.libm combinators math.order math.ratios sequences ;
+math.libm combinators math.order sequences ;
 IN: math.functions
 
+: >fraction ( a/b -- a b )
+    [ numerator ] [ denominator ] bi ; inline
+
 <PRIVATE
 
 : (rect>) ( x y -- z )
diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor
index 5dde4fbb99..d9dea22b7b 100644
--- a/basis/math/ratios/ratios.factor
+++ b/basis/math/ratios/ratios.factor
@@ -3,9 +3,6 @@
 USING: accessors kernel kernel.private math math.functions math.private ;
 IN: math.ratios
 
-: >fraction ( a/b -- a b )
-    dup numerator swap denominator ; inline
-
 : 2>fraction ( a/b c/d -- a c b d )
     [ >fraction ] bi@ swapd ; inline
 

From d7dd084b8d69817034572f4528c09c0aba7336ae Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 11:46:35 -0600
Subject: [PATCH 297/318] Usability tweak: focus on listener input area when
 input presentation is clicked

---
 basis/ui/tools/listener/listener.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 4c8b88d62c..68bf765295 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -50,7 +50,8 @@ M: listener-gadget tool-scroller
     listener>> input>> interactor-busy? ;
 
 : listener-input ( string -- )
-    get-workspace listener>> input>> set-editor-string ;
+    get-workspace listener>> input>>
+    [ set-editor-string ] [ request-focus ] bi ;
 
 : (call-listener) ( quot listener -- )
     input>> interactor-call ;

From a32acdcff01f925d6fbc6a6145ab5688db680a26 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 12:11:13 -0600
Subject: [PATCH 298/318] Tweak grouping code for better method inlining

---
 .../tree/cleanup/cleanup-tests.factor         |  7 +-
 core/grouping/grouping.factor                 | 74 ++++++++++++-------
 2 files changed, 53 insertions(+), 28 deletions(-)

diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor
index 13847e55a2..4a6198db37 100644
--- a/basis/compiler/tree/cleanup/cleanup-tests.factor
+++ b/basis/compiler/tree/cleanup/cleanup-tests.factor
@@ -5,7 +5,7 @@ strings sbufs sequences.private slots.private combinators
 definitions system layouts vectors math.partial-dispatch
 math.order math.functions accessors hashtables classes assocs
 io.encodings.utf8 io.encodings.ascii io.encodings fry slots
-sorting.private combinators.short-circuit
+sorting.private combinators.short-circuit grouping prettyprint
 compiler.tree
 compiler.tree.combinators
 compiler.tree.cleanup
@@ -505,3 +505,8 @@ cell-bits 32 = [
     [ { null } declare [ 1 ] [ 2 ] if ]
     build-tree normalize propagate cleanup check-nodes
 ] unit-test
+
+[ t ] [
+    [ { array } declare 2 <groups> [ . . ] assoc-each ]
+    \ nth-unsafe inlined?
+] unit-test
diff --git a/core/grouping/grouping.factor b/core/grouping/grouping.factor
index 332fd2635a..4a1b8c7b90 100644
--- a/core/grouping/grouping.factor
+++ b/core/grouping/grouping.factor
@@ -1,10 +1,12 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.order strings arrays vectors sequences
-accessors ;
+sequences.private accessors ;
 IN: grouping
 
-TUPLE: abstract-groups { seq read-only } { n read-only } ;
+<PRIVATE
+
+TUPLE: chunking-seq { seq read-only } { n read-only } ;
 
 : check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
 
@@ -13,55 +15,73 @@ TUPLE: abstract-groups { seq read-only } { n read-only } ;
 
 GENERIC: group@ ( n groups -- from to seq )
 
-M: abstract-groups nth group@ subseq ;
+M: chunking-seq set-nth group@ <slice> 0 swap copy ;
 
-M: abstract-groups set-nth group@ <slice> 0 swap copy ;
+M: chunking-seq like drop { } like ;
 
-M: abstract-groups like drop { } like ;
+INSTANCE: chunking-seq sequence
 
-INSTANCE: abstract-groups sequence
+MIXIN: subseq-chunking
+
+M: subseq-chunking nth group@ subseq ;
+
+MIXIN: slice-chunking
+
+M: slice-chunking nth group@ <slice> ;
+
+M: slice-chunking nth-unsafe group@ slice boa ;
+
+TUPLE: abstract-groups < chunking-seq ;
+
+M: abstract-groups length
+    [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
+
+M: abstract-groups set-length
+    [ n>> * ] [ seq>> ] bi set-length ;
+
+M: abstract-groups group@
+    [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
+
+TUPLE: abstract-clumps < chunking-seq ;
+
+M: abstract-clumps length
+    [ seq>> length ] [ n>> ] bi - 1+ ;
+
+M: abstract-clumps set-length
+    [ n>> + 1- ] [ seq>> ] bi set-length ;
+
+M: abstract-clumps group@
+    [ n>> over + ] [ seq>> ] bi ;
+
+PRIVATE>
 
 TUPLE: groups < abstract-groups ;
 
 : <groups> ( seq n -- groups )
     groups new-groups ; inline
 
-M: groups length
-    [ seq>> length ] [ n>> ] bi [ + 1- ] keep /i ;
+INSTANCE: groups subseq-chunking
 
-M: groups set-length
-    [ n>> * ] [ seq>> ] bi set-length ;
-
-M: groups group@
-    [ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ;
-
-TUPLE: sliced-groups < groups ;
+TUPLE: sliced-groups < abstract-groups ;
 
 : <sliced-groups> ( seq n -- groups )
     sliced-groups new-groups ; inline
 
-M: sliced-groups nth group@ <slice> ;
+INSTANCE: sliced-groups slice-chunking
 
-TUPLE: clumps < abstract-groups ;
+TUPLE: clumps < abstract-clumps ;
 
 : <clumps> ( seq n -- clumps )
     clumps new-groups ; inline
 
-M: clumps length
-    [ seq>> length ] [ n>> ] bi - 1+ ;
+INSTANCE: clumps subseq-chunking
 
-M: clumps set-length
-    [ n>> + 1- ] [ seq>> ] bi set-length ;
-
-M: clumps group@
-    [ n>> over + ] [ seq>> ] bi ;
-
-TUPLE: sliced-clumps < clumps ;
+TUPLE: sliced-clumps < abstract-clumps ;
 
 : <sliced-clumps> ( seq n -- clumps )
     sliced-clumps new-groups ; inline
 
-M: sliced-clumps nth group@ <slice> ;
+INSTANCE: sliced-clumps slice-chunking
 
 : group ( seq n -- array ) <groups> { } like ;
 

From 8a6ecec9f3ebe23941d4288357620a351559d570 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 12:11:36 -0600
Subject: [PATCH 299/318] Fix broken link in ratios docs

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

diff --git a/basis/math/ratios/ratios-docs.factor b/basis/math/ratios/ratios-docs.factor
index 903017e371..7b6393dabe 100644
--- a/basis/math/ratios/ratios-docs.factor
+++ b/basis/math/ratios/ratios-docs.factor
@@ -1,5 +1,5 @@
 USING: help.markup help.syntax math math.private
-math.ratios.private ;
+math.ratios.private math.functions ;
 IN: math.ratios
 
 ARTICLE: "rationals" "Rational numbers"

From 439acef7a12ce94194831e456e4ee20e7996e595 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 13:02:51 -0600
Subject: [PATCH 300/318] better roman docs

---
 extra/roman/roman-docs.factor | 90 +++++++++++++++++++++++++++++++----
 1 file changed, 81 insertions(+), 9 deletions(-)

diff --git a/extra/roman/roman-docs.factor b/extra/roman/roman-docs.factor
index 87551635f1..4a8197f064 100644
--- a/extra/roman/roman-docs.factor
+++ b/extra/roman/roman-docs.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel math ;
 IN: roman
 
@@ -5,44 +7,114 @@ HELP: >roman
 { $values { "n" "an integer" } { "str" "a string" } }
 { $description "Converts a number to its lower-case Roman Numeral equivalent." }
 { $notes "The range for this word is 1-3999, inclusive." }
-{ $see-also >ROMAN roman> } ;
+{ $examples 
+    { $example "USING: io roman ;"
+               "56 >roman print"
+               "lvi"
+    }
+} ;
 
 HELP: >ROMAN
 { $values { "n" "an integer" } { "str" "a string" } }
 { $description "Converts a number to its upper-case Roman numeral equivalent." }
 { $notes "The range for this word is 1-3999, inclusive." }
-{ $see-also >roman roman> } ;
+{ $examples 
+    { $example "USING: io roman ;"
+               "56 >ROMAN print"
+               "LVI"
+    }
+} ;
 
 HELP: roman>
 { $values { "str" "a string" } { "n" "an integer" } }
 { $description "Converts a Roman numeral to an integer." }
 { $notes "The range for this word is i-mmmcmxcix, inclusive." }
-{ $see-also >roman } ;
+{ $examples 
+    { $example "USING: prettyprint roman ;"
+               "\"lvi\" roman> ."
+               "56"
+    }
+} ;
+
+{ >roman >ROMAN roman> } related-words
 
 HELP: roman+
 { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
 { $description "Adds two Roman numerals." }
-{ $see-also roman- } ;
+{ $examples 
+    { $example "USING: io roman ;"
+               "\"v\" \"v\" roman+ print"
+               "x"
+    }
+} ;
 
 HELP: roman-
 { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
 { $description "Subtracts two Roman numerals." }
-{ $see-also roman+ } ;
+{ $examples 
+    { $example "USING: io roman ;"
+               "\"x\" \"v\" roman- print"
+               "v"
+    }
+} ;
+
+{ roman+ roman- } related-words
 
 HELP: roman*
 { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
 { $description "Multiplies two Roman numerals." }
-{ $see-also roman/i roman/mod } ;
+{ $examples 
+    { $example "USING: io roman ;"
+        "\"ii\" \"iii\" roman* print"
+        "vi"
+    }
+} ;
 
 HELP: roman/i
 { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
 { $description "Computes the integer division of two Roman numerals." }
-{ $see-also roman* roman/mod /i } ;
+{ $examples 
+    { $example "USING: io roman ;"
+        "\"v\" \"iv\" roman/i print"
+        "i"
+    }
+} ;
 
 HELP: roman/mod
 { $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
 { $description "Computes the quotient and remainder of two Roman numerals." }
-{ $see-also roman* roman/i /mod } ;
+{ $examples 
+    { $example "USING: kernel io roman ;"
+        "\"v\" \"iv\" roman/mod [ print ] bi@"
+        "i\ni"
+    }
+} ;
+
+{ roman* roman/i roman/mod } related-words
 
 HELP: ROMAN:
-{ $description "A parsing word that reads the next token and converts it to an integer." } ;
+{ $description "A parsing word that reads the next token and converts it to an integer." }
+{ $examples 
+    { $example "USING: prettyprint roman ;"
+               "ROMAN: v ."
+               "5"
+    }
+} ;
+
+ARTICLE: "roman" "Roman numerals"
+"The " { $vocab-link "roman" } " vocabulary can convert numbers to and from the Roman numeral system and can perform arithmetic given Roman numerals as input." $nl
+"A parsing word for literal Roman numerals:"
+{ $subsection POSTPONE: ROMAN: }
+"Converting to Roman numerals:"
+{ $subsection >roman }
+{ $subsection >ROMAN }
+"Converting Roman numerals to integers:"
+{ $subsection roman> }
+"Roman numeral arithmetic:"
+{ $subsection roman+ }
+{ $subsection roman- }
+{ $subsection roman* }
+{ $subsection roman/i }
+{ $subsection roman/mod } ;
+
+ABOUT: "roman"

From 7aeeb2c9cedfedb986efb4738cf0e39ae82c164b Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 13:03:08 -0600
Subject: [PATCH 301/318] bitwise docs, fix some bugs in bitwise words

---
 basis/math/bitwise/bitwise-docs.factor  | 310 +++++++++++++++++++++++-
 basis/math/bitwise/bitwise-tests.factor |   2 +
 basis/math/bitwise/bitwise.factor       |  25 +-
 3 files changed, 317 insertions(+), 20 deletions(-)

diff --git a/basis/math/bitwise/bitwise-docs.factor b/basis/math/bitwise/bitwise-docs.factor
index 247523369b..4f2606bda0 100644
--- a/basis/math/bitwise/bitwise-docs.factor
+++ b/basis/math/bitwise/bitwise-docs.factor
@@ -1,12 +1,8 @@
-USING: help.markup help.syntax math ;
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax math sequences ;
 IN: math.bitwise
 
-ARTICLE: "math-bitfields" "Constructing bit fields"
-"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
-{ $subsection bitfield } ;
-
-ABOUT: "math-bitfields"
-
 HELP: bitfield
 { $values { "values..." "a series of objects" } { "bitspec" "an array" } { "n" integer } }
 { $description "Constructs an integer from a series of values on the stack together with a bit field specifier, which is an array whose elements have one of the following shapes:"
@@ -42,9 +38,307 @@ HELP: bits
 { $example "USING: math.bitwise prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ;
 
 HELP: bitroll
-{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
+{ $values { "x" integer } { "s" "a shift integer" } { "w" "a wrap integer" } { "y" integer }
+}
 { $description "Roll n by s bits to the left, wrapping around after w bits." }
 { $examples
     { $example "USING: math.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
     { $example "USING: math.bitwise prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
 } ;
+
+HELP: bit-clear?
+{ $values
+     { "x" integer } { "n" integer }
+     { "?" "a boolean" }
+}
+{ $description "Returns " { $link t } " if the nth bit is set to zero." }
+{ $examples 
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: ff 8 bit-clear? ."
+               "t"
+    }
+    { $example "" "USING: math.bitwise prettyprint ;"
+               "HEX: ff 7 bit-clear? ."
+               "f"
+    }
+} ;
+
+{ bit? bit-clear? set-bit clear-bit } related-words
+
+HELP: bit-count
+{ $values
+     { "x" integer }
+     { "n" integer }
+}
+{ $description "Returns the number of set bits as an integer." }
+{ $examples 
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: f0 bit-count ."
+               "4"
+    }
+    { $example "USING: math.bitwise prettyprint ;"
+               "-7 bit-count ."
+               "2"
+    }
+} ;
+
+HELP: bitroll-32
+{ $values
+     { "n" integer } { "s" integer }
+     { "n'" integer }
+}     
+{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 32 bits." }
+{ $examples 
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: 1 10 bitroll-32 .h"
+               "400"
+    }
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: 1 -10 bitroll-32 .h"
+               "400000"
+    }
+} ;
+
+HELP: bitroll-64
+{ $values
+     { "n" integer } { "s" "a shift integer" }
+     { "n'" integer }
+}
+{ $description "Rolls the number " { $snippet "n" } " by " { $snippet "s" } " bits to the left, wrapping around after 64 bits." }
+{ $examples 
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: 1 10 bitroll-64 .h"
+               "400"
+    }
+    { $example "USING: math.bitwise prettyprint ;"
+               "HEX: 1 -10 bitroll-64 .h"
+               "40000000000000"
+    }
+} ;
+
+{ bitroll bitroll-32 bitroll-64 } related-words
+
+HELP: clear-bit
+{ $values
+     { "x" integer } { "n" integer }
+     { "y" integer }
+}
+{ $description "Sets the nth bit of " { $snippet "x" } " to zero." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ff 7 clear-bit .h"
+        "7f"
+    }
+} ;
+
+HELP: flags
+{ $values
+     { "values" sequence }
+}
+{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "IN: scratchpad"
+        ": MY-CONSTANT HEX: 1 ; inline"
+        "{ HEX: 20 MY-CONSTANT BIN: 100 } flags .h"
+        "25"
+    }
+} ;
+
+HELP: mask
+{ $values
+     { "x" integer } { "n" integer }
+     { "?" "a boolean" }
+}
+{ $description "After the operation, only the bits that were set in both the mask and the original number are set." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "BIN: 11111111 BIN: 101 mask .b"
+        "101"
+    }
+} ;
+
+HELP: mask-bit
+{ $values
+     { "m" integer } { "n" integer }
+     { "m'" integer }
+}
+{ $description "Turns off all bits besides the nth bit." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ff 2 mask-bit .b"
+        "100"
+    }
+} ;
+
+HELP: mask?
+{ $values
+     { "x" integer } { "n" integer }
+     { "?" "a boolean" }
+}
+{ $description "Returns true if all of the bits in the mask " { $snippet "n" } " are set in the integer input " { $snippet "x" } "." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ff HEX: f mask? ."
+        "t"
+    }
+
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: f0 HEX: 1 mask? ."
+        "f"
+    }
+} ;
+
+HELP: on-bits
+{ $values
+     { "n" integer }
+     { "m" integer }
+}
+{ $description "Returns an integer with " { $snippet "n" } " bits set." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "6 on-bits .h"
+        "3f"
+    }
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "64 on-bits .h"
+        "ffffffffffffffff"
+    }
+}
+;
+
+HELP: set-bit
+{ $values
+     { "x" integer } { "n" integer }
+     { "y" integer }
+}
+{ $description "Sets the nth bit of " { $snippet "x" } "." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "0 5 set-bit .h"
+        "20"
+    }
+} ;
+
+HELP: shift-mod
+{ $values
+     { "n" integer } { "s" integer } { "w" integer }
+     { "n" integer }
+}
+{ $description "" } ;
+
+HELP: unmask
+{ $values
+     { "x" integer } { "n" integer }
+     { "?" "a boolean" }
+}
+{ $description "Clears the bits in " { $snippet "x" } " if they are set in the mask " { $snippet "n" } "." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ff  HEX: 0f unmask .h"
+        "f0"
+    }
+} ;
+
+HELP: unmask?
+{ $values
+     { "x" integer } { "n" integer }
+     { "?" "a boolean" }
+}
+{ $description "Tests whether unmasking the bits in " { $snippet "x" } " would return an integer greater than zero." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ff  HEX: 0f unmask? ."
+        "t"
+    }
+} ;
+
+HELP: w*
+{ $values
+     { "int" integer } { "int" integer }
+     { "int" integer }
+}
+{ $description "Multiplies two integers and wraps the result to 32 bits." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ffffffff HEX: 2 w* ."
+        "4294967294"
+    }
+} ;
+
+HELP: w+
+{ $values
+     { "int" integer } { "int" integer }
+     { "int" integer }
+}
+{ $description "Adds two integers and wraps the result to 32 bits." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: ffffffff HEX: 2 w+ ."
+        "1"
+    }
+} ;
+
+HELP: w-
+{ $values
+     { "int" integer } { "int" integer }
+     { "int" integer }
+}
+{ $description "Subtracts two integers and wraps the result to 32 bits." }
+{ $examples
+    { $example "USING: math.bitwise kernel prettyprint ;"
+        "HEX: 0 HEX: ff w- ."
+        "4294967041"
+    }
+} ;
+
+HELP: wrap
+{ $values
+     { "m" integer } { "n" integer }
+     { "m'" integer }
+}
+{ $description "Wraps an integer " { $snippet "m" } " by modding it by " { $snippet "n" } ". This word is uses bitwise arithmetic and does not actually call the modulus word, and as such can only mod by powers of two." }
+{ $examples "Equivalent to modding by 8:"
+    { $example 
+        "USING: math.bitwise prettyprint ;"
+        "HEX: ffff 8 wrap .h"
+        "7"
+    }
+} ;
+
+ARTICLE: "math-bitfields" "Constructing bit fields"
+"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
+{ $subsection bitfield } ;
+
+ARTICLE: "math.bitwise" "Bitwise arithmetic"
+"The " { $vocab-link "math.bitwise" } " vocabulary can implements bitwise arithmetic words that are useful for efficiency, low-level programming, and interfacing with C libraries." $nl
+"Setting and clearing bits:"
+{ $subsection set-bit }
+{ $subsection clear-bit }
+"Testing if bits are set or clear:"
+{ $subsection bit? }
+{ $subsection bit-clear? }
+"Operations with bitmasks:"
+{ $subsection mask }
+{ $subsection unmask }
+{ $subsection mask? }
+{ $subsection unmask? }
+"Generating an integer with n set bits:"
+{ $subsection on-bits }
+"Counting the number of set bits:"
+{ $subsection bit-count }
+"More efficient modding by powers of two:"
+{ $subsection wrap }
+"Bit-rolling:"
+{ $subsection bitroll }
+{ $subsection bitroll-32 }
+{ $subsection bitroll-64 }
+"32-bit arithmetic:"
+{ $subsection w+ }
+{ $subsection w- }
+{ $subsection w* }
+"Bitfields:"
+{ $subsection flags }
+{ $subsection "math-bitfields" } ;
+
+ABOUT: "math.bitwise"
diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor
index 8b13cb23b3..4422992956 100644
--- a/basis/math/bitwise/bitwise-tests.factor
+++ b/basis/math/bitwise/bitwise-tests.factor
@@ -27,3 +27,5 @@ IN: math.bitwise.tests
 [ 3 ] [ foo ] unit-test
 [ 3 ] [ { a b } flags ] unit-test
 \ foo must-infer
+
+[ 1 ] [ { 1 } flags ] unit-test
diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor
index 871f40e74c..ad1907fcb0 100644
--- a/basis/math/bitwise/bitwise.factor
+++ b/basis/math/bitwise/bitwise.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel math math.functions sequences
 sequences.private words namespaces macros hints
@@ -8,28 +8,29 @@ IN: math.bitwise
 ! utilities
 : clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
 : set-bit ( x n -- y ) 2^ bitor ; inline
-: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
+: bit-clear? ( x n -- ? ) 2^ bitand 0 = ; inline
 : unmask ( x n -- ? ) bitnot bitand ; inline
 : unmask? ( x n -- ? ) unmask 0 > ; inline
 : mask ( x n -- ? ) bitand ; inline
 : mask? ( x n -- ? ) mask 0 > ; inline
 : wrap ( m n -- m' ) 1- bitand ; inline
 : bits ( m n -- m' ) 2^ wrap ; inline
-: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
+: mask-bit ( m n -- m' ) 2^ mask ; inline
+: on-bits ( n -- m ) 2^ 1- ; inline
 
 : shift-mod ( n s w -- n )
-    >r shift r> 2^ wrap ; inline
+    [ shift ] dip 2^ wrap ; inline
 
 : bitroll ( x s w -- y )
-     [ wrap ] keep
-     [ shift-mod ]
-     [ [ - ] keep shift-mod ] 3bi bitor ; inline
+    [ wrap ] keep
+    [ shift-mod ]
+    [ [ - ] keep shift-mod ] 3bi bitor ; inline
 
-: bitroll-32 ( n s -- n' ) 32 bitroll ;
+: bitroll-32 ( n s -- n' ) 32 bitroll ; inline
 
 HINTS: bitroll-32 bignum fixnum ;
 
-: bitroll-64 ( n s -- n' ) 64 bitroll ;
+: bitroll-64 ( n s -- n' ) 64 bitroll ; inline
 
 HINTS: bitroll-64 bignum fixnum ;
 
@@ -40,7 +41,7 @@ HINTS: bitroll-64 bignum fixnum ;
 
 ! flags
 MACRO: flags ( values -- )
-    [ 0 ] [ [ execute bitor ] curry compose ] reduce ;
+    [ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
 
 ! bitfield
 <PRIVATE
@@ -51,7 +52,7 @@ M: integer (bitfield-quot) ( spec -- quot )
     [ swapd shift bitor ] curry ;
 
 M: pair (bitfield-quot) ( spec -- quot )
-    first2 over word? [ >r swapd execute r> ] [ ] ?
+    first2 over word? [ [ swapd execute ] dip ] [ ] ?
     [ shift bitor ] append 2curry ;
 
 PRIVATE>
@@ -91,4 +92,4 @@ M: bignum (bit-count)
 PRIVATE>
 
 : bit-count ( x -- n )
-    dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline
+    dup 0 < [ bitnot ] when (bit-count) ; inline

From 51ecc18cd80af33fded2d4290ac49a3eff4a3daa Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 13:03:42 -0600
Subject: [PATCH 302/318] changed a bitwise word, updating usage for mersenne
 twister

---
 basis/random/mersenne-twister/mersenne-twister.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor
index 712883e4b8..c31d338fac 100644
--- a/basis/random/mersenne-twister/mersenne-twister.factor
+++ b/basis/random/mersenne-twister/mersenne-twister.factor
@@ -16,7 +16,7 @@ TUPLE: mersenne-twister seq i ;
 : mt-a HEX: 9908b0df ; inline
 
 : calculate-y ( n seq -- y )
-    [ nth 32 mask-bit ]
+    [ nth 31 mask-bit ]
     [ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline
 
 : (mt-generate) ( n seq -- next-mt )

From e3533daf4d7ba00e6d61c87668b88cd3553d7269 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 13:04:20 -0600
Subject: [PATCH 303/318] make jedit behave nicely with scaffolding docs

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

diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor
index 6659940b2b..e1076775fa 100644
--- a/basis/tools/scaffold/scaffold.factor
+++ b/basis/tools/scaffold/scaffold.factor
@@ -148,7 +148,7 @@ ERROR: no-vocab vocab ;
             "{ $values" print
             [ "    " write ($values.) ]
             [ [ nl "    " write ($values.) ] unless-empty ] bi*
-            " }" write nl
+            nl "}" print
         ] if
     ] when* ;
 

From f6c0c43dd45e836600a2a735b5aca6f518d4f1d3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 13:05:04 -0600
Subject: [PATCH 304/318] fix user-cache and add tests for this

---
 basis/unix/groups/groups-tests.factor | 2 ++
 basis/unix/users/users-docs.factor    | 8 ++++----
 basis/unix/users/users-tests.factor   | 2 ++
 basis/unix/users/users.factor         | 8 ++++----
 4 files changed, 12 insertions(+), 8 deletions(-)

diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor
index 9e7122fc34..7e7ebd902a 100644
--- a/basis/unix/groups/groups-tests.factor
+++ b/basis/unix/groups/groups-tests.factor
@@ -22,3 +22,5 @@ IN: unix.groups.tests
 
 [ ] [ effective-group-name [ ] with-effective-group ] unit-test
 [ ] [ effective-group-id [ ] with-effective-group ] unit-test
+
+[ ] [ [ ] with-group-cache ] unit-test
diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor
index c466ad1575..83e7e99481 100644
--- a/basis/unix/users/users-docs.factor
+++ b/basis/unix/users/users-docs.factor
@@ -22,8 +22,8 @@ HELP: new-passwd
 HELP: passwd
 { $description "A platform-specific tuple correspding to every field from the Unix passwd struct. BSD passwd structures have four extra slots: " { $slot "change" } ", " { $slot "class" } "," { $slot "expire" } ", " { $slot "fields" } "." } ;
 
-HELP: passwd-cache
-{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-passwd-cache } "." } ;
+HELP: user-cache
+{ $description "A symbol storing passwd structures indexed by user-ids when within a " { $link with-user-cache } "." } ;
 
 HELP: passwd>new-passwd
 { $values
@@ -70,10 +70,10 @@ HELP: with-effective-user
      { "string/id" "a string or a uid" } { "quot" quotation } }
 { $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ;
 
-HELP: with-passwd-cache
+HELP: with-user-cache
 { $values
      { "quot" quotation } }
-{ $description "Iterates over the password file using library calls and creates a cache in the " { $link passwd-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
+{ $description "Iterates over the password file using library calls and creates a cache in the " { $link user-cache } " symbol. The cache is a hashtable indexed by user id. When looking up many users, this approach is much faster than calling system calls." } ;
 
 HELP: with-real-user
 { $values
diff --git a/basis/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor
index a85c322aca..1113383635 100644
--- a/basis/unix/users/users-tests.factor
+++ b/basis/unix/users/users-tests.factor
@@ -22,3 +22,5 @@ IN: unix.users.tests
 
 [ ] [ effective-username [ ] with-effective-user ] unit-test
 [ ] [ effective-user-id [ ] with-effective-user ] unit-test
+
+[ ] [ [ ] with-user-cache ] unit-test
diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor
index eac771160b..f76fbd5388 100644
--- a/basis/unix/users/users.factor
+++ b/basis/unix/users/users.factor
@@ -39,16 +39,16 @@ PRIVATE>
         [ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce
     ] with-pwent ;
 
-SYMBOL: passwd-cache
+SYMBOL: user-cache
 
-: with-passwd-cache ( quot -- )
+: with-user-cache ( quot -- )
     all-users [ [ uid>> ] keep ] H{ } map>assoc
-    passwd-cache swap with-variable ; inline
+    user-cache rot with-variable ; inline
 
 GENERIC: user-passwd ( obj -- passwd )
 
 M: integer user-passwd ( id -- passwd/f )
-    passwd-cache get
+    user-cache get
     [ at ] [ getpwuid passwd>new-passwd ] if* ;
 
 M: string user-passwd ( string -- passwd/f )

From 5c03aad985d3913b9849b551ddee23da35c8c331 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 13:05:26 -0600
Subject: [PATCH 305/318] minor simplification

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

diff --git a/extra/pack/pack.factor b/extra/pack/pack.factor
index 889eecb49a..0e5cb7dbbc 100755
--- a/extra/pack/pack.factor
+++ b/extra/pack/pack.factor
@@ -88,7 +88,7 @@ M: string b, ( n string -- ) heap-size b, ;
 
 : (read-128-ber) ( n -- n )
     read1
-    [ >r 7 shift r> 7 clear-bit bitor ] keep
+    [ [ 7 shift ] [ 7 clear-bit ] bi* bitor ] keep
     7 bit? [ (read-128-ber) ] when ;
     
 : read-128-ber ( -- n )

From 4caf275b1f6e5ab91458b39edf75451d9323a204 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 13:05:48 -0600
Subject: [PATCH 306/318] clean up math.floating-point

---
 .../math/floating-point/floating-point.factor | 44 +++++++++++--------
 1 file changed, 26 insertions(+), 18 deletions(-)

diff --git a/extra/math/floating-point/floating-point.factor b/extra/math/floating-point/floating-point.factor
index 87767181cd..3792d6ba9b 100644
--- a/extra/math/floating-point/floating-point.factor
+++ b/extra/math/floating-point/floating-point.factor
@@ -1,32 +1,40 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences ;
+USING: kernel math sequences prettyprint math.parser io
+math.functions ;
 IN: math.floating-point
 
-: float-sign ( float -- ? )
-    float>bits -31 shift { 1 -1 } nth ; 
+: (double-sign) ( bits -- n ) -63 shift ; inline
+: double-sign ( double -- n ) double>bits (double-sign) ;
 
-: double-sign ( float -- ? )
-    double>bits -63 shift { 1 -1 } nth ;
-
-: float-exponent-bits ( float -- n )
-    float>bits -23 shift 8 2^ 1- bitand ;
+: (double-exponent-bits) ( bits -- n )
+    -52 shift 11 2^ 1- bitand ; inline
 
 : double-exponent-bits ( double -- n )
-    double>bits -52 shift 11 2^ 1- bitand ;
+    double>bits (double-exponent-bits) ;
 
-: float-mantissa-bits ( float -- n )
-    float>bits 23 2^ 1- bitand ;
+: (double-mantissa-bits) ( double -- n )
+    52 2^ 1- bitand ;
 
 : double-mantissa-bits ( double -- n )
-    double>bits 52 2^ 1- bitand ;
+    double>bits (double-mantissa-bits) ;
 
-: float-e ( -- float ) 127 ; inline
-: double-e ( -- float ) 1023 ; inline
+: >double ( S E M -- frac )
+    [ 52 shift ] dip
+    [ 63 shift ] 2dip bitor bitor bits>double ;
 
-! : calculate-float ( S M E -- float )
-    ! float-e - 2^ * * ; ! bits>float ;
+: >double< ( double -- S E M )
+    double>bits
+    [ (double-sign) ]
+    [ (double-exponent-bits) ]
+    [ (double-mantissa-bits) ] tri ;
 
-! : calculate-double ( S M E -- frac )
-    ! double-e - 2^ swap 52 2^ /f 1+ * * ;
+: double. ( double -- )
+    double>bits
+    [ (double-sign) .b ]
+    [ (double-exponent-bits) >bin 11 CHAR: 0 pad-left bl print ]
+    [
+        (double-mantissa-bits) >bin 52 CHAR: 0 pad-left
+        11 [ bl ] times print
+    ] tri ;
 

From d57566496915e0e56f4c819430813e790507ad11 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 13:06:31 -0600
Subject: [PATCH 307/318] add two words to sequences.lib

---
 extra/sequences/lib/lib.factor | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index 6fe3de4f03..9dc01c04fa 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -152,3 +152,6 @@ PRIVATE>
 
 : enumerate ( seq -- seq' ) <enum> >alist ;
 
+: splice ( left-seq right-seq seq -- newseq ) swap 3append ;
+
+: surround ( seq left-seq right-seq -- newseq ) swapd 3append ;

From b502942e1e0711c206655f19993c36b91b7cfc7d Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 13:06:43 -0600
Subject: [PATCH 308/318] cleanups in ftp before going for the juicy meat

---
 extra/ftp/client/client.factor |  6 +++---
 extra/ftp/ftp.factor           | 11 +++++++----
 extra/ftp/server/server.factor | 27 +++++++++++++++------------
 3 files changed, 25 insertions(+), 19 deletions(-)

diff --git a/extra/ftp/client/client.factor b/extra/ftp/client/client.factor
index 9b9a2214c1..8413331c00 100644
--- a/extra/ftp/client/client.factor
+++ b/extra/ftp/client/client.factor
@@ -120,7 +120,7 @@ name target ;
 
 ERROR: ftp-error got expected ;
 : ftp-assert ( ftp-response n -- )
-    2dup >r n>> r> = [ 2drop ] [ ftp-error ] if ;
+    2dup [ n>> ] dip = [ 2drop ] [ ftp-error ] if ;
 
 : ftp-login ( ftp-client -- )
     read-response 220 ftp-assert
@@ -156,12 +156,12 @@ GENERIC: ftp-download ( path obj -- )
     dupd '[
         _ [ ftp-login ] [ @ ] bi
         ftp-quit drop
-    ] >r ftp-connect r> with-stream ; inline
+    ] [ ftp-connect ] dip with-stream ; inline
 
 M: ftp-client ftp-download ( path ftp-client -- )
     [
         [ drop parent-directory ftp-cwd drop ]
-        [ >r file-name r> ftp-get drop ] 2bi
+        [ [ file-name ] dip ftp-get drop ] 2bi
     ] with-ftp-client ;
 
 M: string ftp-download ( path string -- )
diff --git a/extra/ftp/ftp.factor b/extra/ftp/ftp.factor
index 1fd97df6d5..8f0b48bd4d 100644
--- a/extra/ftp/ftp.factor
+++ b/extra/ftp/ftp.factor
@@ -36,7 +36,6 @@ TUPLE: ftp-response n strings parsed ;
 : ftp-ipv4 1 ; inline
 : ftp-ipv6 2 ; inline
 
-
 : ch>type ( ch -- type )
     {
         { CHAR: d [ +directory+ ] }
@@ -54,9 +53,13 @@ TUPLE: ftp-response n strings parsed ;
     } case ;
 
 : file-info>string ( file-info name -- string )
-    >r [ [ type>> type>ch 1string ] [ drop "rwx------" append ] bi ]
-    [ size>> number>string 15 CHAR: \s pad-left ] bi r>
-    3array " " join ;
+    [
+        [
+            [ type>> type>ch 1string ]
+            [ drop "rwx------" append ] bi
+        ]
+        [ size>> number>string 15 CHAR: \s pad-left ] bi
+    ] dip 3array " " join ;
 
 : directory-list ( -- seq )
     "" directory-files
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
index 3ecf8d2f3f..170155bd43 100644
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@@ -6,7 +6,8 @@ io.encodings.utf8 io.files io.sockets kernel math.parser
 namespaces make sequences ftp io.unix.launcher.parser
 unicode.case splitting assocs classes io.servers.connection
 destructors calendar io.timeouts io.streams.duplex threads
-continuations math concurrency.promises byte-arrays ;
+continuations math concurrency.promises byte-arrays sequences.lib
+hexdump ;
 IN: ftp.server
 
 SYMBOL: client
@@ -19,12 +20,14 @@ TUPLE: ftp-command raw tokenized ;
 TUPLE: ftp-get path ;
 
 : <ftp-get> ( path -- obj )
-    ftp-get new swap >>path ;
+    ftp-get new
+        swap >>path ;
 
 TUPLE: ftp-put path ;
 
 : <ftp-put> ( path -- obj )
-    ftp-put new swap >>path ;
+    ftp-put new
+        swap >>path ;
 
 TUPLE: ftp-list ;
 
@@ -62,7 +65,7 @@ C: <ftp-list> ftp-list
 
 : handle-USER ( ftp-command -- )
     [
-        tokenized>> second client get swap >>user drop
+        tokenized>> second client get (>>user)
         331 "Please specify the password." server-response
     ] [
         2drop "bad USER" ftp-error
@@ -70,7 +73,7 @@ C: <ftp-list> ftp-list
 
 : handle-PASS ( ftp-command -- )
     [
-        tokenized>> second client get swap >>password drop
+        tokenized>> second client get (>>password)
         230 "Login successful" server-response
     ] [
         2drop "PASS error" ftp-error
@@ -101,20 +104,20 @@ ERROR: type-error type ;
 
 : handle-PWD ( obj -- )
     drop
-    257 current-directory get "\"" swap "\"" 3append server-response ;
+    257 current-directory get "\"" "\"" surround server-response ;
 
 : handle-SYST ( obj -- )
     drop
     215 "UNIX Type: L8" server-response ;
 
 : if-command-promise ( quot -- )
-    >r client get command-promise>> r>
+    [ client get command-promise>> ] dip
     [ "Establish an active or passive connection first" ftp-error ] if* ;
 
 : handle-STOR ( obj -- )
     [
         tokenized>> second
-        [ >r <ftp-put> r> fulfill ] if-command-promise
+        [ [ <ftp-put> ] dip fulfill ] if-command-promise
     ] [
         2drop
     ] recover ;
@@ -145,7 +148,7 @@ M: ftp-list service-command ( stream obj -- )
     rot   
     [ file-name ] [
         " " swap  file-info size>> number>string
-        "(" " bytes)." swapd 3append append
+        "(" " bytes)." surround append
     ] bi 3append server-response ;
 
 : transfer-incoming-file ( path -- )
@@ -191,7 +194,7 @@ M: ftp-put service-command ( stream obj -- )
 
 : handle-LIST ( obj -- )
     drop
-    [ >r <ftp-list> r> fulfill ] if-command-promise ;
+    [ [ <ftp-list> ] dip fulfill ] if-command-promise ;
 
 : handle-SIZE ( obj -- )
     [
@@ -217,7 +220,7 @@ M: ftp-put service-command ( stream obj -- )
     expect-connection
     [
         "Entering Passive Mode (127,0,0,1," %
-        port>bytes [ number>string ] bi@ "," swap 3append %
+        port>bytes [ number>string ] bi@ "," splice %
         ")" %
     ] "" make 227 swap server-response ;
 
@@ -242,7 +245,7 @@ ERROR: not-a-directory ;
             set-current-directory
             250 "Directory successully changed." server-response
         ] [
-            not-a-directory throw
+            not-a-directory
         ] if
     ] [
         2drop

From 0ad4f276fdf4afba4f0983ae087be209a469c52f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 13:14:39 -0600
Subject: [PATCH 309/318] Add time server demo

---
 extra/time-server/authors.txt              |  1 +
 extra/time-server/time-server-tests.factor |  4 ++++
 extra/time-server/time-server.factor       | 19 +++++++++++++++++++
 3 files changed, 24 insertions(+)
 create mode 100644 extra/time-server/authors.txt
 create mode 100644 extra/time-server/time-server-tests.factor
 create mode 100644 extra/time-server/time-server.factor

diff --git a/extra/time-server/authors.txt b/extra/time-server/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/time-server/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/time-server/time-server-tests.factor b/extra/time-server/time-server-tests.factor
new file mode 100644
index 0000000000..a9fac2d9d8
--- /dev/null
+++ b/extra/time-server/time-server-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test time-server ;
+IN: time-server.tests
diff --git a/extra/time-server/time-server.factor b/extra/time-server/time-server.factor
new file mode 100644
index 0000000000..28debf17cd
--- /dev/null
+++ b/extra/time-server/time-server.factor
@@ -0,0 +1,19 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.servers.connection accessors threads
+calendar calendar.format ;
+IN: time-server
+
+: handle-time-client ( -- )
+    now timestamp>rfc822 print ;
+
+: <time-server> ( -- threaded-server )
+    <threaded-server>
+        "time-server" >>name
+        1234 >>insecure
+        [ handle-time-client ] >>handler ;
+
+: start-time-server ( -- threaded-server )
+    <time-server> [ start-server ] in-thread ;
+
+MAIN: start-time-server

From 482933f4d34cf5f471cfb83bae7b101fdd676048 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 13:19:53 -0600
Subject: [PATCH 310/318] remove duplicated slot from linux statfs

---
 basis/unix/statfs/linux/32/32.factor | 4 ++--
 basis/unix/statfs/linux/64/64.factor | 4 ++--
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/basis/unix/statfs/linux/32/32.factor b/basis/unix/statfs/linux/32/32.factor
index 6658d5942d..fb8c6b5035 100644
--- a/basis/unix/statfs/linux/32/32.factor
+++ b/basis/unix/statfs/linux/32/32.factor
@@ -19,8 +19,8 @@ C-STRUCT: statfs
 FUNCTION: int statfs ( char* path, statfs* buf ) ;
 
 TUPLE: linux32-file-system-info < file-system-info
-type bsize blocks bfree bavail files ffree fsid
-namelen frsize spare ;
+bsize blocks bfree bavail files ffree fsid namelen
+frsize spare ;
 
 M: linux >file-system-info ( struct -- statfs )
     [ \ linux32-file-system-info new ] dip
diff --git a/basis/unix/statfs/linux/64/64.factor b/basis/unix/statfs/linux/64/64.factor
index 3bf2644e12..e9cd5576aa 100644
--- a/basis/unix/statfs/linux/64/64.factor
+++ b/basis/unix/statfs/linux/64/64.factor
@@ -21,8 +21,8 @@ C-STRUCT: statfs64
 FUNCTION: int statfs64 ( char* path, statfs64* buf ) ;
 
 TUPLE: linux64-file-system-info < file-system-info
-type bsize blocks bfree bavail files ffree fsid
-namelen frsize spare ;
+bsize blocks bfree bavail files ffree fsid namelen
+frsize spare ;
 
 M: linux >file-system-info ( struct -- statfs )
     [ \ linux64-file-system-info new ] dip

From bbaa8b95bdf9c1808458679fa6e42f64d15f917a Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 13:30:12 -0600
Subject: [PATCH 311/318] mounted -> file-systems

---
 basis/unix/statfs/linux/linux.factor   | 2 +-
 basis/unix/statfs/macosx/macosx.factor | 2 +-
 basis/unix/statfs/statfs.factor        | 2 +-
 3 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor
index aae8d09145..d2d892cfb7 100644
--- a/basis/unix/statfs/linux/linux.factor
+++ b/basis/unix/statfs/linux/linux.factor
@@ -32,7 +32,7 @@ frequency pass-number ;
     ] with-scope
     [ mtab-csv>mtab-entry ] map ;
 
-M: linux mounted
+M: linux file-systems
     parse-mtab [
         [ mount-point>> file-system-info ] keep
         {
diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor
index 6bf09fcdc0..7c30c4b9d4 100644
--- a/basis/unix/statfs/macosx/macosx.factor
+++ b/basis/unix/statfs/macosx/macosx.factor
@@ -122,7 +122,7 @@ TUPLE: macosx-file-system-info < file-system-info
 block-size io-size blocks blocks-free blocks-available files
 files-free file-system-id owner type-id flags filesystem-subtype ;
 
-M: macosx mounted ( -- array )
+M: macosx file-systems ( -- array )
     f <void*> dup 0 getmntinfo64 dup io-error
     [ *void* ] dip
     "statfs64" heap-size [ * memory>byte-array ] keep group
diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor
index e77ef37b0f..db31dabfa2 100644
--- a/basis/unix/statfs/statfs.factor
+++ b/basis/unix/statfs/statfs.factor
@@ -8,7 +8,7 @@ TUPLE: file-system-info root-directory total-free-size total-size ;
 
 HOOK: >file-system-info os ( struct -- statfs )
 
-HOOK: mounted os ( -- array )
+HOOK: file-systems os ( -- array )
 
 os {
     { linux   [ "unix.statfs.linux"   require ] }

From c860ab78b6b45697ebcf06fb80b013ff796cbd4e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 11 Nov 2008 13:41:34 -0600
Subject: [PATCH 312/318] removed duplicate file-system-info definition. oops

---
 basis/unix/statfs/statfs.factor | 2 --
 1 file changed, 2 deletions(-)

diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor
index db31dabfa2..85734d660d 100644
--- a/basis/unix/statfs/statfs.factor
+++ b/basis/unix/statfs/statfs.factor
@@ -4,8 +4,6 @@ USING: sequences system vocabs.loader combinators accessors
 kernel math.order sorting ;
 IN: unix.statfs
 
-TUPLE: file-system-info root-directory total-free-size total-size ;
-
 HOOK: >file-system-info os ( struct -- statfs )
 
 HOOK: file-systems os ( -- array )

From 78ab09d8bbbd021789600a1c489efb95901ae362 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 14:04:05 -0600
Subject: [PATCH 313/318] move file-systems word to core

---
 basis/unix/statfs/statfs.factor | 2 --
 core/io/files/files.factor      | 2 ++
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/unix/statfs/statfs.factor b/basis/unix/statfs/statfs.factor
index db31dabfa2..ee6ef83430 100644
--- a/basis/unix/statfs/statfs.factor
+++ b/basis/unix/statfs/statfs.factor
@@ -8,8 +8,6 @@ TUPLE: file-system-info root-directory total-free-size total-size ;
 
 HOOK: >file-system-info os ( struct -- statfs )
 
-HOOK: file-systems os ( -- array )
-
 os {
     { linux   [ "unix.statfs.linux"   require ] }
     { macosx  [ "unix.statfs.macosx"  require ] }
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 9899f5a014..ca8125d936 100644
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -184,6 +184,8 @@ SYMBOL: +unknown+
 
 ! File-system
 
+HOOK: file-systems os ( -- array )
+
 TUPLE: file-system-info device-name mount-point type free-space ;
 
 HOOK: file-system-info os ( path -- file-system-info )

From 146340690f812b1ed4ebb45ce27900169d8271da Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 11 Nov 2008 15:17:35 -0600
Subject: [PATCH 314/318] implement file-systems on windows

---
 basis/io/windows/files/files.factor    | 24 +++++++++++++++++++-----
 basis/windows/kernel32/kernel32.factor |  9 ++++++---
 2 files changed, 25 insertions(+), 8 deletions(-)

diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor
index 3952299543..b9b5baa0ca 100755
--- a/basis/io/windows/files/files.factor
+++ b/basis/io/windows/files/files.factor
@@ -276,18 +276,31 @@ M: winnt file-system-info ( path -- file-system-info )
         swap >>type
         swap >>mount-point ;
 
+: volume>paths ( string -- array )
+    16384 "ushort" <c-array> tuck dup length
+    0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
+        win32-error-string throw
+    ] [
+        *uint "ushort" heap-size * head
+        utf16n alien>string CHAR: \0 split
+    ] if ;
+
 : find-first-volume ( -- string handle )
     MAX_PATH 1+ <byte-array> dup length
     dupd
     FindFirstVolume dup win32-error=0/f
     [ utf16n alien>string ] dip ;
 
-: find-next-volume ( handle -- string )
+: find-next-volume ( handle -- string/f )
     MAX_PATH 1+ <byte-array> dup length
-    [ FindNextVolume win32-error=0/f ] 2keep drop
-    utf16n alien>string ;
+    over [ FindNextVolume ] dip swap 0 = [
+        GetLastError ERROR_NO_MORE_FILES =
+        [ drop f ] [ win32-error ] if
+    ] [
+        utf16n alien>string
+    ] if ;
 
-: mounted ( -- array )
+M: winnt file-systems ( -- array )
     find-first-volume
     [
         '[
@@ -296,7 +309,8 @@ M: winnt file-system-info ( path -- file-system-info )
             [ drop ] produce
             swap prefix
         ]
-    ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
+    ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup
+    [ volume>paths ] map ;
 
 : file-times ( path -- timestamp timestamp timestamp )
     [
diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor
index eb90fb522e..462377e85c 100644
--- a/basis/windows/kernel32/kernel32.factor
+++ b/basis/windows/kernel32/kernel32.factor
@@ -954,7 +954,8 @@ ALIAS: GetDiskFreeSpaceEx GetDiskFreeSpaceExW
 ! FUNCTION: GetDllDirectoryA
 ! FUNCTION: GetDllDirectoryW
 ! FUNCTION: GetDriveTypeA
-! FUNCTION: GetDriveTypeW
+FUNCTION: UINT GetDriveTypeW ( LPCTSTR lpRootPathName ) ;
+ALIAS: GetDriveType GetDriveTypeW
 FUNCTION: void* GetEnvironmentStringsW ( ) ;
 ! FUNCTION: GetEnvironmentStringsA
 ALIAS: GetEnvironmentStrings GetEnvironmentStringsW
@@ -999,7 +1000,7 @@ FUNCTION: DWORD GetLastError ( ) ;
 ! FUNCTION: GetLocaleInfoA
 ! FUNCTION: GetLocaleInfoW
 ! FUNCTION: GetLocalTime
-! FUNCTION: GetLogicalDrives
+FUNCTION: DWORD GetLogicalDrives ( ) ;
 ! FUNCTION: GetLogicalDriveStringsA
 ! FUNCTION: GetLogicalDriveStringsW
 ! FUNCTION: GetLongPathNameA
@@ -1129,7 +1130,9 @@ ALIAS: GetVolumeInformation GetVolumeInformationW
 ! FUNCTION: GetVolumeNameForVolumeMountPointW
 ! FUNCTION: GetVolumePathNameA
 ! FUNCTION: GetVolumePathNamesForVolumeNameA
-! FUNCTION: GetVolumePathNamesForVolumeNameW
+FUNCTION: BOOL GetVolumePathNamesForVolumeNameW ( LPCTSTR lpszVolumeName, LPTSTR lpszVolumePathNames, DWORD cchBufferLength, PDWORD lpcchReturnLength ) ;
+ALIAS: GetVolumePathNamesForVolumeName GetVolumePathNamesForVolumeNameW
+
 ! FUNCTION: GetVolumePathNameW
 ! FUNCTION: GetWindowsDirectoryA
 FUNCTION: UINT GetWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;

From 1f85b7ec1459062f40df5faa7ac40eb714946b32 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 11 Nov 2008 15:35:17 -0600
Subject: [PATCH 315/318] catch errors for windows file-systems word and return
 a tuple with just a mount point this happens on empty floppy disk drives

---
 basis/io/windows/files/files.factor | 12 +++++++++---
 1 file changed, 9 insertions(+), 3 deletions(-)

diff --git a/basis/io/windows/files/files.factor b/basis/io/windows/files/files.factor
index b9b5baa0ca..e3b96b98d8 100755
--- a/basis/io/windows/files/files.factor
+++ b/basis/io/windows/files/files.factor
@@ -300,7 +300,7 @@ M: winnt file-system-info ( path -- file-system-info )
         utf16n alien>string
     ] if ;
 
-M: winnt file-systems ( -- array )
+: find-volumes ( -- array )
     find-first-volume
     [
         '[
@@ -309,8 +309,14 @@ M: winnt file-systems ( -- array )
             [ drop ] produce
             swap prefix
         ]
-    ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup
-    [ volume>paths ] map ;
+    ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;
+
+M: winnt file-systems ( -- array )
+    find-volumes [ volume>paths ] map
+    concat [
+        [ file-system-info ]
+        [ drop winnt-file-system-info new swap >>mount-point ] recover
+    ] map ;
 
 : file-times ( path -- timestamp timestamp timestamp )
     [

From fa282c5053fef5c55a7cbf1c949ea0df2e84f70a Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 15:37:32 -0600
Subject: [PATCH 316/318] remove duplicate using

---
 basis/unix/statfs/linux/linux.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor
index d2d892cfb7..43d5a99cd1 100644
--- a/basis/unix/statfs/linux/linux.factor
+++ b/basis/unix/statfs/linux/linux.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types combinators kernel io.files unix.stat
+USING: alien.c-types combinators kernel unix.stat
 math accessors system unix io.backend layouts vocabs.loader
 sequences csv io.streams.string io.encodings.utf8 namespaces
 unix.statfs io.files ;

From 0edfc83d50aaae91e5f9f7b8d6d1640faadd9e7d Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@secrets.local>
Date: Tue, 11 Nov 2008 15:41:27 -0600
Subject: [PATCH 317/318] document file-systems

---
 core/io/files/files-docs.factor | 8 ++++++--
 1 file changed, 6 insertions(+), 2 deletions(-)

diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index 9a85688202..80b515b13f 100644
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -1,5 +1,5 @@
-USING: help.markup help.syntax io strings
-       io.backend io.files.private quotations ;
+USING: help.markup help.syntax io strings arrays io.backend
+io.files.private quotations ;
 IN: io.files
 
 ARTICLE: "file-streams" "Reading and writing files"
@@ -323,6 +323,10 @@ HELP: with-directory-files
 { $values { "path" "a pathname string" } { "quot" quotation } }
 { $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ".  Restores the current directory after the quotation is called." } ;
 
+HELP: file-systems
+{ $values { "array" array } }
+{ $description "Returns an array of " { $link file-system-info } " objects returned by iterating the mount points and calling " { $link file-system-info } " on each." } ;
+
 HELP: file-system-info
 { $values
 { "path" "a pathname string" }

From 5c6860fd0f034a9bb47ff28d47b2cb8dacb1334d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 11 Nov 2008 17:42:52 -0600
Subject: [PATCH 318/318] Updating linked-assocs documentation, add
 <linked-assoc> word

---
 basis/linked-assocs/linked-assocs-docs.factor | 24 +++++++++----------
 basis/linked-assocs/linked-assocs.factor      |  7 ++++--
 2 files changed, 17 insertions(+), 14 deletions(-)

diff --git a/basis/linked-assocs/linked-assocs-docs.factor b/basis/linked-assocs/linked-assocs-docs.factor
index 8f73bdfd36..31f387aeb9 100644
--- a/basis/linked-assocs/linked-assocs-docs.factor
+++ b/basis/linked-assocs/linked-assocs-docs.factor
@@ -2,22 +2,22 @@ IN: linked-assocs
 USING: help.markup help.syntax assocs ;
 
 HELP: linked-assoc
-{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assocs and a dlist.  The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ;
+{ $class-description "The class of linked assocs. Linked assoc are implemented by combining an assoc with a dlist.  The assoc is used for lookup and retrieval of single values, while the dlist is used for getting lists of keys/values, which will be in insertion order." } ;
+
+HELP: <linked-assoc>
+{ $values { "exemplar" "an exemplar assoc" } }
+{ $description "Creates an empty linked assoc backed by a new instance of the same type as the exemplar." } ;
 
 HELP: <linked-hash>
-{ $values { "assoc" "A new linked-assoc" } }
-{ $description "Creates a new, empty linked assoc." } ;
+{ $values { "assoc" linked-assoc } }
+{ $description "Creates an empty linked assoc backed by a hashtable." } ;
 
 ARTICLE: "linked-assocs" "Linked assocs"
-"A " { $emphasis "linked assoc" } " is an assoc which combines a hash table and a dlist to form a structure which has the insertion and retrieval characteristics of a hash table, but with the ability to get the items in insertion order."
+"A " { $emphasis "linked assoc" } " is an assoc which combines an underlying assoc with a dlist to form a structure which has the insertion and retrieval characteristics of the underlying assoc (typically a hashtable), but with the ability to get the entries in insertion order by calling " { $link >alist } "."
 $nl
-"Linked assocs implement the following methods from the assoc protocol:"
-{ $subsection at* }
-{ $subsection assoc-size }
-{ $subsection >alist }
-{ $subsection set-at }
-{ $subsection delete-at }
-{ $subsection clear-assoc }
-{ $subsection >alist } ;
+"Linked assocs are implemented in the " { $vocab-link "linked-assocs" } " vocabulary."
+{ $subsection linked-assoc }
+{ $subsection <linked-hash> }
+{ $subsection <linked-assoc> } ;
 
 ABOUT: "linked-assocs"
\ No newline at end of file
diff --git a/basis/linked-assocs/linked-assocs.factor b/basis/linked-assocs/linked-assocs.factor
index 54f4be7269..7330ac1a56 100644
--- a/basis/linked-assocs/linked-assocs.factor
+++ b/basis/linked-assocs/linked-assocs.factor
@@ -1,12 +1,15 @@
 ! Copyright (C) 2008 Slava Pestov, James Cash.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs arrays kernel deques dlists sequences hashtables fry ;
+USING: accessors assocs arrays kernel deques dlists sequences fry ;
 IN: linked-assocs
 
 TUPLE: linked-assoc assoc dlist ;
 
+: <linked-assoc> ( exemplar -- assoc )
+    0 swap new-assoc <dlist> linked-assoc boa ;
+
 : <linked-hash> ( -- assoc )
-    0 <hashtable> <dlist> linked-assoc boa ;
+    H{ } <linked-assoc> ;
 
 M: linked-assoc assoc-size assoc>> assoc-size ;