From 2d07fd6826cd46c63784e046352721a1ca5d9827 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 8 Aug 2008 13:14:36 -0500
Subject: [PATCH 1/9] Tuple unboxing progress

---
 basis/disjoint-sets/disjoint-sets.factor      |   4 +
 .../compiler/tree/cleanup/cleanup.factor      |  13 +-
 .../tree/dead-code/dead-code-tests.factor     |  23 ++--
 .../compiler/tree/dead-code/dead-code.factor  |  79 ++++++-----
 .../allocations/allocations.factor            |  59 +++++----
 .../escape-analysis-tests.factor              |  11 ++
 .../escape-analysis/escape-analysis.factor    |   1 +
 .../recursive/recursive-tests.factor          |   2 +-
 .../recursive/recursive.factor                |  20 ++-
 .../tree/escape-analysis/simple/simple.factor |  36 +++--
 .../tree/intrinsics/intrinsics.factor         |   6 +
 .../tuple-unboxing-tests.factor               |  31 +++++
 .../tree/tuple-unboxing/tuple-unboxing.factor | 125 ++++++++----------
 13 files changed, 248 insertions(+), 162 deletions(-)
 create mode 100644 unfinished/compiler/tree/intrinsics/intrinsics.factor
 create mode 100644 unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor
index 680103f188..f48129fbd4 100644
--- a/basis/disjoint-sets/disjoint-sets.factor
+++ b/basis/disjoint-sets/disjoint-sets.factor
@@ -66,6 +66,10 @@ M: disjoint-set add-atom
 
 : add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
 
+GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
+
+M: disjoint-set disjoint-set-member? parents>> key? ;
+
 GENERIC: equiv-set-size ( a disjoint-set -- n )
 
 M: disjoint-set equiv-set-size [ representative ] keep count ;
diff --git a/unfinished/compiler/tree/cleanup/cleanup.factor b/unfinished/compiler/tree/cleanup/cleanup.factor
index 08fd12f177..45a916b984 100644
--- a/unfinished/compiler/tree/cleanup/cleanup.factor
+++ b/unfinished/compiler/tree/cleanup/cleanup.factor
@@ -2,8 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sequences.deep combinators fry
 classes.algebra namespaces assocs math math.private
-math.partial-dispatch
+math.partial-dispatch classes.tuple classes.tuple.private
 compiler.tree
+compiler.tree.intrinsics
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.propagation.branches ;
@@ -53,11 +54,21 @@ GENERIC: cleanup* ( node -- node/nodes )
 : remove-overflow-check ( #call -- #call )
     [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
 
+: immutable-tuple-boa? ( #call -- ? )
+    dup word>> \ <tuple-boa> eq? [
+        dup in-d>> peek node-value-info
+        literal>> class>> immutable-tuple-class?
+    ] [ drop f ] if ;
+
+: immutable-tuple-boa ( #call -- #call )
+    \ <immutable-tuple-boa> >>word ;
+
 M: #call cleanup*
     {
         { [ dup body>> ] [ cleanup-inlining ] }
         { [ dup cleanup-folding? ] [ cleanup-folding ] }
         { [ dup remove-overflow-check? ] [ remove-overflow-check ] }
+        { [ dup immutable-tuple-boa? ] [ immutable-tuple-boa ] }
         [ ]
     } cond ;
 
diff --git a/unfinished/compiler/tree/dead-code/dead-code-tests.factor b/unfinished/compiler/tree/dead-code/dead-code-tests.factor
index 51a34bcd50..7b0919562f 100644
--- a/unfinished/compiler/tree/dead-code/dead-code-tests.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code-tests.factor
@@ -1,7 +1,7 @@
 USING: namespaces assocs sequences compiler.tree.builder
 compiler.tree.dead-code compiler.tree.def-use compiler.tree
 compiler.tree.combinators tools.test kernel math
-stack-checker.state accessors ;
+stack-checker.state accessors combinators ;
 IN: compiler.tree.dead-code.tests
 
 \ remove-dead-code must-infer
@@ -10,20 +10,27 @@ IN: compiler.tree.dead-code.tests
     build-tree
     compute-def-use
     remove-dead-code
-    compute-def-use
-    0 swap [ dup #push? [ out-d>> length + ] [ drop ] if ] each-node ;
+    0 swap [
+        {
+            { [ dup #push? ] [ out-d>> length + ] }
+            { [ dup #introduce? ] [ drop 1 + ] }
+            [ drop ]
+        } cond
+    ] each-node ;
 
 [ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test
 
+[ 1 ] [ [ drop ] count-live-values ] unit-test
+
 [ 0 ] [ [ 1 drop ] count-live-values ] unit-test
 
 [ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test
 
-[ 2 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
+[ 3 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
 
-[ 0 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
+[ 1 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
 
-[ 0 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
+[ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
 
 [ 2 ] [ [ 1 2 + ] count-live-values ] unit-test
 
@@ -33,9 +40,9 @@ IN: compiler.tree.dead-code.tests
 
 [ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
 
-[ 3 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
+[ 4 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
 
-[ 0 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
+[ 1 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
 
 [ 0 ] [ [ [ ] call ] count-live-values ] unit-test
 
diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor
index ccf8a9cd09..6703f924fd 100644
--- a/unfinished/compiler/tree/dead-code/dead-code.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code.factor
@@ -3,15 +3,18 @@
 USING: fry accessors namespaces assocs dequeues search-dequeues
 kernel sequences words sets stack-checker.inlining
 compiler.tree
+compiler.tree.combinators
 compiler.tree.dataflow-analysis
-compiler.tree.dataflow-analysis.backward
-compiler.tree.combinators ;
+compiler.tree.dataflow-analysis.backward ;
 IN: compiler.tree.dead-code
 
 ! Dead code elimination: remove #push and flushable #call whose
 ! outputs are unused using backward DFA.
 GENERIC: mark-live-values ( node -- )
 
+M: #introduce mark-live-values
+    value>> look-at-value ;
+
 M: #if mark-live-values look-at-inputs ;
 
 M: #dispatch mark-live-values look-at-inputs ;
@@ -34,9 +37,6 @@ SYMBOL: live-values
 
 GENERIC: remove-dead-values* ( node -- )
 
-M: #introduce remove-dead-values*
-    [ [ live-value? ] filter ] change-values drop ;
-
 M: #>r remove-dead-values*
     dup out-r>> first live-value? [ { } >>out-r ] unless
     dup in-d>> first live-value? [ { } >>in-d ] unless
@@ -57,6 +57,30 @@ M: #push remove-dead-values*
 : filter-live ( values -- values' )
     [ live-value? ] filter ;
 
+M: #call remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
+M: #recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    drop ;
+
+M: #call-recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
+M: #enter-recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
+M: #return-recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
 M: #shuffle remove-dead-values*
     [ filter-live ] change-in-d
     [ filter-live ] change-out-d
@@ -92,24 +116,19 @@ M: #phi remove-dead-values*
 
 M: node remove-dead-values* drop ;
 
-M: f remove-dead-values* drop ;
+: remove-dead-values ( nodes -- )
+    [ remove-dead-values* ] each-node ;
 
-GENERIC: remove-dead-nodes* ( node -- newnode/t )
+GENERIC: remove-dead-nodes* ( node -- node/f )
 
-: prune-if-empty ( node seq -- successor/t )
-    empty? [ successor>> ] [ drop t ] if ; inline
+: prune-if-empty ( node seq -- node/f )
+    empty? [ drop f ] when ; inline
 
-M: #introduce remove-dead-nodes* dup values>> prune-if-empty ;
-
-: live-call? ( #call -- ? )
-    out-d>> [ live-value? ] contains? ;
+: live-call? ( #call -- ? ) out-d>> [ live-value? ] contains? ;
 
 M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ;
 
-M: #call remove-dead-nodes*
-    dup live-call? [ drop t ] [
-        [ in-d>> #drop ] [ successor>> ] bi >>successor
-    ] if ;
+M: #call remove-dead-nodes* dup live-call? [ in-d>> #drop ] unless ;
 
 M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
 
@@ -121,25 +140,13 @@ M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
 
 M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
 
-: (remove-dead-code) ( node -- newnode )
-    [
-        dup remove-dead-values*
-        dup remove-dead-nodes* dup t eq?
-        [ drop ] [ nip (remove-dead-code) ] if
-    ] transform-nodes ;
+M: node remove-dead-nodes* ;
 
-M: #if remove-dead-nodes*
-    [ (remove-dead-code) ] map-children t ;
-
-M: #dispatch remove-dead-nodes*
-    [ (remove-dead-code) ] map-children t ;
-
-M: #recursive remove-dead-nodes*
-    [ (remove-dead-code) ] change-child drop t ;
-
-M: node remove-dead-nodes* drop t ;
-
-M: f remove-dead-nodes* drop t ;
+: remove-dead-nodes ( nodes -- nodes' )
+    [ remove-dead-nodes* ] map-nodes ;
 
 : remove-dead-code ( node -- newnode )
-    [ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;
+    [ compute-live-values ]
+    [ remove-dead-values ]
+    [ remove-dead-nodes ]
+    tri ;
diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
index 973720c388..2296afebc4 100644
--- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -9,21 +9,13 @@ IN: compiler.tree.escape-analysis.allocations
 !        may potentially become an allocation later
 ! - a sequence of values -- potentially unboxed tuple allocations
 ! - t -- not allocated in this procedure, can never be unboxed
-
 SYMBOL: allocations
 
-TUPLE: slot-access slot# value ;
-
-C: <slot-access> slot-access
-
 : (allocation) ( value -- value' allocations )
     allocations get ; inline
 
 : allocation ( value -- allocation )
-    (allocation) at dup slot-access? [
-        [ slot#>> ] [ value>> allocation ] bi nth
-        allocation
-    ] when ;
+    (allocation) at ;
 
 : record-allocation ( allocation value -- )
     (allocation) set-at ;
@@ -31,6 +23,17 @@ C: <slot-access> slot-access
 : record-allocations ( allocations values -- )
     [ record-allocation ] 2each ;
 
+! We track slot access to connect constructor inputs with
+! accessor outputs.
+SYMBOL: slot-accesses
+
+TUPLE: slot-access slot# value ;
+
+C: <slot-access> slot-access
+
+: record-slot-access ( out slot# in -- )
+    <slot-access> swap slot-accesses get set-at ;
+
 ! We track escaping values with a disjoint set.
 SYMBOL: escaping-values
 
@@ -43,18 +46,15 @@ SYMBOL: +escaping+
     <escaping-values> escaping-values set ;
 
 : introduce-value ( values -- )
-    escaping-values get add-atom ;
+    escaping-values get
+    2dup disjoint-set-member?
+    [ 2drop ] [ add-atom ] if ;
 
 : introduce-values ( values -- )
-    escaping-values get add-atoms ;
+    [ introduce-value ] each ;
 
 : <slot-value> ( -- value )
-    <value> dup escaping-values get add-atom ;
-
-: record-slot-access ( out slot# in -- )
-    over zero? [ 3drop ] [
-        <slot-access> swap record-allocation
-    ] if ;
+    <value> dup introduce-value ;
 
 : merge-values ( in-values out-value -- )
     escaping-values get '[ , , equate ] each ;
@@ -66,11 +66,17 @@ SYMBOL: +escaping+
     escaping-values get equate ;
 
 : add-escaping-value ( value -- )
-    +escaping+ equate-values ;
+    [
+        allocation {
+            { [ dup not ] [ drop ] }
+            { [ dup t eq? ] [ drop ] }
+            [ [ add-escaping-value ] each ]
+        } cond
+    ]
+    [ +escaping+ equate-values ] bi ;
 
 : add-escaping-values ( values -- )
-    escaping-values get
-    '[ +escaping+ , equate ] each ;
+    [ add-escaping-value ] each ;
 
 : unknown-allocation ( value -- )
     [ add-escaping-value ]
@@ -97,6 +103,14 @@ DEFER: copy-value
     [ [ allocation copy-allocation ] dip record-allocation ]
     2bi ;
 
+: copy-slot-value ( out slot# in -- )
+    allocation {
+        { [ dup not ] [ 3drop ] }
+        { [ dup t eq? ] [ 3drop ] }
+        [ nth swap copy-value ]
+    } cond ;
+
+! Compute which tuples escape
 SYMBOL: escaping-allocations
 
 : compute-escaping-allocations ( -- )
@@ -111,6 +125,5 @@ SYMBOL: escaping-allocations
     dup escaping-allocation? [ drop f ] [ allocation ] if ;
 
 : unboxed-slot-access? ( value -- ? )
-    (allocation) at dup slot-access?
-    [ value>> unboxed-allocation >boolean ] [ drop f ] if ;
-
+    slot-accesses get at*
+    [ value>> unboxed-allocation >boolean ] when ;
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
index f01949d422..a0c27ac069 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -217,6 +217,11 @@ C: <ro-box> ro-box
 
 [ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
 
+: tuple-fib' ( m -- n )
+    dup 1 <= [ 1- tuple-fib' i>> ] when <ro-box> ; inline recursive
+
+[ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test
+
 : bad-tuple-fib-1 ( m -- n )
     dup i>> 1 <= [
         drop 1 <ro-box>
@@ -283,3 +288,9 @@ C: <ro-box> ro-box
 [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
 
 [ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ 1 cons boa 2 cons boa car>> ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ 1 cons boa 2 cons boa dup . car>> ] count-unboxed-allocations ] unit-test
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
index 5847f0a5e4..f515641343 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
@@ -16,5 +16,6 @@ IN: compiler.tree.escape-analysis
 : escape-analysis ( node -- node )
     init-escaping-values
     H{ } clone allocations set
+    H{ } clone slot-accesses set
     dup (escape-analysis)
     compute-escaping-allocations ;
diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
index 1f6f347ded..033d5b01cc 100644
--- a/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
@@ -4,7 +4,7 @@ compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.allocations ;
 
 H{ } clone allocations set
-H{ } clone copies set
+<escaping-values> escaping-values set
 
 [ ] [ 8 [ introduce-value ] each ] unit-test
 
diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
index e72f4b6a45..604bed6b6d 100644
--- a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
+++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
@@ -29,10 +29,12 @@ IN: compiler.tree.escape-analysis.recursive
     out-d>> [ allocation ] map ;
 
 : recursive-stacks ( #enter-recursive -- stacks )
-    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
+    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix
+    escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
+    flip ;
 
 : analyze-recursive-phi ( #enter-recursive -- )
-    [ ] [ recursive-stacks flip ] [ out-d>> ] tri
+    [ ] [ recursive-stacks ] [ out-d>> ] tri
     [ [ merge-values ] 2each ]
     [
         [ (merge-allocations) ] dip
@@ -44,11 +46,16 @@ IN: compiler.tree.escape-analysis.recursive
 M: #recursive escape-analysis* ( #recursive -- )
     [
         child>>
+        [ first out-d>> introduce-values ]
         [ first analyze-recursive-phi ]
         [ (escape-analysis) ]
-        bi
+        tri
     ] until-fixed-point ;
 
+M: #enter-recursive escape-analysis* ( #enter-recursive -- )
+    #! Handled by #recursive
+    drop ;
+
 : return-allocations ( node -- allocations )
     label>> return>> node-input-allocations ;
 
@@ -57,5 +64,8 @@ M: #call-recursive escape-analysis* ( #call-label -- )
     [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
 
 M: #return-recursive escape-analysis* ( #return-recursive -- )
-    [ in-d>> ] [ label>> calls>> ] bi
-    [ out-d>> escaping-values get '[ , equate ] 2each ] with each ;
+    [ call-next-method ]
+    [
+        [ in-d>> ] [ label>> calls>> ] bi
+        [ out-d>> escaping-values get '[ , equate ] 2each ] with each
+    ] bi ;
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index 22daa36644..d7699cfc73 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -5,6 +5,7 @@ classes.tuple.private arrays math math.private slots.private
 combinators dequeues search-dequeues namespaces fry classes
 classes.algebra stack-checker.state
 compiler.tree
+compiler.tree.intrinsics
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
@@ -23,33 +24,24 @@ DEFER: record-literal-allocation
 : make-literal-slots ( seq -- values )
     [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
 
-: record-literal-tuple-allocation ( value object -- )
-    tuple-slots rest-slice
-    make-literal-slots
-    swap record-allocation ;
-
-: record-literal-complex-allocation ( value object -- )
-    [ real-part ] [ imaginary-part ] bi 2array make-literal-slots
-    swap record-allocation ;
+: object-slots ( object -- slots/f )
+    #! Delegation
+    {
+        { [ dup class immutable-tuple-class? ] [ tuple-slots rest-slice ] }
+        { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
+        [ drop f ]
+    } cond ;
 
 : record-literal-allocation ( value object -- )
-    {
-        { [ dup class immutable-tuple-class? ] [ record-literal-tuple-allocation ] }
-        { [ dup complex? ] [ record-literal-complex-allocation ] }
-        [ drop unknown-allocation ]
-    } cond ;
+    object-slots dup
+    [ make-literal-slots swap record-allocation ] [ 2drop ] if ;
 
 M: #push escape-analysis*
     #! Delegation.
     [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
 
 : record-tuple-allocation ( #call -- )
-    #! Delegation.
-    dup dup in-d>> peek node-value-info literal>>
-    class>> immutable-tuple-class? [
-        [ in-d>> but-last ] [ out-d>> first ] bi
-        record-allocation
-    ] [ out-d>> unknown-allocations ] if ;
+    [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ;
 
 : record-complex-allocation ( #call -- )
     [ in-d>> ] [ out-d>> first ] bi record-allocation ;
@@ -68,11 +60,13 @@ M: #push escape-analysis*
 
 : record-slot-call ( #call -- )
     [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
-    over [ record-slot-access ] [ 2drop unknown-allocation ] if ;
+    over [
+        [ record-slot-access ] [ copy-slot-value ] 3bi
+    ] [ 2drop unknown-allocation ] if ;
 
 M: #call escape-analysis*
     dup word>> {
-        { \ <tuple-boa> [ record-tuple-allocation ] }
+        { \ <immutable-tuple-boa> [ record-tuple-allocation ] }
         { \ <complex> [ record-complex-allocation ] }
         { \ slot [ record-slot-call ] }
         [
diff --git a/unfinished/compiler/tree/intrinsics/intrinsics.factor b/unfinished/compiler/tree/intrinsics/intrinsics.factor
new file mode 100644
index 0000000000..a3328114bd
--- /dev/null
+++ b/unfinished/compiler/tree/intrinsics/intrinsics.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: compiler.tree.intrinsics
+
+: <immutable-tuple-boa> ( ... class -- tuple ) "Intrinsic" throw ;
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
new file mode 100644
index 0000000000..df721f0c6c
--- /dev/null
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
@@ -0,0 +1,31 @@
+IN: compiler.tree.tuple-unboxing.tests
+USING: tools.test compiler.tree.tuple-unboxing
+compiler.tree compiler.tree.builder compiler.tree.normalization
+compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.escape-analysis compiler.tree.tuple-unboxing
+compiler.tree.def-use kernel accessors sequences math ;
+
+\ unbox-tuples must-infer
+
+: test-unboxing ( quot -- )
+    #! Just make sure it doesn't throw errors; compute def use
+    #! for kicks.
+    build-tree
+    normalize
+    propagate
+    cleanup
+    escape-analysis
+    unbox-tuples
+    compute-def-use
+    drop ;
+
+TUPLE: cons { car read-only } { cdr read-only } ;
+
+TUPLE: empty-tuple ;
+
+{
+    [ empty-tuple boa drop ]
+    [ cons boa [ car>> ] [ cdr>> ] bi ]
+    [ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
+    [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
+} [ [ ] swap [ test-unboxing ] curry unit-test ] each
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 6b49502722..81933c37dc 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -1,56 +1,41 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs accessors kernel combinators
+classes.algebra sequences sequences.deep slots.private
+classes.tuple.private math math.private arrays
+compiler.tree
+compiler.tree.intrinsics
+compiler.tree.combinators
+compiler.tree.escape-analysis.simple
+compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.tuple-unboxing
 
 ! This pass must run after escape analysis
 
-! Mapping from values to sequences of values
-SYMBOL: unboxed-tuples
+GENERIC: unbox-tuples* ( node -- node/nodes )
 
-: unboxed-tuple ( value -- unboxed-tuple )
-    unboxed-tuples get at ;
-
-GENERIC: unbox-tuples* ( node -- )
-
-: value-info-slots ( info -- slots )
-    #! Delegation.
-    [ info>> ] [ class>> ] bi {
-        { [ dup tuple class<= ] [ drop 2 tail ] }
-        { [ dup complex class<= ] [ drop ] }
-    } cond ;
-
-: prepare-unboxed-values ( #push -- values )
+: unbox-output? ( node -- values )
     out-d>> first unboxed-allocation ;
 
-: prepare-unboxed-info ( #push -- infos values )
-    dup prepare-unboxed-values dup
-    [ [ node-output-infos first value-info-slots ] dip ]
-    [ 2drop f f ]
-    if ;
+: (expand-#push) ( object value -- nodes )
+    dup unboxed-allocation dup [
+        [ object-slots ] [ drop ] [ ] tri*
+        [ (expand-#push) ] 2map
+    ] [
+        drop #push
+    ] if ;
 
-: expand-#push ( #push infos values -- )
-    [ [ literal>> ] dip #push ] 2map >>body drop ;
+: expand-#push ( #push -- nodes )
+    [ literal>> ] [ out-d>> first ] bi (expand-#push) ;
 
-M: #push unbox-tuples* ( #push -- )
-    dup prepare-unboxed-info dup [ expand-#push ] [ 3drop ] if ;
+M: #push unbox-tuples* ( #push -- nodes )
+    dup unbox-output? [ expand-#push ] when ;
 
-: expand-<tuple-boa> ( #call values -- quot )
-    [ drop in-d>> peek #drop ]
-    [ [ in-d>> but-last ] dip #copy ]
-    2bi 2array ;
+: unbox-<tuple-boa> ( #call -- nodes )
+    dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
 
-: expand-<complex> ( #call values -- quot )
-    [ in-d>> ] dip #copy 1array ;
-
-: expand-constructor ( #call values -- )
-    [ drop ] [ ] [ drop word>> ] 2tri {
-        { <tuple-boa> [ expand-<tuple-boa> ] }
-        { <complex> [ expand-<complex> ] }
-    } case unbox-tuples >>body ;
-
-: unbox-constructor ( #call -- )
-    dup prepare-unboxed-values dup
-    [ expand-constructor ] [ 2drop ] if ;
+: unbox-<complex> ( #call -- nodes )
+    dup unbox-output? [ drop { } ] when ;
 
 : (flatten-values) ( values -- values' )
     [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
@@ -59,51 +44,57 @@ M: #push unbox-tuples* ( #push -- )
     (flatten-values) flatten ;
 
 : flatten-value ( values -- values )
-    1array flatten-values ;
+    [ unboxed-allocation ] [ 1array ] bi or ;
 
-: prepare-slot-access ( #call -- tuple-values slot-values outputs )
+: prepare-slot-access ( #call -- tuple-values outputs slot-values )
     [ in-d>> first flatten-value ]
-    [
-        [ dup in-d>> second node-value-info literal>> ]
-        [ out-d>> first unboxed-allocation ]
-        bi nth flatten-value
-    ]
     [ out-d>> flatten-values ]
-    tri ;
+    [
+        out-d>> first slot-accesses get at
+        [ slot#>> ] [ value>> ] bi allocation nth flatten-value
+    ] tri ;
 
-: slot-access-shuffle ( tuple-values slot-values outputs -- #shuffle )
-    [ nip ] [ zip ] 2bi #shuffle ;
+: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
+    [ drop ] [ zip ] 2bi #shuffle ;
 
-: unbox-slot-access ( #call -- )
-    dup unboxed-slot-access? [
-        dup
+: unbox-slot-access ( #call -- nodes )
+    dup out-d>> first unboxed-slot-access? [
         [ in-d>> second 1array #drop ]
         [ prepare-slot-access slot-access-shuffle ]
-        bi 2array unbox-tuples >>body
-    ] when drop ;
+        bi 2array
+    ] when ;
 
-M: #call unbox-tuples* ( #call -- )
+M: #call unbox-tuples*
     dup word>> {
-        { \ <tuple-boa> [ unbox-<tuple-boa> ] }
+        { \ <immutable-tuple-boa> [ unbox-<tuple-boa> ] }
         { \ <complex> [ unbox-<complex> ] }
         { \ slot [ unbox-slot-access ] }
-        [ 2drop ]
+        [ drop ]
     } case ;
 
-M: #copy ... ;
+M: #copy unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d ;
 
-M: #>r ... ;
+M: #>r unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-r ;
 
-M: #r> ... ;
+M: #r> unbox-tuples*
+    [ flatten-values ] change-in-r
+    [ flatten-values ] change-out-d ;
 
-M: #shuffle ... ;
+M: #shuffle unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d
+    [ unzip [ flatten-values ] bi@ zip ] change-mapping ;
 
-M: #terrible ... ;
+M: #terminate unbox-tuples*
+    [ flatten-values ] change-in-d ;
 
 ! These nodes never participate in unboxing
-M: #return drop ;
+M: #return unbox-tuples* ;
 
-M: #introduce drop ;
+M: #introduce unbox-tuples* ;
 
-: unbox-tuples ( nodes -- nodes )
-    dup [ unbox-tuples* ] each-node ;
+: unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;

From 63bc32eda31debf6e349455d99b5fcc54ca5628d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 8 Aug 2008 16:04:33 -0500
Subject: [PATCH 2/9] More unboxing work

---
 .../tuple-unboxing-tests.factor               |  6 ++-
 .../tree/tuple-unboxing/tuple-unboxing.factor | 37 +++++++++++++++++--
 2 files changed, 39 insertions(+), 4 deletions(-)

diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
index df721f0c6c..5b06b37638 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
@@ -3,7 +3,8 @@ USING: tools.test compiler.tree.tuple-unboxing
 compiler.tree compiler.tree.builder compiler.tree.normalization
 compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.escape-analysis compiler.tree.tuple-unboxing
-compiler.tree.def-use kernel accessors sequences math ;
+compiler.tree.def-use kernel accessors sequences math
+sorting math.order binary-search ;
 
 \ unbox-tuples must-infer
 
@@ -24,8 +25,11 @@ TUPLE: cons { car read-only } { cdr read-only } ;
 TUPLE: empty-tuple ;
 
 {
+    [ 1 2 cons boa [ car>> ] [ cdr>> ] bi ]
     [ empty-tuple boa drop ]
     [ cons boa [ car>> ] [ cdr>> ] bi ]
     [ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
     [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
+    [ [ <=> ] sort ]
+    [ [ <=> ] with search ]
 } [ [ ] swap [ test-unboxing ] curry unit-test ] each
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 81933c37dc..71ff79d95b 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -72,6 +72,9 @@ M: #call unbox-tuples*
         [ drop ]
     } case ;
 
+M: #declare unbox-tuples*
+    [ unzip [ flatten-values ] dip zip ] change-declaration ;
+
 M: #copy unbox-tuples*
     [ flatten-values ] change-in-d
     [ flatten-values ] change-out-d ;
@@ -92,9 +95,37 @@ M: #shuffle unbox-tuples*
 M: #terminate unbox-tuples*
     [ flatten-values ] change-in-d ;
 
-! These nodes never participate in unboxing
-M: #return unbox-tuples* ;
+M: #phi unbox-tuples*
+    [ flip [ flatten-values ] map flip ] change-phi-in-d
+    [ flip [ flatten-values ] map flip ] change-phi-in-r
+    [ flatten-values ] change-out-d
+    [ flatten-values ] change-out-r ;
 
-M: #introduce unbox-tuples* ;
+M: #recursive unbox-tuples*
+    [ flatten-values ] change-in-d ;
+
+M: #enter-recursive unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d ;
+
+M: #call-recursive unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d ;
+
+M: #return-recursive unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d ;
+
+! These nodes never participate in unboxing
+: assert-not-unboxed ( values -- )
+    dup array?
+    [ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if
+    [ "Unboxing wrong value" throw ] when ;
+
+M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+M: #introduce unbox-tuples* dup value>> assert-not-unboxed ;
 
 : unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;

From b5473d7f142b098c2355aa3002edd09373114fd6 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Sat, 9 Aug 2008 12:40:17 -0400
Subject: [PATCH 3/9] Persistent deques

---
 basis/persistent/deques/authors.txt         |  1 +
 basis/persistent/deques/deques-docs.factor  | 56 +++++++++++++++
 basis/persistent/deques/deques-tests.factor | 35 ++++++++++
 basis/persistent/deques/deques.factor       | 76 +++++++++++++++++++++
 basis/persistent/deques/summary.txt         |  1 +
 basis/persistent/deques/tags.txt            |  1 +
 6 files changed, 170 insertions(+)
 create mode 100644 basis/persistent/deques/authors.txt
 create mode 100644 basis/persistent/deques/deques-docs.factor
 create mode 100644 basis/persistent/deques/deques-tests.factor
 create mode 100644 basis/persistent/deques/deques.factor
 create mode 100644 basis/persistent/deques/summary.txt
 create mode 100644 basis/persistent/deques/tags.txt

diff --git a/basis/persistent/deques/authors.txt b/basis/persistent/deques/authors.txt
new file mode 100644
index 0000000000..f990dd0ed2
--- /dev/null
+++ b/basis/persistent/deques/authors.txt
@@ -0,0 +1 @@
+Daniel Ehrenberg
diff --git a/basis/persistent/deques/deques-docs.factor b/basis/persistent/deques/deques-docs.factor
new file mode 100644
index 0000000000..56ee46a6a9
--- /dev/null
+++ b/basis/persistent/deques/deques-docs.factor
@@ -0,0 +1,56 @@
+USING: help.markup help.syntax kernel sequences ;
+IN: persistent.deques
+
+ARTICLE: "persistent.deques" "Persistent deques"
+"A deque is a data structure that can be used as both a queue and a stack. That is, there are two ends, the left and the right, and values can be pushed onto and popped off of both ends. These operations take O(1) amortized time and space in a normal usage pattern."
+$nl
+"This vocabulary provides a deque implementation which is persistent and purely functional: old versions of deques are not modified by operations. Instead, each push and pop operation creates a new deque based off the old one."
+$nl
+"The class of persistent deques:"
+{ $subsection deque }
+"To create a deque:"
+{ $subsection <deque> }
+{ $subsection sequence>deque }
+"To test if a deque is empty:"
+{ $subsection deque-empty? }
+"To manipulate deques:"
+{ $subsection push-left }
+{ $subsection push-right }
+{ $subsection pop-left }
+{ $subsection pop-right }
+{ $subsection deque>sequence } ;
+
+HELP: deque
+{ $class-description "This is the class of persistent (functional) double-ended queues. All deque operations can be done in O(1) amortized time for single-threaded access while maintaining the old version. For more information, see " { $link "persistent.deques" } "." } ;
+
+HELP: <deque>
+{ $values { "deque" "an empty deque" } }
+{ $description "Creates an empty deque." } ;
+
+HELP: sequence>deque
+{ $values { "sequence" sequence } { "deque" deque } }
+{ $description "Given a sequence, creates a deque containing those elements in the order such that the beginning of the sequence is on the left and the end is on the right." } ;
+
+HELP: deque>sequence
+{ $values { "deque" deque } { "sequence" sequence } }
+{ $description "Given a deque, creates a sequence containing those elements, such that the left side of the deque is the beginning of the sequence." } ;
+
+HELP: deque-empty?
+{ $values { "deque" deque } { "?" "t/f" } }
+{ $description "Returns true if the deque is empty. This takes constant time." } ;
+
+HELP: push-left
+{ $values { "deque" deque } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the given object pushed onto the left side. This takes constant time." } ;
+
+HELP: push-right
+{ $values { "deque" deque } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the given object pushed onto the right side. This takes constant time." } ;
+
+HELP: pop-left
+{ $values { "deque" object } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the leftmost item removed. This takes amortized constant time with single-threaded access." } ;
+
+HELP: pop-right
+{ $values { "deque" object } { "item" object } { "newdeque" deque } }
+{ $description "Creates a new deque with the rightmost item removed. This takes amortized constant time with single-threaded access." } ;
diff --git a/basis/persistent/deques/deques-tests.factor b/basis/persistent/deques/deques-tests.factor
new file mode 100644
index 0000000000..353828cb14
--- /dev/null
+++ b/basis/persistent/deques/deques-tests.factor
@@ -0,0 +1,35 @@
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test persistent.deques kernel math ;
+IN: persistent.deques.tests
+
+[ 3 2 1 t ]
+[ { 1 2 3 } sequence>deque 3 [ pop-right ] times deque-empty? ] unit-test
+
+[ 1 2 3 t ]
+[ { 1 2 3 } sequence>deque 3 [ pop-left ] times deque-empty? ] unit-test
+
+[ 1 3 2 t ]
+[ { 1 2 3 } sequence>deque pop-left 2 [ pop-right ] times deque-empty? ]
+unit-test
+
+[ { 2 3 4 5 6 1 } ]
+[ { 1 2 3 4 5 6 } sequence>deque pop-left swap push-right deque>sequence ]
+unit-test
+
+[ 1 t ] [ <deque> 1 push-left pop-right deque-empty? ] unit-test
+[ 1 t ] [ <deque> 1 push-left pop-left deque-empty? ] unit-test
+[ 1 t ] [ <deque> 1 push-right pop-left deque-empty? ] unit-test
+[ 1 t ] [ <deque> 1 push-right pop-right deque-empty? ] unit-test
+
+[ 1 f ]
+[ <deque> 1 push-left 2 push-left pop-right deque-empty? ] unit-test
+
+[ 1 f ]
+[ <deque> 1 push-right 2 push-right pop-left deque-empty? ] unit-test
+
+[ 2 f ]
+[ <deque> 1 push-right 2 push-right pop-right deque-empty? ] unit-test
+
+[ 2 f ]
+[ <deque> 1 push-left 2 push-left pop-left deque-empty? ] unit-test
diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor
new file mode 100644
index 0000000000..b30153aada
--- /dev/null
+++ b/basis/persistent/deques/deques.factor
@@ -0,0 +1,76 @@
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math qualified ;
+QUALIFIED: sequences
+IN: persistent.deques
+
+! Amortized O(1) push/pop on both ends for single-threaded access
+! In a pathological case, if there are m modified versions from the
+!   same source, it could take O(m) amortized time per update.
+
+<PRIVATE
+TUPLE: cons { car read-only } { cdr read-only } ;
+C: <cons> cons
+
+: each ( list quot -- )
+    over
+    [ [ >r car>> r> call ] [ >r cdr>> r> ] 2bi each ]
+    [ 2drop ] if ; inline
+
+: reduce ( list start quot -- end )
+    swapd each ; inline
+
+: reverse ( list -- reversed )
+    f [ swap <cons> ] reduce ;
+
+: length ( list -- length )
+    0 [ drop 1+ ] reduce ;
+
+: cut ( list index -- back front-reversed )
+    f swap [ >r [ cdr>> ] [ car>> ] bi r> <cons> ] times ;
+
+: split-reverse ( list -- back-reversed front )
+    dup length 2/ cut [ reverse ] bi@ ;
+PRIVATE>
+
+TUPLE: deque { lhs read-only } { rhs read-only } ;
+: <deque> ( -- deque ) T{ deque } ;
+
+: deque-empty? ( deque -- ? )
+    [ lhs>> ] [ rhs>> ] bi or not ;
+
+: push-left ( deque item -- newdeque )
+    swap [ lhs>> <cons> ] [ rhs>> ] bi deque boa ;
+
+: push-right ( deque item -- newdeque )
+    swap [ rhs>> <cons> ] [ lhs>> ] bi swap deque boa ;
+
+<PRIVATE
+: (pop-left) ( deque -- item newdeque )
+    [ lhs>> car>> ] [ [ lhs>> cdr>> ] [ rhs>> ] bi deque boa ] bi ;
+
+: transfer-left ( deque -- item newdeque )
+    rhs>> [ split-reverse deque boa (pop-left) ]
+    [ "Popping from an empty deque" throw ] if* ;
+PRIVATE>
+
+: pop-left ( deque -- item newdeque )
+    dup lhs>> [ (pop-left) ] [ transfer-left ] if ;
+
+<PRIVATE
+: (pop-right) ( deque -- item newdeque )
+    [ rhs>> car>> ] [ [ lhs>> ] [ rhs>> cdr>> ] bi deque boa ] bi ;
+
+: transfer-right ( deque -- newdeque item )
+    lhs>> [ split-reverse deque boa (pop-left) ]
+    [ "Popping from an empty deque" throw ] if* ;
+PRIVATE>
+
+: pop-right ( deque -- item newdeque )
+    dup rhs>> [ (pop-right) ] [ transfer-right ] if ;
+
+: sequence>deque ( sequence -- deque )
+    <deque> [ push-right ] sequences:reduce ;
+
+: deque>sequence ( deque -- sequence )
+    [ dup deque-empty? not ] [ pop-left swap ] [ ] sequences:produce nip ;
diff --git a/basis/persistent/deques/summary.txt b/basis/persistent/deques/summary.txt
new file mode 100644
index 0000000000..021a1e3fef
--- /dev/null
+++ b/basis/persistent/deques/summary.txt
@@ -0,0 +1 @@
+Persistent amortized O(1) deques
diff --git a/basis/persistent/deques/tags.txt b/basis/persistent/deques/tags.txt
new file mode 100644
index 0000000000..42d711b32b
--- /dev/null
+++ b/basis/persistent/deques/tags.txt
@@ -0,0 +1 @@
+collections

From ca57e4386cdc39f8ae9cff36c33ce35cab2381b1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 9 Aug 2008 23:00:27 -0500
Subject: [PATCH 4/9] Various fixes

---
 .../compiler/tree/checker/checker.factor      | 61 +++++++++++++++++++
 .../compiler/tree/cleanup/cleanup.factor      |  5 +-
 .../dataflow-analysis.factor                  |  7 ++-
 .../tree/def-use/def-use-tests.factor         | 22 +++++--
 .../compiler/tree/def-use/def-use.factor      | 20 +++---
 .../escape-analysis/branches/branches.factor  |  6 +-
 .../escape-analysis-tests.factor              |  5 +-
 .../recursive/recursive.factor                |  9 ++-
 .../tree/escape-analysis/simple/simple.factor |  6 +-
 .../normalization/normalization-tests.factor  |  4 +-
 .../tree/normalization/normalization.factor   | 12 +++-
 .../tree/propagation/branches/branches.factor | 16 +++--
 .../tree/propagation/copy/copy.factor         |  3 +-
 .../propagation/recursive/recursive.factor    |  2 +-
 .../tuple-unboxing-tests.factor               | 20 +++---
 .../tree/tuple-unboxing/tuple-unboxing.factor | 18 +++---
 .../stack-checker/branches/branches.factor    | 21 +++++--
 17 files changed, 173 insertions(+), 64 deletions(-)
 create mode 100644 unfinished/compiler/tree/checker/checker.factor

diff --git a/unfinished/compiler/tree/checker/checker.factor b/unfinished/compiler/tree/checker/checker.factor
new file mode 100644
index 0000000000..08beec8b8f
--- /dev/null
+++ b/unfinished/compiler/tree/checker/checker.factor
@@ -0,0 +1,61 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel sets namespaces accessors assocs
+arrays combinators continuations
+compiler.tree
+compiler.tree.def-use
+compiler.tree.combinators ;
+IN: compiler.tree.checker
+
+! Check some invariants.
+ERROR: check-use-error value message ;
+
+: check-use ( value uses -- )
+    [ empty? [ "No use" check-use-error ] [ drop ] if ]
+    [ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ;
+
+: check-def-use ( -- )
+    def-use get [ uses>> check-use ] assoc-each ;
+
+GENERIC: check-node ( node -- )
+
+M: #shuffle check-node
+    [ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
+    [ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
+    bi ;
+
+: check-lengths ( seq -- )
+    [ length ] map all-equal? [ "Bad lengths" throw ] unless ;
+
+M: #copy check-node inputs/outputs 2array check-lengths ;
+
+M: #>r check-node inputs/outputs 2array check-lengths ;
+
+M: #r> check-node inputs/outputs 2array check-lengths ;
+
+M: #return-recursive check-node inputs/outputs 2array check-lengths ;
+
+M: #phi check-node
+    {
+        [ [ phi-in-d>> ] [ out-d>> ] bi 2array check-lengths ]
+        [ [ phi-in-r>> ] [ out-r>> ] bi 2array check-lengths ]
+        [ phi-in-d>> check-lengths ]
+        [ phi-in-r>> check-lengths ]
+    } cleave ;
+
+M: #enter-recursive check-node
+    [ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
+    [ [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix check-lengths ]
+    bi ;
+
+M: #push check-node
+    out-d>> length 1 = [ "Bad #push" throw ] unless ;
+
+M: node check-node drop ;
+
+ERROR: check-node-error node error ;
+
+: check-nodes ( nodes -- )
+    compute-def-use
+    check-def-use
+    [ [ check-node ] [ check-node-error ] recover ] each-node ;
diff --git a/unfinished/compiler/tree/cleanup/cleanup.factor b/unfinished/compiler/tree/cleanup/cleanup.factor
index 45a916b984..1ea31fe815 100644
--- a/unfinished/compiler/tree/cleanup/cleanup.factor
+++ b/unfinished/compiler/tree/cleanup/cleanup.factor
@@ -105,10 +105,10 @@ SYMBOL: live-branches
 
 M: #branch cleanup*
     {
-        [ live-branches>> live-branches set ]
         [ delete-unreachable-branches ]
         [ cleanup-children ]
         [ fold-only-branch ]
+        [ live-branches>> live-branches set ]
     } cleave ;
 
 : cleanup-phi-in ( phi-in live-branches -- phi-in' )
@@ -122,7 +122,8 @@ M: #phi cleanup*
         [ '[ , cleanup-phi-in ] change-phi-in-r ]
         [ '[ , cleanup-phi-in ] change-phi-info-d ]
         [ '[ , cleanup-phi-in ] change-phi-info-r ]
-    } cleave ;
+    } cleave
+    live-branches off ;
 
 : >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;
 
diff --git a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
index c7d558f4bf..54b10e9612 100644
--- a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
+++ b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors namespaces assocs dequeues search-dequeues
-kernel sequences words sets stack-checker.inlining compiler.tree
-compiler.tree.def-use compiler.tree.combinators ;
+kernel sequences words sets
+stack-checker.branches stack-checker.inlining
+compiler.tree compiler.tree.def-use compiler.tree.combinators ;
 IN: compiler.tree.dataflow-analysis
 
 ! Dataflow analysis
@@ -34,5 +35,5 @@ SYMBOL: work-list
 : dfa ( node mark-quot iterate-quot -- assoc )
     init-dfa
     [ each-node ] dip
-    work-list get H{ { f f } } clone
+    work-list get H{ { +bottom+ f } } clone
     [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline
diff --git a/unfinished/compiler/tree/def-use/def-use-tests.factor b/unfinished/compiler/tree/def-use/def-use-tests.factor
index 34e28761ac..88172443ad 100755
--- a/unfinished/compiler/tree/def-use/def-use-tests.factor
+++ b/unfinished/compiler/tree/def-use/def-use-tests.factor
@@ -1,7 +1,9 @@
 USING: accessors namespaces assocs kernel sequences math
 tools.test words sets combinators.short-circuit
 stack-checker.state compiler.tree compiler.tree.builder
-compiler.tree.def-use arrays kernel.private ;
+compiler.tree.normalization compiler.tree.propagation
+compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
+sorting math.order binary-search compiler.tree.checker ;
 IN: compiler.tree.def-use.tests
 
 \ compute-def-use must-infer
@@ -14,8 +16,16 @@ IN: compiler.tree.def-use.tests
     } 1&&
 ] unit-test
 
-! compute-def-use checks for SSA violations, so we make sure
-! some common patterns are generated correctly.
+: test-def-use ( quot -- )
+    build-tree
+    normalize
+    propagate
+    cleanup
+    compute-def-use
+    check-nodes ;
+
+! compute-def-use checks for SSA violations, so we use that to
+! ensure we generate some common patterns correctly.
 {
     [ [ drop ] each-integer ]
     [ [ 2drop ] curry each-integer ]
@@ -28,6 +38,10 @@ IN: compiler.tree.def-use.tests
     [ [ 1 ] 2 [ + ] curry compose call + ]
     [ [ 1 ] [ call 2 ] curry call + ]
     [ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
+    [ dup slice? [ dup array? [ ] [ ] if ] [ ] if ]
+    [ dup [ drop f ] [ "A" throw ] if ]
+    [ [ <=> ] sort ]
+    [ [ <=> ] with search ]
 } [
-    [ ] swap [ build-tree compute-def-use drop ] curry unit-test
+    [ ] swap [ test-def-use ] curry unit-test
 ] each
diff --git a/unfinished/compiler/tree/def-use/def-use.factor b/unfinished/compiler/tree/def-use/def-use.factor
index 189dd292a2..c0cc240fd4 100755
--- a/unfinished/compiler/tree/def-use/def-use.factor
+++ b/unfinished/compiler/tree/def-use/def-use.factor
@@ -1,8 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays namespaces assocs sequences kernel generic assocs
-classes vectors accessors combinators sets stack-checker.state
-compiler.tree compiler.tree.combinators ;
+classes vectors accessors combinators sets
+stack-checker.state
+stack-checker.branches
+compiler.tree
+compiler.tree.combinators ;
 IN: compiler.tree.def-use
 
 SYMBOL: def-use
@@ -37,7 +40,8 @@ M: #introduce node-uses-values drop f ;
 M: #push node-uses-values drop f ;
 M: #r> node-uses-values in-r>> ;
 M: #phi node-uses-values
-    [ phi-in-d>> ] [ phi-in-r>> ] bi append concat sift prune ;
+    [ phi-in-d>> ] [ phi-in-r>> ] bi
+    append concat remove-bottom prune ;
 M: #declare node-uses-values declaration>> keys ;
 M: node node-uses-values in-d>> ;
 
@@ -57,14 +61,6 @@ M: node node-defs-values out-d>> ;
     [ dup node-uses-values [ use-value ] with each ]
     [ dup node-defs-values [ def-value ] with each ] bi ;
 
-: check-use ( uses -- )
-    [ empty? [ "No use" throw ] when ]
-    [ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
-
-: check-def-use ( -- )
-    def-use get [ nip uses>> check-use ] assoc-each ;
-
 : compute-def-use ( node -- node )
     H{ } clone def-use set
-    dup [ node-def-use ] each-node
-    check-def-use ;
+    dup [ node-def-use ] each-node ;
diff --git a/unfinished/compiler/tree/escape-analysis/branches/branches.factor b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
index 391649fcb2..910726e069 100644
--- a/unfinished/compiler/tree/escape-analysis/branches/branches.factor
+++ b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
@@ -9,7 +9,9 @@ compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.branches
 
 M: #branch escape-analysis*
-    live-children sift [ (escape-analysis) ] each ;
+    [ in-d>> add-escaping-values ]
+    [ live-children sift [ (escape-analysis) ] each ]
+    bi ;
 
 : (merge-allocations) ( values -- allocation )
     [
@@ -25,7 +27,7 @@ M: #branch escape-analysis*
     ] map ;
 
 : merge-allocations ( in-values out-values -- )
-    [ [ sift ] map ] dip
+    [ [ remove-bottom ] map ] dip
     [ [ merge-values ] 2each ]
     [ [ (merge-allocations) ] dip record-allocations ]
     2bi ;
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
index a0c27ac069..532c5a9ac3 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -5,7 +5,8 @@ compiler.tree.normalization 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 ;
+prettyprint classes.tuple.private classes classes.tuple
+compiler.tree.intrinsics ;
 
 \ escape-analysis must-infer
 
@@ -15,7 +16,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
     out-d>> first escaping-allocation? [ 1+ ] unless ;
 
 M: #call count-unboxed-allocations*
-    dup word>> { <tuple-boa> <complex> } memq?
+    dup word>> { <immutable-tuple-boa> <complex> } memq?
     [ (count-unboxed-allocations) ] [ drop ] if ;
 
 M: #push count-unboxed-allocations*
diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
index 604bed6b6d..1ea89787df 100644
--- a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
+++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
@@ -18,9 +18,7 @@ IN: compiler.tree.escape-analysis.recursive
     } cond ;
 
 : check-fixed-point ( node alloc1 alloc2 -- )
-    [ congruent? ] 2all? [ drop ] [
-        label>> f >>fixed-point drop
-    ] if ;
+    [ congruent? ] 2all? [ drop ] [ label>> f >>fixed-point drop ] if ;
 
 : node-input-allocations ( node -- allocations )
     in-d>> [ allocation ] map ;
@@ -44,13 +42,14 @@ IN: compiler.tree.escape-analysis.recursive
     ] 2bi ;
 
 M: #recursive escape-analysis* ( #recursive -- )
-    [
+    { 0 } clone [ USE: math
+        dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
         child>>
         [ first out-d>> introduce-values ]
         [ first analyze-recursive-phi ]
         [ (escape-analysis) ]
         tri
-    ] until-fixed-point ;
+    ] curry until-fixed-point ;
 
 M: #enter-recursive escape-analysis* ( #enter-recursive -- )
     #! Handled by #recursive
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index d7699cfc73..c6c407b048 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -33,8 +33,10 @@ DEFER: record-literal-allocation
     } cond ;
 
 : record-literal-allocation ( value object -- )
-    object-slots dup
-    [ make-literal-slots swap record-allocation ] [ 2drop ] if ;
+    object-slots
+    [ make-literal-slots swap record-allocation ]
+    [ unknown-allocation ]
+    if* ;
 
 M: #push escape-analysis*
     #! Delegation.
diff --git a/unfinished/compiler/tree/normalization/normalization-tests.factor b/unfinished/compiler/tree/normalization/normalization-tests.factor
index 91c11f3be6..6986439dcc 100644
--- a/unfinished/compiler/tree/normalization/normalization-tests.factor
+++ b/unfinished/compiler/tree/normalization/normalization-tests.factor
@@ -1,6 +1,6 @@
 IN: compiler.tree.normalization.tests
 USING: compiler.tree.builder compiler.tree.normalization
-compiler.tree sequences accessors tools.test kernel ;
+compiler.tree sequences accessors tools.test kernel math ;
 
 \ count-introductions must-infer
 \ fixup-enter-recursive must-infer
@@ -25,3 +25,5 @@ compiler.tree sequences accessors tools.test kernel ;
     [ recursive-inputs ]
     [ normalize recursive-inputs ] bi
 ] unit-test
+
+[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test
diff --git a/unfinished/compiler/tree/normalization/normalization.factor b/unfinished/compiler/tree/normalization/normalization.factor
index 4eb28be917..285964e393 100644
--- a/unfinished/compiler/tree/normalization/normalization.factor
+++ b/unfinished/compiler/tree/normalization/normalization.factor
@@ -1,7 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry namespaces sequences math accessors kernel arrays
-stack-checker.backend stack-checker.inlining compiler.tree
+stack-checker.backend
+stack-checker.branches
+stack-checker.inlining
+compiler.tree
 compiler.tree.combinators ;
 IN: compiler.tree.normalization
 
@@ -97,7 +100,12 @@ M: #branch eliminate-introductions*
     bi ;
 
 : eliminate-phi-introductions ( introductions seq terminated -- seq' )
-    [ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ;
+    [ flip ] dip [
+        [ nip ] [
+            dup [ +bottom+ eq? ] left-trim
+            [ [ length ] bi@ - tail* ] keep append
+        ] if
+    ] 3map flip ;
 
 M: #phi eliminate-introductions*
     remaining-introductions get swap dup terminated>>
diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor
index 00a7833655..25b4775b8e 100644
--- a/unfinished/compiler/tree/propagation/branches/branches.factor
+++ b/unfinished/compiler/tree/propagation/branches/branches.factor
@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry kernel sequences assocs accessors namespaces
 math.intervals arrays classes.algebra combinators
+stack-checker.branches
 compiler.tree
 compiler.tree.def-use
 compiler.tree.combinators
@@ -59,7 +60,14 @@ SYMBOL: infer-children-data
 
 : compute-phi-input-infos ( phi-in -- phi-info )
     infer-children-data get
-    '[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ;
+    '[
+        , [
+            [
+                dup +bottom+ eq?
+                [ drop null-info ] [ value-info ] if
+            ] bind
+        ] 2map
+    ] map ;
 
 : annotate-phi-inputs ( #phi -- )
     dup phi-in-d>> compute-phi-input-infos >>phi-info-d
@@ -139,10 +147,10 @@ M: #phi propagate-before ( #phi -- )
 M: #phi propagate-after ( #phi -- )
     condition-value get [
         [ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
-        3array flip [
-            first3 [ possible-boolean-values ] map
+        [
+            [ possible-boolean-values ] map
             branch-phi-constraints
-        ] each
+        ] 3each
     ] [ drop ] if ;
 
 M: #phi propagate-around ( #phi -- )
diff --git a/unfinished/compiler/tree/propagation/copy/copy.factor b/unfinished/compiler/tree/propagation/copy/copy.factor
index ee2d6e7415..1f4e5c0a86 100644
--- a/unfinished/compiler/tree/propagation/copy/copy.factor
+++ b/unfinished/compiler/tree/propagation/copy/copy.factor
@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences assocs math kernel accessors fry
 combinators sets locals
+stack-checker.branches
 compiler.tree
 compiler.tree.def-use
 compiler.tree.combinators ;
@@ -42,7 +43,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
     #! An output is a copy of every input if all inputs are
     #! copies of the same original value.
     [
-        swap sift [ resolve-copy ] map
+        swap remove-bottom [ resolve-copy ] map
         dup [ all-equal? ] [ empty? not ] bi and
         [ first swap is-copy-of ] [ 2drop ] if
     ] 2each ;
diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor
index 0e3af85b20..6b266c4ea8 100644
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor
@@ -39,7 +39,7 @@ IN: compiler.tree.propagation.recursive
 : unify-recursive-stacks ( stacks initial -- infos )
     over empty? [ nip ] [
         [
-            [ sift value-infos-union ] dip
+            [ value-infos-union ] dip
             [ generalize-counter ] keep
             value-info-union
         ] 2map
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
index 5b06b37638..0dd8f3e3de 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
@@ -1,24 +1,22 @@
 IN: compiler.tree.tuple-unboxing.tests
-USING: tools.test compiler.tree.tuple-unboxing
-compiler.tree compiler.tree.builder compiler.tree.normalization
+USING: tools.test compiler.tree.tuple-unboxing compiler.tree
+compiler.tree.builder compiler.tree.normalization
 compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.escape-analysis compiler.tree.tuple-unboxing
-compiler.tree.def-use kernel accessors sequences math
-sorting math.order binary-search ;
+compiler.tree.checker compiler.tree.def-use kernel accessors
+sequences math math.private sorting math.order binary-search
+sequences.private slots.private ;
 
 \ unbox-tuples must-infer
 
 : test-unboxing ( quot -- )
-    #! Just make sure it doesn't throw errors; compute def use
-    #! for kicks.
     build-tree
     normalize
     propagate
     cleanup
     escape-analysis
     unbox-tuples
-    compute-def-use
-    drop ;
+    check-nodes ;
 
 TUPLE: cons { car read-only } { cdr read-only } ;
 
@@ -30,6 +28,12 @@ TUPLE: empty-tuple ;
     [ cons boa [ car>> ] [ cdr>> ] bi ]
     [ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
     [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
+    [ 2 cons boa { [ ] [ ] } dispatch ]
+    [ dup [ drop f ] [ "A" throw ] if ]
+    [ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ]
+    [ [ ] [ ] curry curry call ]
+    [ <complex> <complex> dup 1 slot drop 2 slot drop ]
+    [ 1 cons boa over [ "A" throw ] when car>> ]
     [ [ <=> ] sort ]
     [ [ <=> ] with search ]
 } [ [ ] swap [ test-unboxing ] curry unit-test ] each
diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 71ff79d95b..3b832917d8 100644
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -3,6 +3,7 @@
 USING: namespaces assocs accessors kernel combinators
 classes.algebra sequences sequences.deep slots.private
 classes.tuple.private math math.private arrays
+stack-checker.branches
 compiler.tree
 compiler.tree.intrinsics
 compiler.tree.combinators
@@ -43,15 +44,13 @@ M: #push unbox-tuples* ( #push -- nodes )
 : flatten-values ( values -- values' )
     (flatten-values) flatten ;
 
-: flatten-value ( values -- values )
-    [ unboxed-allocation ] [ 1array ] bi or ;
-
 : prepare-slot-access ( #call -- tuple-values outputs slot-values )
-    [ in-d>> first flatten-value ]
+    [ in-d>> flatten-values ]
     [ out-d>> flatten-values ]
     [
         out-d>> first slot-accesses get at
-        [ slot#>> ] [ value>> ] bi allocation nth flatten-value
+        [ slot#>> ] [ value>> ] bi allocation nth
+        1array flatten-values
     ] tri ;
 
 : slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
@@ -73,7 +72,8 @@ M: #call unbox-tuples*
     } case ;
 
 M: #declare unbox-tuples*
-    [ unzip [ flatten-values ] dip zip ] change-declaration ;
+    #! We don't look at declarations after propagation anyway.
+    f >>declaration ;
 
 M: #copy unbox-tuples*
     [ flatten-values ] change-in-d
@@ -96,9 +96,9 @@ M: #terminate unbox-tuples*
     [ flatten-values ] change-in-d ;
 
 M: #phi unbox-tuples*
-    [ flip [ flatten-values ] map flip ] change-phi-in-d
-    [ flip [ flatten-values ] map flip ] change-phi-in-r
-    [ flatten-values ] change-out-d
+    [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-d
+    [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-r
+    [ flatten-values ] change-out-d 
     [ flatten-values ] change-out-r ;
 
 M: #recursive unbox-tuples*
diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor
index c4a89deb05..72a32574e1 100644
--- a/unfinished/stack-checker/branches/branches.factor
+++ b/unfinished/stack-checker/branches/branches.factor
@@ -9,21 +9,30 @@ IN: stack-checker.branches
 : balanced? ( pairs -- ? )
     [ second ] filter [ first2 length - ] map all-equal? ;
 
-: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
-    dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
+SYMBOL: +bottom+
 
-: pad-with-f ( seq -- newseq )
-    dup [ length ] map supremum '[ , f pad-left ] map ;
+: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
+    dup [ [ - +bottom+ <repetition> ] dip append ] [ 3drop f ] if ;
+
+: pad-with-bottom ( seq -- newseq )
+    dup empty? [
+        dup [ length ] map supremum
+        '[ , +bottom+ pad-left ] map
+    ] unless ;
 
 : phi-inputs ( max-d-in pairs -- newseq )
     dup empty? [ nip ] [
         swap '[ , _ first2 unify-inputs ] map
-        pad-with-f
+        pad-with-bottom
         flip
     ] if ;
 
+: remove-bottom ( seq -- seq' )
+    +bottom+ swap remove ;
+
 : unify-values ( values -- phi-out )
-    sift dup empty? [ drop <value> ] [
+    remove-bottom
+    dup empty? [ drop <value> ] [
         [ known ] map dup all-eq?
         [ first make-known ] [ drop <value> ] if
     ] if ;

From 4cf2b064c52934010843d1fda61a251919e37114 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 01:58:39 -0500
Subject: [PATCH 5/9] Loop detection

---
 .../loop/detection/detection-tests.factor     | 150 ++++++++++++++++++
 .../tree/loop/detection/detection.factor      | 102 +++++++++++-
 .../stack-checker/inlining/inlining.factor    |  12 +-
 3 files changed, 259 insertions(+), 5 deletions(-)
 create mode 100644 unfinished/compiler/tree/loop/detection/detection-tests.factor

diff --git a/unfinished/compiler/tree/loop/detection/detection-tests.factor b/unfinished/compiler/tree/loop/detection/detection-tests.factor
new file mode 100644
index 0000000000..5864dc368f
--- /dev/null
+++ b/unfinished/compiler/tree/loop/detection/detection-tests.factor
@@ -0,0 +1,150 @@
+IN: compiler.tree.loop.detection.tests
+USING: compiler.tree.loop.detection tools.test
+kernel combinators.short-circuit math sequences accessors
+compiler.tree
+compiler.tree.builder
+compiler.tree.combinators ;
+
+[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test
+[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test
+[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
+[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
+
+\ detect-loops must-infer
+
+: label-is-loop? ( nodes word -- ? )
+    [
+        {
+            [ drop #recursive? ]
+            [ drop label>> loop?>> ]
+            [ swap label>> word>> eq? ]
+        } 2&&
+    ] curry contains-node? ;
+
+\ label-is-loop? must-infer
+
+: label-is-not-loop? ( nodes word -- ? )
+    [
+        {
+            [ drop #recursive? ]
+            [ drop label>> loop?>> not ]
+            [ swap label>> word>> eq? ]
+        } 2&&
+    ] curry contains-node? ;
+
+\ label-is-not-loop? must-infer
+
+: loop-test-1 ( a -- )
+    dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
+                          
+[ t ] [
+    [ loop-test-1 ] build-tree detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ loop-test-1 1 2 3 ] build-tree detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ [ loop-test-1 ] each ] build-tree detect-loops
+    \ loop-test-1 label-is-loop?
+] unit-test
+
+[ t ] [
+    [ [ loop-test-1 ] each ] build-tree detect-loops
+    \ (each-integer) label-is-loop?
+] unit-test
+
+: loop-test-2 ( a -- )
+    dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
+
+[ t ] [
+    [ loop-test-2 ] build-tree detect-loops
+    \ loop-test-2 label-is-not-loop?
+] unit-test
+
+: loop-test-3 ( a -- )
+    dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive
+
+[ t ] [
+    [ loop-test-3 ] build-tree detect-loops
+    \ loop-test-3 label-is-not-loop?
+] unit-test
+
+: loop-test-4 ( a -- )
+    dup [
+        loop-test-4
+    ] [
+        drop
+    ] if ; inline recursive
+
+[ f ] [
+    [ [ [ ] map ] map ] build-tree detect-loops
+    [
+        dup #recursive? [ label>> loop?>> not ] [ drop f ] if
+    ] contains-node?
+] unit-test
+
+: blah f ;
+
+DEFER: a
+
+: b ( -- )
+    blah [ b ] [ a ] if ; inline recursive
+
+: a ( -- )
+    blah [ b ] [ a ] if ; inline recursive
+
+[ t ] [
+    [ a ] build-tree detect-loops
+    \ a label-is-loop?
+] unit-test
+
+[ t ] [
+    [ a ] build-tree detect-loops
+    \ b label-is-loop?
+] unit-test
+
+[ t ] [
+    [ b ] build-tree detect-loops
+    \ a label-is-loop?
+] unit-test
+
+[ t ] [
+    [ a ] build-tree detect-loops
+    \ b label-is-loop?
+] unit-test
+
+DEFER: a'
+
+: b' ( -- )
+    blah [ b' b' ] [ a' ] if ; inline recursive
+
+: a' ( -- )
+    blah [ b' ] [ a' ] if ; inline recursive
+
+[ f ] [
+    [ a' ] build-tree detect-loops
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ b' ] build-tree detect-loops
+    \ b' label-is-loop?
+] unit-test
+
+! I used to think this should be f, but doing this on pen and
+! paper almost convinced me that a loop conversion here is
+! sound.
+
+[ t ] [
+    [ b' ] build-tree detect-loops
+    \ a' label-is-loop?
+] unit-test
+
+[ f ] [
+    [ a' ] build-tree detect-loops
+    \ b' label-is-loop?
+] unit-test
diff --git a/unfinished/compiler/tree/loop/detection/detection.factor b/unfinished/compiler/tree/loop/detection/detection.factor
index e29ae22f0d..1c881e9ee4 100644
--- a/unfinished/compiler/tree/loop/detection/detection.factor
+++ b/unfinished/compiler/tree/loop/detection/detection.factor
@@ -1,5 +1,103 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.loop-detection
+USING: kernel sequences namespaces assocs accessors fry
+compiler.tree ;
+IN: compiler.tree.loop.detection
 
-: detect-loops ( nodes -- nodes' ) ;
+! A loop is a #recursive which only tail calls itself, and those
+! calls are nested inside other loops only.
+
+TUPLE: recursive-call tail? nesting ;
+
+! calls is a sequence of recursive-call instances
+TUPLE: loop-info calls height ;
+
+! Mapping inline-recursive instances to loop-info instances
+SYMBOL: loop-infos
+
+! A sequence of inline-recursive instances
+SYMBOL: label-stack
+
+: (tail-calls) ( tail? seq -- seq' )
+    reverse [ swap [ and ] keep ] map nip reverse ;
+
+: tail-calls ( tail? node -- seq )
+    [
+        [ #phi? ]
+        [ #return? ]
+        [ #return-recursive? ]
+        tri or or
+    ] map (tail-calls) ;
+
+GENERIC: collect-loop-info* ( tail? node -- )
+
+: non-tail-label-info ( nodes -- )
+    [ f swap collect-loop-info* ] each ;
+
+: (collect-loop-info) ( tail? nodes -- )
+    [ tail-calls ] keep [ collect-loop-info* ] 2each ;
+
+: remember-loop-info ( #recursive -- )
+    V{ } clone label-stack get length loop-info boa
+    swap label>> loop-infos get set-at ;
+
+M: #recursive collect-loop-info*
+    nip
+    [
+        [ label-stack [ swap label>> suffix ] change ]
+        [ remember-loop-info ]
+        [ t swap child>> (collect-loop-info) ]
+        tri
+    ] with-scope ;
+
+M: #call-recursive collect-loop-info*
+    label>> loop-infos get at
+    [ label-stack get swap height>> tail recursive-call boa ]
+    [ calls>> ]
+    bi push ;
+
+M: #if collect-loop-info*
+    children>> [ (collect-loop-info) ] with each ;
+
+M: #dispatch collect-loop-info*
+    children>> [ (collect-loop-info) ] with each ;
+
+M: node collect-loop-info* 2drop ;
+
+: collect-loop-info ( node -- )
+    { } label-stack set
+    H{ } clone loop-infos set
+    t swap (collect-loop-info) ;
+
+! Sub-assoc of loop-infos
+SYMBOL: potential-loops
+
+: remove-non-tail-calls ( -- )
+    loop-infos get
+    [ nip calls>> [ tail?>> ] all? ] assoc-filter
+    potential-loops set ;
+
+: (remove-non-loop-calls) ( loop-infos -- )
+    f over [
+        ! If label X is called from within a label Y that is
+        ! no longer a potential loop, then X is no longer a
+        ! potential loop either.
+        over potential-loops get key? [
+            potential-loops get '[ , key? ] all?
+            [ drop ] [ potential-loops get delete-at t or ] if
+        ] [ 2drop ] if
+    ] assoc-each
+    [ (remove-non-loop-calls) ] [ drop ] if ;
+
+: remove-non-loop-calls ( -- )
+    ! Boolean is set to t if something changed.
+    !  We recurse until a fixed point is reached.
+    loop-infos get [ calls>> [ nesting>> ] map concat ] assoc-map
+    (remove-non-loop-calls) ;
+
+: detect-loops ( nodes -- nodes )
+    dup
+    collect-loop-info
+    remove-non-tail-calls
+    remove-non-loop-calls
+    potential-loops get [ drop t >>loop? drop ] assoc-each ;
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index 155baa7e65..6442bc5740 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -17,15 +17,21 @@ IN: stack-checker.inlining
 : (inline-word) ( word label -- )
     [ [ def>> ] keep ] dip infer-quot-recursive ;
 
-TUPLE: inline-recursive
+TUPLE: inline-recursive < identity-tuple
+id
 word
 enter-out enter-recursive
 return calls
 fixed-point
-introductions ;
+introductions
+loop? ;
+
+M: inline-recursive hashcode* id>> hashcode* ;
 
 : <inline-recursive> ( word -- label )
-    inline-recursive new swap >>word ;
+    inline-recursive new
+        gensym >>id
+        swap >>word ;
 
 : quotation-param? ( obj -- ? )
     dup pair? [ second effect? ] [ drop f ] if ;

From 215f6ef65b9ac75ffdf690c79abda92997e6d3f1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 01:59:55 -0500
Subject: [PATCH 6/9] Add minimum and maximum float constants

---
 basis/math/constants/constants.factor | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/basis/math/constants/constants.factor b/basis/math/constants/constants.factor
index c207eaa63c..118a8e8197 100755
--- a/basis/math/constants/constants.factor
+++ b/basis/math/constants/constants.factor
@@ -1,5 +1,6 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USE: math
 IN: math.constants
 
 : e ( -- e ) 2.7182818284590452354 ; inline
@@ -7,3 +8,5 @@ IN: math.constants
 : phi ( -- phi ) 1.61803398874989484820 ; inline
 : pi ( -- pi ) 3.14159265358979323846 ; inline
 : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
+: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
+: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable

From bbd05723a5a4725d01d9518ed8b1303115d10ec6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 19:22:13 -0500
Subject: [PATCH 7/9] Cleaner loop detection pass

---
 .../tree/loop/detection/detection.factor      | 95 ++++++++-----------
 1 file changed, 40 insertions(+), 55 deletions(-)

diff --git a/unfinished/compiler/tree/loop/detection/detection.factor b/unfinished/compiler/tree/loop/detection/detection.factor
index 1c881e9ee4..5c21e8c237 100644
--- a/unfinished/compiler/tree/loop/detection/detection.factor
+++ b/unfinished/compiler/tree/loop/detection/detection.factor
@@ -1,22 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences namespaces assocs accessors fry
-compiler.tree ;
+compiler.tree dequeues search-dequeues ;
 IN: compiler.tree.loop.detection
 
 ! A loop is a #recursive which only tail calls itself, and those
-! calls are nested inside other loops only.
-
-TUPLE: recursive-call tail? nesting ;
-
-! calls is a sequence of recursive-call instances
-TUPLE: loop-info calls height ;
-
-! Mapping inline-recursive instances to loop-info instances
-SYMBOL: loop-infos
-
-! A sequence of inline-recursive instances
-SYMBOL: label-stack
+! calls are nested inside other loops only. We optimistically
+! assume all #recursive nodes are loops, disqualifying them as
+! we see evidence to the contrary.
 
 : (tail-calls) ( tail? seq -- seq' )
     reverse [ swap [ and ] keep ] map nip reverse ;
@@ -29,6 +20,11 @@ SYMBOL: label-stack
         tri or or
     ] map (tail-calls) ;
 
+SYMBOL: loop-heights
+SYMBOL: loop-calls
+SYMBOL: label-stack
+SYMBOL: work-list
+
 GENERIC: collect-loop-info* ( tail? node -- )
 
 : non-tail-label-info ( nodes -- )
@@ -37,24 +33,32 @@ GENERIC: collect-loop-info* ( tail? node -- )
 : (collect-loop-info) ( tail? nodes -- )
     [ tail-calls ] keep [ collect-loop-info* ] 2each ;
 
-: remember-loop-info ( #recursive -- )
-    V{ } clone label-stack get length loop-info boa
-    swap label>> loop-infos get set-at ;
+: remember-loop-info ( label -- )
+    label-stack get length swap loop-heights get set-at ;
 
 M: #recursive collect-loop-info*
     nip
     [
-        [ label-stack [ swap label>> suffix ] change ]
-        [ remember-loop-info ]
-        [ t swap child>> (collect-loop-info) ]
-        tri
+        [
+            label>>
+            [ label-stack [ swap suffix ] change ]
+            [ remember-loop-info ]
+            [ t >>loop? drop ]
+            tri
+        ]
+        [ t swap child>> (collect-loop-info) ] bi
     ] with-scope ;
 
+: current-loop-nesting ( label -- labels )
+    label-stack get swap loop-heights get at tail ;
+
+: disqualify-loop ( label -- )
+    work-list get push-front ;
+
 M: #call-recursive collect-loop-info*
-    label>> loop-infos get at
-    [ label-stack get swap height>> tail recursive-call boa ]
-    [ calls>> ]
-    bi push ;
+    label>>
+    swap [ dup disqualify-loop ] unless
+    dup current-loop-nesting [ loop-calls get push-at ] with each ;
 
 M: #if collect-loop-info*
     children>> [ (collect-loop-info) ] with each ;
@@ -66,38 +70,19 @@ M: node collect-loop-info* 2drop ;
 
 : collect-loop-info ( node -- )
     { } label-stack set
-    H{ } clone loop-infos set
+    H{ } clone loop-calls set
+    H{ } clone loop-heights set
+    <hashed-dlist> work-list set
     t swap (collect-loop-info) ;
 
-! Sub-assoc of loop-infos
-SYMBOL: potential-loops
-
-: remove-non-tail-calls ( -- )
-    loop-infos get
-    [ nip calls>> [ tail?>> ] all? ] assoc-filter
-    potential-loops set ;
-
-: (remove-non-loop-calls) ( loop-infos -- )
-    f over [
-        ! If label X is called from within a label Y that is
-        ! no longer a potential loop, then X is no longer a
-        ! potential loop either.
-        over potential-loops get key? [
-            potential-loops get '[ , key? ] all?
-            [ drop ] [ potential-loops get delete-at t or ] if
-        ] [ 2drop ] if
-    ] assoc-each
-    [ (remove-non-loop-calls) ] [ drop ] if ;
-
-: remove-non-loop-calls ( -- )
-    ! Boolean is set to t if something changed.
-    !  We recurse until a fixed point is reached.
-    loop-infos get [ calls>> [ nesting>> ] map concat ] assoc-map
-    (remove-non-loop-calls) ;
+: disqualify-loops ( -- )
+    work-list get [
+        dup loop?>> [
+            [ f >>loop? drop ]
+            [ loop-calls get at [ disqualify-loop ] each ]
+            bi
+        ] [ drop ] if
+    ] slurp-dequeue ;
 
 : detect-loops ( nodes -- nodes )
-    dup
-    collect-loop-info
-    remove-non-tail-calls
-    remove-non-loop-calls
-    potential-loops get [ drop t >>loop? drop ] assoc-each ;
+    dup collect-loop-info disqualify-loops ;

From 73ed573a05398c99ce2136dcd83b37296d58b9d7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 22:20:14 -0500
Subject: [PATCH 8/9] Fix typo in 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 0a1a3cb7f2..94f0ddea51 100755
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -629,7 +629,7 @@ HELP: 2bi*
     "The following two lines are equivalent:"
     { $code
         "[ p ] [ q ] 2bi*"
-        ">r >r q r> r> q"
+        ">r >r p r> r> q"
     }
 } ;
 

From fe16de52e030c47f074498743d365e504e5dc9dd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 Aug 2008 22:22:26 -0500
Subject: [PATCH 9/9] Inference transforms can now give up; remove elaboration
 phase since we'll do that while building CFG

---
 .../compiler/tree/builder/builder.factor      |   5 +
 .../tree/elaboration/elaboration.factor       |   5 -
 .../tree/intrinsics/intrinsics.factor         |  24 +++-
 .../tree/loop/detection/detection.factor      |  10 +-
 .../compiler/tree/optimizer/optimizer.factor  |  10 +-
 .../tree/propagation/inlining/inlining.factor |   5 +-
 .../known-words/known-words.factor            |   9 +-
 .../transforms/transforms.factor              | 114 +++++++++++++++---
 8 files changed, 138 insertions(+), 44 deletions(-)
 delete mode 100644 unfinished/compiler/tree/elaboration/elaboration.factor

diff --git a/unfinished/compiler/tree/builder/builder.factor b/unfinished/compiler/tree/builder/builder.factor
index afa57556ca..e2315dbdf7 100644
--- a/unfinished/compiler/tree/builder/builder.factor
+++ b/unfinished/compiler/tree/builder/builder.factor
@@ -22,6 +22,11 @@ IN: compiler.tree.builder
     ] with-tree-builder nip
     unclip-last in-d>> ;
 
+: build-sub-tree ( #call quot -- nodes )
+    [ [ out-d>> ] [ in-d>> ] bi ] dip
+    build-tree-with
+    rot #copy suffix ;
+
 : (make-specializer) ( class picker -- quot )
     swap "predicate" word-prop append ;
 
diff --git a/unfinished/compiler/tree/elaboration/elaboration.factor b/unfinished/compiler/tree/elaboration/elaboration.factor
deleted file mode 100644
index b0f4306964..0000000000
--- a/unfinished/compiler/tree/elaboration/elaboration.factor
+++ /dev/null
@@ -1,5 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.elaboration
-
-: elaborate ( nodes -- nodes' ) ;
diff --git a/unfinished/compiler/tree/intrinsics/intrinsics.factor b/unfinished/compiler/tree/intrinsics/intrinsics.factor
index a3328114bd..322e0dabe1 100644
--- a/unfinished/compiler/tree/intrinsics/intrinsics.factor
+++ b/unfinished/compiler/tree/intrinsics/intrinsics.factor
@@ -1,6 +1,26 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel ;
+USING: kernel classes.tuple classes.tuple.private math arrays 
+byte-arrays words stack-checker.known-words ;
 IN: compiler.tree.intrinsics
 
-: <immutable-tuple-boa> ( ... class -- tuple ) "Intrinsic" throw ;
+: <immutable-tuple-boa> ( ... class -- tuple )
+    "BUG: missing <immutable-tuple-boa> intrinsic" throw ;
+
+: (tuple) ( layout -- tuple )
+    "BUG: missing (tuple) intrinsic" throw ;
+
+\ (tuple) { tuple-layout } { tuple } define-primitive
+\ (tuple) make-flushable
+
+: (array) ( n -- array )
+    "BUG: missing (array) intrinsic" throw ;
+
+\ (array) { integer } { array } define-primitive
+\ (array) make-flushable
+
+: (byte-array) ( n -- byte-array )
+    "BUG: missing (byte-array) intrinsic" throw ;
+
+\ (byte-array) { integer } { byte-array } define-primitive
+\ (byte-array) make-flushable
diff --git a/unfinished/compiler/tree/loop/detection/detection.factor b/unfinished/compiler/tree/loop/detection/detection.factor
index 5c21e8c237..21d7e2a694 100644
--- a/unfinished/compiler/tree/loop/detection/detection.factor
+++ b/unfinished/compiler/tree/loop/detection/detection.factor
@@ -22,7 +22,7 @@ IN: compiler.tree.loop.detection
 
 SYMBOL: loop-heights
 SYMBOL: loop-calls
-SYMBOL: label-stack
+SYMBOL: loop-stack
 SYMBOL: work-list
 
 GENERIC: collect-loop-info* ( tail? node -- )
@@ -34,14 +34,14 @@ GENERIC: collect-loop-info* ( tail? node -- )
     [ tail-calls ] keep [ collect-loop-info* ] 2each ;
 
 : remember-loop-info ( label -- )
-    label-stack get length swap loop-heights get set-at ;
+    loop-stack get length swap loop-heights get set-at ;
 
 M: #recursive collect-loop-info*
     nip
     [
         [
             label>>
-            [ label-stack [ swap suffix ] change ]
+            [ loop-stack [ swap suffix ] change ]
             [ remember-loop-info ]
             [ t >>loop? drop ]
             tri
@@ -50,7 +50,7 @@ M: #recursive collect-loop-info*
     ] with-scope ;
 
 : current-loop-nesting ( label -- labels )
-    label-stack get swap loop-heights get at tail ;
+    loop-stack get swap loop-heights get at tail ;
 
 : disqualify-loop ( label -- )
     work-list get push-front ;
@@ -69,7 +69,7 @@ M: #dispatch collect-loop-info*
 M: node collect-loop-info* 2drop ;
 
 : collect-loop-info ( node -- )
-    { } label-stack set
+    { } loop-stack set
     H{ } clone loop-calls set
     H{ } clone loop-heights set
     <hashed-dlist> work-list set
diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor
index e44cf44db7..24df9b5af3 100644
--- a/unfinished/compiler/tree/optimizer/optimizer.factor
+++ b/unfinished/compiler/tree/optimizer/optimizer.factor
@@ -8,7 +8,7 @@ compiler.tree.tuple-unboxing
 compiler.tree.def-use
 compiler.tree.dead-code
 compiler.tree.strength-reduction
-compiler.tree.loop-detection
+compiler.tree.loop.detection
 compiler.tree.branch-fusion ;
 IN: compiler.tree.optimizer
 
@@ -16,11 +16,11 @@ IN: compiler.tree.optimizer
     normalize
     propagate
     cleanup
+    detect-loops
+    invert-loops
+    fuse-branches
     escape-analysis
     unbox-tuples
     compute-def-use
     remove-dead-code
-    strength-reduce
-    detect-loops
-    fuse-branches
-    elaborate ;
+    strength-reduce ;
diff --git a/unfinished/compiler/tree/propagation/inlining/inlining.factor b/unfinished/compiler/tree/propagation/inlining/inlining.factor
index 22e056ce60..d333842657 100644
--- a/unfinished/compiler/tree/propagation/inlining/inlining.factor
+++ b/unfinished/compiler/tree/propagation/inlining/inlining.factor
@@ -18,10 +18,7 @@ M: word splicing-nodes
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
 
 M: quotation splicing-nodes
-    [ [ out-d>> ] [ in-d>> ] bi ] dip
-    build-tree-with
-    rot #copy suffix
-    normalize ;
+    build-sub-tree normalize ;
 
 : propagate-body ( #call -- )
     body>> (propagate) ;
diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index 01991147f7..2e0c979f98 100755
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -165,24 +165,27 @@ M: object infer-call*
 { call execute dispatch load-locals get-local drop-locals }
 [ t "no-compile" set-word-prop ] each
 
+SYMBOL: +primitive+
+
 : non-inline-word ( word -- )
     dup +called+ depends-on
     {
         { [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] }
         { [ dup +special+ word-prop ] [ infer-special ] }
-        { [ dup primitive? ] [ infer-primitive ] }
+        { [ dup +primitive+ word-prop ] [ infer-primitive ] }
         { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
-        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
         { [ dup +transform-quot+ word-prop ] [ apply-transform ] }
+        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
         { [ dup "macro" word-prop ] [ apply-macro ] }
         { [ dup recursive-label ] [ call-recursive-word ] }
         [ dup infer-word apply-word/effect ]
     } cond ;
 
 : define-primitive ( word inputs outputs -- )
+    [ 2drop t +primitive+ set-word-prop ]
     [ drop "input-classes" set-word-prop ]
     [ nip "default-output-classes" set-word-prop ]
-    3bi ;
+    3tri ;
 
 ! Stack effects for all primitives
 \ fixnum< { fixnum fixnum } { object } define-primitive
diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor
index 5ec3f5ad64..d9e889f188 100755
--- a/unfinished/stack-checker/transforms/transforms.factor
+++ b/unfinished/stack-checker/transforms/transforms.factor
@@ -11,31 +11,45 @@ IN: stack-checker.transforms
 SYMBOL: +transform-quot+
 SYMBOL: +transform-n+
 
-: (apply-transform) ( quot n -- newquot )
-    dup zero? [
-        drop recursive-state get 1array
-    ] [
-        consume-d
-        [ #drop, ]
-        [ [ literal value>> ] map ]
-        [ first literal recursion>> ] tri prefix
-    ] if
-    swap with-datastack ;
+: give-up-transform ( word -- )
+    dup recursive-label
+    [ call-recursive-word ]
+    [ dup infer-word apply-word/effect ]
+    if ;
+
+: ((apply-transform)) ( word quot stack -- )
+    swap with-datastack first2
+    dup [ swap infer-quot drop ] [ 2drop give-up-transform ] if ;
+    inline
+
+: (apply-transform) ( word quot n -- )
+    consume-d dup [ known literal? ] all? [
+        dup empty? [
+            drop recursive-state get 1array
+        ] [
+            [ #drop, ]
+            [ [ literal value>> ] map ]
+            [ first literal recursion>> ] tri prefix
+        ] if
+        ((apply-transform))
+    ] [ 2drop give-up-transform ] if ;
 
 : apply-transform ( word -- )
     [ +inlined+ depends-on ] [
+        [ ]
         [ +transform-quot+ word-prop ]
         [ +transform-n+ word-prop ]
-        bi (apply-transform)
-        first2 swap infer-quot
+        tri
+        (apply-transform)
     ] bi ;
 
 : apply-macro ( word -- )
     [ +inlined+ depends-on ] [
+        [ ]
         [ "macro" word-prop ]
         [ "declared-effect" word-prop in>> length ]
-        bi (apply-transform)
-        first2 swap infer-quot
+        tri
+        (apply-transform)
     ] bi ;
 
 : define-transform ( word quot n -- )
@@ -66,20 +80,80 @@ SYMBOL: +transform-n+
 
 \ spread [ spread>quot ] 1 define-transform
 
+\ (call-next-method) [
+    [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+] 2 define-transform
+
+! Constructors
 \ boa [
     dup tuple-class? [
         dup +inlined+ depends-on
         [ "boa-check" word-prop ]
         [ tuple-layout '[ , <tuple-boa> ] ]
         bi append
-    ] [
-        \ boa \ no-method boa time-bomb
-    ] if
+    ] [ drop f ] if
 ] 1 define-transform
 
-\ (call-next-method) [
-    [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
-] 2 define-transform
+\ new [
+    dup tuple-class? [
+        dup +inlined+ depends-on
+        dup all-slots rest-slice ! delegate slot
+        [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make
+    ] [ drop f ] if
+] 1 define-transform
+
+! Membership testing
+: bit-member-n 256 ; inline
+
+: bit-member? ( seq -- ? )
+    #! Can we use a fast byte array test here?
+    {
+        { [ dup length 8 < ] [ f ] }
+        { [ dup [ integer? not ] contains? ] [ f ] }
+        { [ dup [ 0 < ] contains? ] [ f ] }
+        { [ dup [ bit-member-n >= ] contains? ] [ f ] }
+        [ t ]
+    } cond nip ;
+
+: bit-member-seq ( seq -- flags )
+    bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
+
+: exact-float? ( f -- ? )
+    dup float? [ dup >integer >float = ] [ drop f ] if ; inline
+
+: bit-member-quot ( seq -- newquot )
+    [
+        [ drop ] % ! drop the sequence itself; we don't use it at run time
+        bit-member-seq ,
+        [
+            {
+                { [ over fixnum? ] [ ?nth 1 eq? ] }
+                { [ over bignum? ] [ ?nth 1 eq? ] }
+                { [ over exact-float? ] [ ?nth 1 eq? ] }
+                [ 2drop f ]
+            } cond
+        ] %
+    ] [ ] make ;
+
+: member-quot ( seq -- newquot )
+    dup bit-member? [
+        bit-member-quot
+    ] [
+        [ literalize [ t ] ] { } map>assoc
+        [ drop f ] suffix [ nip case ] curry
+    ] if ;
+
+\ member? [
+    dup sequence? [ member-quot ] [ drop f ] if
+] 1 define-transform
+
+: memq-quot ( seq -- newquot )
+    [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
+    [ drop f ] suffix [ nip cond ] curry ;
+
+\ memq? [
+    dup sequence? [ memq-quot ] [ drop f ] if
+] 1 define-transform
 
 ! Deprecated
 \ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform