diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 2540ee39cd..68feb7a94a 100755
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -165,12 +165,16 @@ GENERIC: boa ( ... class -- tuple )
     compose compose ; inline
 
 ! Booleans
-: not ( obj -- ? ) f eq? ; inline
+: not ( obj -- ? )
+    #! Not inline because its special-cased by compiler.
+    f eq? ;
+
+: and ( obj1 obj2 -- ? )
+    #! Not inline because its special-cased by compiler.
+    over ? ;
 
 : >boolean ( obj -- ? ) t f ? ; inline
 
-: and ( obj1 obj2 -- ? ) over ? ; inline
-
 : or ( obj1 obj2 -- ? ) dupd ? ; inline
 
 : xor ( obj1 obj2 -- ? ) dup not swap ? ; inline
diff --git a/core/math/intervals/intervals-tests.factor b/core/math/intervals/intervals-tests.factor
index 7aa8ae0679..5234f03ecf 100755
--- a/core/math/intervals/intervals-tests.factor
+++ b/core/math/intervals/intervals-tests.factor
@@ -217,7 +217,7 @@ IN: math.intervals.tests
     ] if ;
 
 : random-interval ( -- interval )
-    1000 random dup 2 1000 random + +
+    2000 random 1000 - dup 2 1000 random + +
     1 random zero? [ [ neg ] bi@ swap ] when
     4 random {
         { 0 [ [a,b] ] }
@@ -274,7 +274,7 @@ IN: math.intervals.tests
 
 : binary-test ( -- ? )
     random-interval random-interval random-binary-op ! 3dup . . .
-    0 pick interval-contains? over first { / /i } member? and [
+    0 pick interval-contains? over first { / /i mod rem } member? and [
         3drop t
     ] [
         [ >r [ random-element ] bi@ ! 2dup . .
@@ -310,3 +310,25 @@ IN: math.intervals.tests
 [ t ] [ -10 10 [a,b] -100 0 [a,b] assume<= -10 0 [a,b] = ] unit-test
 
 [ t ] [ -10 10 [a,b] 0 100 [a,b] assume<= -10 10 [a,b] = ] unit-test
+
+[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
+
+! Test that commutative interval ops really are
+: random-interval-or-empty ( -- )
+    10 random 0 = [ empty-interval ] [ random-interval ] if ;
+
+: random-commutative-op ( -- op )
+    {
+        interval+ interval*
+        interval-bitor interval-bitand interval-bitxor
+        interval-max interval-min
+    } random ;
+
+[ t ] [
+    80000 [
+        drop
+        random-interval-or-empty random-interval-or-empty
+        random-commutative-op
+        [ execute ] [ swapd execute ] 3bi =
+    ] all?
+] unit-test
diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor
index 4aa86d772b..1896943a71 100755
--- a/core/math/intervals/intervals.factor
+++ b/core/math/intervals/intervals.factor
@@ -235,11 +235,15 @@ TUPLE: interval { from read-only } { to read-only } ;
 : interval/f ( i1 i2 -- i3 )
     [ [ [ /f ] interval-op ] interval-division-op ] do-empty-interval ;
 
+: (interval-abs) ( i1 -- i2 )
+    interval>points [ first2 [ abs ] dip 2array ] bi@ 2array ;
+
 : interval-abs ( i1 -- i2 )
-    dup empty-interval eq? [
-        interval>points [ first2 [ abs ] dip 2array ] bi@ 2array
-        points>interval
-    ] unless ;
+    {
+        { [ dup empty-interval eq? ] [ ] }
+        { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
+        [ (interval-abs) points>interval ]
+    } cond ;
 
 : interval-mod ( i1 i2 -- i3 )
     #! Inaccurate.
@@ -307,30 +311,45 @@ SYMBOL: incomparable
 : interval>= ( i1 i2 -- ? )
     swap interval<= ;
 
+: interval-bitand-pos ( i1 i2 -- ? )
+    [ to>> first ] bi@ min 0 swap [a,b] ;
+
+: interval-bitand-neg ( i1 i2 -- ? )
+    dup from>> first 0 < [ drop ] [ nip ] if
+    0 swap to>> first [a,b] ;
+
+: interval-nonnegative? ( i -- ? )
+    from>> first 0 >= ;
+
 : interval-bitand ( i1 i2 -- i3 )
-    dup 1 [a,a] interval>= [
-        1 [a,a] interval- interval-rem
-    ] [
-        2drop [-inf,inf]
-    ] if ;
+    #! Inaccurate.
+    [
+        {
+            {
+                [ 2dup [ interval-nonnegative? ] both? ]
+                [ interval-bitand-pos ]
+            }
+            {
+                [ 2dup [ interval-nonnegative? ] either? ]
+                [ interval-bitand-neg ]
+            }
+            [ 2drop [-inf,inf] ]
+        } cond
+    ] do-empty-interval ;
 
 : interval-bitor ( i1 i2 -- i3 )
     #! Inaccurate.
     [
-        2dup [ 0 [a,a] interval>= ] both?
-        [ to>> first 0 swap [a,b] interval-intersect ]
-        [ 2drop [-inf,inf] ]
-        if
+        2dup [ interval-nonnegative? ] both?
+        [
+            [ interval>points [ first ] bi@ ] bi@
+            4array supremum 0 swap next-power-of-2 [a,b]
+        ] [ 2drop [-inf,inf] ] if
     ] do-empty-interval ;
 
 : interval-bitxor ( i1 i2 -- i3 )
     #! Inaccurate.
-    [
-        2dup [ 0 [a,a] interval>= ] both?
-        [ nip to>> first 0 swap [a,b] ]
-        [ 2drop [-inf,inf] ]
-        if
-    ] do-empty-interval ;
+    interval-bitor ;
 
 : assume< ( i1 i2 -- i3 )
     dup empty-interval eq? [ drop ] [
diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor
new file mode 100644
index 0000000000..569cef8302
--- /dev/null
+++ b/extra/24-game/24-game.factor
@@ -0,0 +1,38 @@
+! Copyright © 2008 Reginald Keith Ford II
+! 24, the Factor game!
+
+USING: kernel random namespaces shuffle sequences
+parser io math prettyprint combinators continuations
+vectors words quotations accessors math.parser
+backtrack math.ranges locals fry memoize macros assocs ;
+
+IN: 24-game
+
+: nop ;
+: do-something ( a b -- c ) { + - * } amb-execute ;
+: maybe-swap ( a b -- a b ) { nop swap } amb-execute ;
+: some-rots ( a b c -- a b c )
+    #! Try each permutation of 3 elements.
+    { nop rot -rot swap spin swapd } amb-execute ;
+: makes-24? ( a b c d -- ? ) [ some-rots do-something some-rots do-something maybe-swap do-something 24 = ] [ 4drop ] if-amb ;
+: vector-24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
+: q ( -- obj ) "quit" ;
+: show-commands ( -- ) "Commands: " write "commands" get unparse print ;
+: report ( vector -- ) unparse print show-commands ;
+: give-help ( -- ) "Command not found..." print show-commands ;
+: find-word ( string choices -- word ) [ name>> = ] with find nip ;
+: obtain-word ( -- word ) readln "commands" get find-word dup [ drop give-help obtain-word ] unless ;
+: done? ( vector -- t/f ) 1 swap length = ;
+: victory? ( vector -- t/f ) V{ 24 } = ;
+: apply-word ( vector word -- vector ) 1quotation with-datastack >vector ;
+: update-commands ( vector -- ) length 3 < [ "commands" [ \ rot swap remove ] change ] [ ] if ;
+DEFER: check-status
+: quit-game ( vector -- ) drop "you're a quitter" print ;
+: quit? ( vector -- t/f ) peek "quit" = ;
+: end-game ( vector -- ) dup victory? [ drop "You WON!" ] [ pop number>string " is not 24... You lose." append ] if print ;
+: repeat ( vector -- ) dup report obtain-word apply-word dup update-commands check-status  ;
+: check-status ( object -- ) dup done? [ end-game ] [ dup quit? [ quit-game ] [ repeat ] if ] if ;
+: build-quad ( -- vector ) 4 [ 10 random ] replicate >vector ;
+: 24-able ( -- vector ) build-quad dup vector-24-able? [ drop build-quad ] unless ;
+: set-commands ( -- ) { + - * / rot swap q } "commands" set ;
+: play-game ( -- ) set-commands 24-able repeat ;
\ No newline at end of file
diff --git a/extra/locals/backend/backend.factor b/extra/locals/backend/backend.factor
index 10bed8b5df..fd24631171 100644
--- a/extra/locals/backend/backend.factor
+++ b/extra/locals/backend/backend.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel slots.private inference.known-words
 inference.backend sequences effects words ;
 IN: locals.backend
diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor
new file mode 100644
index 0000000000..23847e82f7
--- /dev/null
+++ b/extra/math/derivatives/derivatives-docs.factor
@@ -0,0 +1,9 @@
+USING: help.markup help.syntax ;
+
+IN: math.derivatives
+
+HELP: derivative ( x function -- m )
+{ $values { "x" "the x-position on the function" } { "function" "a differentiable function" } }
+{ $description "Finds the slope of the tangent line at the given x-position on the given function." } ;
+
+{ derivative-func } related-words
diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor
new file mode 100644
index 0000000000..fef93cabc4
--- /dev/null
+++ b/extra/math/derivatives/derivatives.factor
@@ -0,0 +1,9 @@
+! Copyright © 2008 Reginald Keith Ford II
+! Tool for computing the derivative of a function at a point 
+USING: kernel math math.points math.function-tools ;
+IN: math.derivatives
+
+: small-amount ( -- n ) 1.0e-12 ;
+: near ( x -- y ) small-amount + ;
+: derivative ( x function -- m ) 2dup [ near ] dip [ eval ] 2bi@ slope ;
+: derivative-func ( function -- function ) [ derivative ] curry ;
\ No newline at end of file
diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor
new file mode 100644
index 0000000000..042b5f0897
--- /dev/null
+++ b/extra/math/function-tools/function-tools.factor
@@ -0,0 +1,8 @@
+! Copyright © 2008 Reginald Keith Ford II
+! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions
+
+USING: kernel math arrays ;
+IN: math.function-tools 
+: difference-func ( func func -- func ) [ bi - ] 2curry ;
+: eval ( x func -- pt ) dupd call 2array ;
+: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ;
diff --git a/extra/math/newtons-method/newtons-method.factor b/extra/math/newtons-method/newtons-method.factor
new file mode 100644
index 0000000000..b2778a2d85
--- /dev/null
+++ b/extra/math/newtons-method/newtons-method.factor
@@ -0,0 +1,11 @@
+! Copyright © 2008 Reginald Keith Ford II
+! Newton's Method of approximating roots
+
+USING: kernel math math.derivatives ;
+IN: math.newtons-method
+
+<PRIVATE
+: newton-step ( x function -- x2 ) dupd [ call ] [ derivative ] 2bi / - ;
+: newton-precision ( -- n ) 7 ;
+PRIVATE>
+: newton-method ( guess function -- x ) newton-precision [ [ newton-step ] keep ] times drop ;
diff --git a/extra/math/points/points.factor b/extra/math/points/points.factor
index 5efd6e07e0..c8654869e2 100644
--- a/extra/math/points/points.factor
+++ b/extra/math/points/points.factor
@@ -1,5 +1,4 @@
-
-USING: kernel arrays math.vectors ;
+USING: kernel arrays math.vectors sequences math ;
 
 IN: math.points
 
@@ -20,3 +19,9 @@ PRIVATE>
 : v+z ( seq z -- seq ) Z v+ ;
 : v-z ( seq z -- seq ) Z v- ;
 
+: rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
+: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
+: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
+: distance ( point point -- float ) v- norm ;
+: midpoint ( point point -- point ) v+ 2 v/n ;
+: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;
\ No newline at end of file
diff --git a/extra/math/secant-method/secant-method.factor b/extra/math/secant-method/secant-method.factor
new file mode 100644
index 0000000000..2089dde848
--- /dev/null
+++ b/extra/math/secant-method/secant-method.factor
@@ -0,0 +1,14 @@
+! Copyright © 2008 Reginald Keith Ford II
+! Secant Method of approximating roots
+
+USING: kernel math math.function-tools math.points math.vectors ;
+IN: math.secant-method
+
+<PRIVATE
+: secant-solution ( x1 x2 function -- solution ) [ eval ] curry bi@ linear-solution ;
+: secant-step ( x1 x2 func -- x2 x3 func ) 2dup [ secant-solution ] 2dip swapd ;
+: secant-precision ( -- n ) 11 ;
+PRIVATE>
+: secant-method ( left right function -- x ) secant-precision [ secant-step ] times drop v+ 2 v*n ;
+! : close-enough? ( a b -- t/f ) - abs tiny-amount < ;
+! : secant-method2 ( left right function -- x ) 2over close-enough? [ drop average ] [ secant-step secant-method ] if  ;
\ No newline at end of file
diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor
index c8212b4009..56f7185095 100644
--- a/extra/project-euler/ave-time/ave-time.factor
+++ b/extra/project-euler/ave-time/ave-time.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2007 Aaron Schaefer
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays combinators io kernel math math.functions math.parser
-    math.statistics namespaces sequences tools.time ;
+    math.statistics namespaces sequences tools.time continuations ;
 IN: project-euler.ave-time
 
 : collect-benchmarks ( quot n -- seq )
diff --git a/extra/shell/shell.factor b/extra/shell/shell.factor
index 45c6f1fb4d..e694b36007 100644
--- a/extra/shell/shell.factor
+++ b/extra/shell/shell.factor
@@ -50,7 +50,6 @@ DEFER: expansion
 METHOD: expand { back-quoted-expr }
   expr>>
   expr
-  ast>>
   command>>
   expansion
   utf8 <process-stream>
@@ -122,7 +121,7 @@ DEFER: shell
     { [ dup f = ]      [ drop ] }
     { [ dup "exit" = ] [ drop ] }
     { [ dup "" = ]     [ drop shell ] }
-    { [ dup expr ]     [ expr ast>> chant shell ] }
+    { [ dup expr ]     [ expr chant shell ] }
     { [ t ]            [ drop "ix: ignoring input" print shell ] }
   }
     cond ;
diff --git a/extra/ui/gadgets/labelled/labelled.factor b/extra/ui/gadgets/labelled/labelled.factor
index 686e940ae6..831ac1b1d8 100755
--- a/extra/ui/gadgets/labelled/labelled.factor
+++ b/extra/ui/gadgets/labelled/labelled.factor
@@ -12,9 +12,9 @@ TUPLE: labelled-gadget < track content ;
 
 : <labelled-gadget> ( gadget title -- newgadget )
   { 0 1 } labelled-gadget new-track
-    swap <label> reverse-video-theme f track-add*
+    swap <label> reverse-video-theme f track-add
     swap >>content
-    dup content>> 1 track-add* ;
+    dup content>> 1 track-add ;
 
 M: labelled-gadget focusable-child* labelled-gadget-content ;
 
diff --git a/extra/ui/gadgets/labels/labels.factor b/extra/ui/gadgets/labels/labels.factor
index e965d6b2b8..a3a5c1a0a6 100755
--- a/extra/ui/gadgets/labels/labels.factor
+++ b/extra/ui/gadgets/labels/labels.factor
@@ -65,10 +65,10 @@ M: f >label drop <gadget> ;
 
 : label-on-left ( gadget label -- button )
   { 1 0 } <track>
-    swap >label f track-add*
-    swap        1 track-add* ;
+    swap >label f track-add
+    swap        1 track-add ;
     
 : label-on-right ( label gadget -- button )
   { 1 0 } <track>
-    swap        f track-add*
-    swap >label 1 track-add* ;
+    swap        f track-add
+    swap >label 1 track-add ;
diff --git a/extra/ui/gadgets/slots/slots.factor b/extra/ui/gadgets/slots/slots.factor
index 2ce4a1fa8c..0102876136 100755
--- a/extra/ui/gadgets/slots/slots.factor
+++ b/extra/ui/gadgets/slots/slots.factor
@@ -71,9 +71,9 @@ M: value-ref finish-editing
 : <slot-editor> ( ref -- gadget )
   { 0 1 } slot-editor new-track
     swap >>ref
-    dup <toolbar> f track-add*
+    dup <toolbar> f track-add
     <source-editor> >>text
-    dup text>> <scroller> 1 track-add*
+    dup text>> <scroller> 1 track-add
     dup revert ;
     
 M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
@@ -97,8 +97,8 @@ TUPLE: editable-slot < track printer ref ;
 
 : display-slot ( gadget editable-slot -- )
   dup clear-track
-    swap          1 track-add*
-    <edit-button> f track-add*
+    swap          1 track-add
+    <edit-button> f track-add
   drop ;
 
 : update-slot ( editable-slot -- )
@@ -109,7 +109,7 @@ TUPLE: editable-slot < track printer ref ;
     [ clear-track ]
     [
         dup ref>> <slot-editor>
-        [ 1 track-add* drop ]
+        [ 1 track-add drop ]
         [ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
     ] bi ;
 
diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/extra/ui/gadgets/status-bar/status-bar.factor
index 9c709c2f78..431804f4ca 100755
--- a/extra/ui/gadgets/status-bar/status-bar.factor
+++ b/extra/ui/gadgets/status-bar/status-bar.factor
@@ -12,7 +12,7 @@ IN: ui.gadgets.status-bar
 
 : open-status-window ( gadget title -- )
     f <model> [ <world> ] keep
-    <status-bar> f track-add*
+    <status-bar> f track-add
     open-world-window ;
 
 : show-summary ( object gadget -- )
diff --git a/extra/ui/gadgets/tiling/tiling.factor b/extra/ui/gadgets/tiling/tiling.factor
index 22b473e44b..2d096966af 100644
--- a/extra/ui/gadgets/tiling/tiling.factor
+++ b/extra/ui/gadgets/tiling/tiling.factor
@@ -38,7 +38,7 @@ TUPLE: tiling < track gadgets tiles first focused ;
 
 : tiling-map-gadgets ( tiling -- tiling )
   dup clear-track
-  dup tiling-gadgets-to-map [ 1 track-add* ] each ;
+  dup tiling-gadgets-to-map [ 1 track-add ] each ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
diff --git a/extra/ui/gadgets/tracks/tracks-docs.factor b/extra/ui/gadgets/tracks/tracks-docs.factor
index 2c2ebac15d..7fbbd1a330 100755
--- a/extra/ui/gadgets/tracks/tracks-docs.factor
+++ b/extra/ui/gadgets/tracks/tracks-docs.factor
@@ -8,7 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
 "Creating empty tracks:"
 { $subsection <track> }
 "Adding children:"
-{ $subsection track-add* } ;
+{ $subsection track-add } ;
 
 HELP: track
 { $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
@@ -17,7 +17,7 @@ HELP: <track>
 { $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
 { $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ; 
 
-HELP: track-add*
+HELP: track-add
 { $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
 { $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;
 
diff --git a/extra/ui/gadgets/tracks/tracks-tests.factor b/extra/ui/gadgets/tracks/tracks-tests.factor
index 210a7c5771..6feaf52b47 100644
--- a/extra/ui/gadgets/tracks/tracks-tests.factor
+++ b/extra/ui/gadgets/tracks/tracks-tests.factor
@@ -4,13 +4,13 @@ IN: ui.gadgets.tracks.tests
 
 [ { 100 100 } ] [
   { 0 1 } <track>
-    <gadget> { 100 100 } >>dim 1 track-add*
+    <gadget> { 100 100 } >>dim 1 track-add
   pref-dim
 ] unit-test
 
 [ { 100 110 } ] [
   { 0 1 } <track>
-    <gadget> { 10 10 }   >>dim f track-add*
-    <gadget> { 100 100 } >>dim 1 track-add*
+    <gadget> { 10 10 }   >>dim f track-add
+    <gadget> { 100 100 } >>dim 1 track-add
   pref-dim
 ] unit-test
diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor
index 4aba8f45ef..cf679424e0 100644
--- a/extra/ui/gadgets/tracks/tracks.factor
+++ b/extra/ui/gadgets/tracks/tracks.factor
@@ -50,7 +50,7 @@ M: track pref-dim* ( gadget -- dim )
    tri
    set-axis ;
 
-: track-add* ( track gadget constraint -- track )
+: track-add ( track gadget constraint -- track )
   pick sizes>> push add-gadget ;
 
 : track-remove ( track gadget -- track )
diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor
index 69bb8a13c0..88ba99201b 100755
--- a/extra/ui/gadgets/worlds/worlds.factor
+++ b/extra/ui/gadgets/worlds/worlds.factor
@@ -40,7 +40,7 @@ M: world request-focus-on ( child gadget -- )
         { 0 0 } >>window-loc
         swap >>status
         swap >>title
-        swap 1 track-add*
+        swap 1 track-add
     dup request-focus ;
 
 M: world layout*
diff --git a/extra/ui/tools/browser/browser.factor b/extra/ui/tools/browser/browser.factor
index ee427625f5..8f180714c8 100755
--- a/extra/ui/tools/browser/browser.factor
+++ b/extra/ui/tools/browser/browser.factor
@@ -22,9 +22,9 @@ TUPLE: browser-gadget < track pane history ;
 : <browser-gadget> ( -- gadget )
   { 0 1 } browser-gadget new-track
     dup init-history
-    dup <toolbar> f track-add*
+    dup <toolbar> f track-add
     dup <help-pane> >>pane
-    dup pane>> <scroller> 1 track-add* ;
+    dup pane>> <scroller> 1 track-add ;
 
 M: browser-gadget call-tool* show-help ;
 
diff --git a/extra/ui/tools/debugger/debugger.factor b/extra/ui/tools/debugger/debugger.factor
index 6ed98f4964..203406c6cb 100644
--- a/extra/ui/tools/debugger/debugger.factor
+++ b/extra/ui/tools/debugger/debugger.factor
@@ -25,9 +25,9 @@ TUPLE: debugger < track restarts ;
 
 : <debugger> ( error restarts restart-hook -- gadget )
     { 0 1 } debugger new-track
-        dup <toolbar> f track-add*
+        dup <toolbar> f track-add
         -rot <restart-list> >>restarts
-        dup restarts>> rot <debugger-display> <scroller> 1 track-add* ;
+        dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
 
 M: debugger focusable-child* debugger-restarts ;
 
diff --git a/extra/ui/tools/inspector/inspector.factor b/extra/ui/tools/inspector/inspector.factor
index 8c92567fe5..bb0f02ec7e 100644
--- a/extra/ui/tools/inspector/inspector.factor
+++ b/extra/ui/tools/inspector/inspector.factor
@@ -17,9 +17,9 @@ TUPLE: inspector-gadget < track object pane ;
 
 : <inspector-gadget> ( -- gadget )
   { 0 1 } inspector-gadget new-track
-    dup <toolbar> f track-add*
+    dup <toolbar> f track-add
     <pane> >>pane
-    dup pane>> <scroller> 1 track-add* ;
+    dup pane>> <scroller> 1 track-add ;
     
 : inspect-object ( obj mirror keys inspector -- )
     2nip swap >>object refresh ;
diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor
index baad793e3b..9890c21491 100755
--- a/extra/ui/tools/listener/listener.factor
+++ b/extra/ui/tools/listener/listener.factor
@@ -14,7 +14,7 @@ TUPLE: listener-gadget < track input output stack ;
 
 : listener-output, ( listener -- listener )
   <scrolling-pane> >>output
-  dup output>> <scroller> "Output" <labelled-gadget> 1 track-add* ;
+  dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
 
 : listener-streams ( listener -- input output )
     [ input>> ] [ output>> <pane-stream> ] bi ;
@@ -27,7 +27,7 @@ TUPLE: listener-gadget < track input output stack ;
   dup input>>
     { 0 100 } <limited-scroller>
     "Input" <labelled-gadget>
-  f track-add* ;
+  f track-add ;
 
 : welcome. ( -- )
    "If this is your first time with Factor, please read the " print
@@ -125,10 +125,10 @@ TUPLE: stack-display < track ;
 : <stack-display> ( workspace -- gadget )
   listener>>
   { 0 1 } stack-display new-track
-    over <toolbar> f track-add*
+    over <toolbar> f track-add
     swap
       stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
-    1 track-add* ;
+    1 track-add ;
 
 M: stack-display tool-scroller
     find-workspace workspace-listener tool-scroller ;
diff --git a/extra/ui/tools/profiler/profiler.factor b/extra/ui/tools/profiler/profiler.factor
index 9d25361e5e..f440bd8766 100755
--- a/extra/ui/tools/profiler/profiler.factor
+++ b/extra/ui/tools/profiler/profiler.factor
@@ -9,9 +9,9 @@ TUPLE: profiler-gadget < track pane ;
 
 : <profiler-gadget> ( -- gadget )
   { 0 1 } profiler-gadget new-track
-    dup <toolbar> f track-add*
+    dup <toolbar> f track-add
     <pane> >>pane
-    dup pane>> <scroller> 1 track-add* ;
+    dup pane>> <scroller> 1 track-add ;
     
 : with-profiler-pane ( gadget quot -- )
     >r profiler-gadget-pane r> with-pane ;
diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor
index 0a8fe92762..2475ecc691 100755
--- a/extra/ui/tools/search/search.factor
+++ b/extra/ui/tools/search/search.factor
@@ -62,9 +62,9 @@ search-field H{
 : <live-search> ( string seq limited? presenter -- gadget )
   { 0 1 } live-search new-track
     <search-field> >>field
-    dup field>> f track-add*
+    dup field>> f track-add
     -roll <search-list> >>list
-    dup list>> <scroller> 1 track-add*
+    dup list>> <scroller> 1 track-add
 
   swap                         
     over field>> set-editor-string
diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor
index c73e9bc5b1..4bfb209e3a 100755
--- a/extra/ui/tools/tools.factor
+++ b/extra/ui/tools/tools.factor
@@ -38,10 +38,10 @@ IN: ui.tools
     <listener-gadget>    >>listener
     dup <workspace-book> >>book
     
-    dup <workspace-tabs> f   track-add*
-    dup book>>           1/5 track-add*
-    dup listener>>       4/5 track-add*
-    dup <toolbar>        f   track-add* ;
+    dup <workspace-tabs> f   track-add
+    dup book>>           1/5 track-add
+    dup listener>>       4/5 track-add
+    dup <toolbar>        f   track-add ;
 
 : resize-workspace ( workspace -- )
     dup track-sizes over control-value zero? [
diff --git a/extra/ui/tools/traceback/traceback.factor b/extra/ui/tools/traceback/traceback.factor
index ffea857429..6438bc0ebb 100755
--- a/extra/ui/tools/traceback/traceback.factor
+++ b/extra/ui/tools/traceback/traceback.factor
@@ -30,13 +30,13 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
 
     dup model>>
       { 1 0 } <track>
-        over <datastack-display>   1/2 track-add*
-        swap <retainstack-display> 1/2 track-add*
-      1/3 track-add*
+        over <datastack-display>   1/2 track-add
+        swap <retainstack-display> 1/2 track-add
+      1/3 track-add
 
-    dup model>> <callstack-display> 2/3 track-add*
+    dup model>> <callstack-display> 2/3 track-add
 
-    dup <toolbar> f track-add* ;
+    dup <toolbar> f track-add ;
 
 : <namestack-display> ( model -- gadget )
     [ [ continuation-name namestack. ] when* ]
diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor
index e5141fb844..c667e6918d 100755
--- a/extra/ui/tools/walker/walker.factor
+++ b/extra/ui/tools/walker/walker.factor
@@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
         swap >>status
         dup continuation>> <traceback-gadget> >>traceback
 
-        dup <toolbar>                     f track-add*
-        dup status>> self <thread-status> f track-add*
-        dup traceback>>                   1 track-add* ;
+        dup <toolbar>                     f track-add
+        dup status>> self <thread-status> f track-add
+        dup traceback>>                   1 track-add ;
     
 : walker-help ( -- ) "ui-walker" help-window ;
 
diff --git a/extra/ui/tools/workspace/workspace.factor b/extra/ui/tools/workspace/workspace.factor
index 86cfdb02c7..0780103415 100755
--- a/extra/ui/tools/workspace/workspace.factor
+++ b/extra/ui/tools/workspace/workspace.factor
@@ -62,7 +62,7 @@ M: gadget tool-scroller drop f ;
 : show-popup ( gadget workspace -- )
   dup hide-popup
   over >>popup
-  over f track-add* drop
+  over f track-add drop
   request-focus ;
 
 : show-titled-popup ( workspace gadget title -- )
diff --git a/unfinished/compiler/frontend/frontend-tests.factor b/unfinished/compiler/frontend/frontend-tests.factor
deleted file mode 100644
index 98d75c5553..0000000000
--- a/unfinished/compiler/frontend/frontend-tests.factor
+++ /dev/null
@@ -1,17 +0,0 @@
-
-
-[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
-[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
-
-USE: inference.dataflow
-
-{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
-
-{ 1 0 }
-[
-    [ [ iterate-next ] iterate-nodes ] with-node-iterator
-] must-infer-as
-
-{ 1 0 } [ [ drop ] each-node ] must-infer-as
-
-{ 1 0 } [ [ ] map-children ] must-infer-as
diff --git a/unfinished/compiler/frontend/frontend.factor b/unfinished/compiler/frontend/frontend.factor
deleted file mode 100644
index f9f93d160a..0000000000
--- a/unfinished/compiler/frontend/frontend.factor
+++ /dev/null
@@ -1,79 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors quotations kernel sequences namespaces assocs
-words generic generic.standard generic.standard.engines arrays
-kernel.private combinators vectors stack-checker
-stack-checker.state stack-checker.visitor stack-checker.errors
-stack-checker.backend compiler.tree.builder ;
-IN: compiler.frontend
-
-: with-dataflow ( quot -- dataflow )
-    [ tree-builder new dataflow-visitor set ] prepose
-    with-infer first>> ; inline
-
-GENERIC# dataflow-with 1 ( quot stack -- dataflow )
-
-M: callable dataflow-with
-    #! Not safe to call from inference transforms.
-    [
-        >vector meta-d set
-        f infer-quot
-    ] with-dataflow nip ;
-
-: dataflow ( quot -- dataflow ) f dataflow-with ;
-
-: (make-specializer) ( class picker -- quot )
-    swap "predicate" word-prop append ;
-
-: make-specializer ( classes -- quot )
-    dup length <reversed>
-    [ (picker) 2array ] 2map
-    [ drop object eq? not ] assoc-filter
-    dup empty? [ drop [ t ] ] [
-        [ (make-specializer) ] { } assoc>map
-        unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
-    ] if ;
-
-: specializer-cases ( quot word -- default alist )
-    dup [ array? ] all? [ 1array ] unless [
-        [ make-specializer ] keep
-        '[ , declare ] pick append
-    ] { } map>assoc ;
-
-: method-declaration ( method -- quot )
-    dup "method-generic" word-prop dispatch# object <array>
-    swap "method-class" word-prop prefix ;
-
-: specialize-method ( quot method -- quot' )
-    method-declaration '[ , declare ] prepend ;
-
-: specialize-quot ( quot specializer -- quot' )
-    specializer-cases alist>quot ;
-
-: standard-method? ( method -- ? )
-    dup method-body? [
-        "method-generic" word-prop standard-generic?
-    ] [ drop f ] if ;
-
-: specialized-def ( word -- quot )
-    dup def>> swap {
-        { [ dup standard-method? ] [ specialize-method ] }
-        {
-            [ dup "specializer" word-prop ]
-            [ "specializer" word-prop specialize-quot ]
-        }
-        [ drop ]
-    } cond ;
-
-: word-dataflow ( word -- effect dataflow )
-    [
-        [
-            dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
-            dup "no-compile" word-prop [ cannot-infer-effect ] when
-            dup specialized-def over dup 2array 1array infer-quot
-            finish-word
-        ] maybe-cannot-infer
-    ] with-dataflow ;
-
-: specialized-length ( specializer -- n )
-    dup [ array? ] all? [ first ] when length ;
diff --git a/unfinished/compiler/frontend/frontend-docs.factor b/unfinished/compiler/tree/builder/builder-docs.factor
similarity index 90%
rename from unfinished/compiler/frontend/frontend-docs.factor
rename to unfinished/compiler/tree/builder/builder-docs.factor
index 294ac4a905..77b6193f8f 100644
--- a/unfinished/compiler/frontend/frontend-docs.factor
+++ b/unfinished/compiler/tree/builder/builder-docs.factor
@@ -1,6 +1,6 @@
 USING: help.markup help.syntax sequences quotations words 
 compiler.tree stack-checker.errors ;
-IN: compiler.frontend
+IN: compiler.tree.builder
 
 ARTICLE: "specializers" "Word specializers"
 "The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
@@ -22,15 +22,15 @@ $nl
 "The specialized version of a word which will be compiled by the compiler can be inspected:"
 { $subsection specialized-def } ;
 
-HELP: dataflow
+HELP: build-tree
 { $values { "quot" quotation } { "dataflow" node } }
-{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation." }
+{ $description "Attempts to construct tree SSA IR from a quotation." }
 { $notes "This is the first stage of the compiler." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
 
-HELP: dataflow-with
+HELP: build-tree-with
 { $values { "quot" quotation } { "stack" sequence } { "dataflow" node } }
-{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." }
+{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values." }
 { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
 
 HELP: specialized-def
diff --git a/unfinished/compiler/tree/builder/builder-tests.factor b/unfinished/compiler/tree/builder/builder-tests.factor
new file mode 100644
index 0000000000..1d859ac531
--- /dev/null
+++ b/unfinished/compiler/tree/builder/builder-tests.factor
@@ -0,0 +1,6 @@
+IN: compiler.tree.builder.tests
+USING: compiler.tree.builder tools.test ;
+
+\ build-tree must-infer
+\ build-tree-with must-infer
+\ build-tree-from-word must-infer
diff --git a/unfinished/compiler/tree/builder/builder.factor b/unfinished/compiler/tree/builder/builder.factor
index f4f46c9fd9..79a2786f64 100644
--- a/unfinished/compiler/tree/builder/builder.factor
+++ b/unfinished/compiler/tree/builder/builder.factor
@@ -1,32 +1,79 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel sequences compiler.tree
-stack-checker.visitor ;
+USING: fry accessors quotations kernel sequences namespaces assocs
+words generic generic.standard generic.standard.engines arrays
+kernel.private combinators vectors stack-checker
+stack-checker.state stack-checker.visitor stack-checker.errors
+stack-checker.backend compiler.tree ;
 IN: compiler.tree.builder
 
-TUPLE: tree-builder first last ;
+: with-tree-builder ( quot -- dataflow )
+    [ node-list new stack-visitor set ] prepose
+    with-infer first>> ; inline
 
-: node, ( node -- )
-    dataflow-visitor get swap
-    over last>>
-    [ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
-    [ [ >>first ] [ >>last ] bi drop ]
-    if ;
+GENERIC# build-tree-with 1 ( quot stack -- dataflow )
 
-M: tree-builder child-visitor tree-builder new ;
-M: tree-builder #introduce, #introduce node, ;
-M: tree-builder #call, #call node, ;
-M: tree-builder #call-recursive, #call-recursive node, ;
-M: tree-builder #push, #push node, ;
-M: tree-builder #shuffle, #shuffle node, ;
-M: tree-builder #drop, #drop node, ;
-M: tree-builder #>r, #>r node, ;
-M: tree-builder #r>, #r> node, ;
-M: tree-builder #return, #return node, ;
-M: tree-builder #terminate, #terminate node, ;
-M: tree-builder #if, [ first>> ] bi@ #if node, ;
-M: tree-builder #dispatch, [ first>> ] map #dispatch node, ;
-M: tree-builder #phi, #phi node, ;
-M: tree-builder #declare, #declare node, ;
-M: tree-builder #recursive, first>> #recursive node, ;
-M: tree-builder #copy, #copy node, ;
+M: callable build-tree-with
+    #! Not safe to call from inference transforms.
+    [
+        >vector meta-d set
+        f infer-quot
+    ] with-tree-builder nip ;
+
+: build-tree ( quot -- dataflow ) f build-tree-with ;
+
+: (make-specializer) ( class picker -- quot )
+    swap "predicate" word-prop append ;
+
+: make-specializer ( classes -- quot )
+    dup length <reversed>
+    [ (picker) 2array ] 2map
+    [ drop object eq? not ] assoc-filter
+    dup empty? [ drop [ t ] ] [
+        [ (make-specializer) ] { } assoc>map
+        unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+    ] if ;
+
+: specializer-cases ( quot word -- default alist )
+    dup [ array? ] all? [ 1array ] unless [
+        [ make-specializer ] keep
+        '[ , declare ] pick append
+    ] { } map>assoc ;
+
+: method-declaration ( method -- quot )
+    dup "method-generic" word-prop dispatch# object <array>
+    swap "method-class" word-prop prefix ;
+
+: specialize-method ( quot method -- quot' )
+    method-declaration '[ , declare ] prepend ;
+
+: specialize-quot ( quot specializer -- quot' )
+    specializer-cases alist>quot ;
+
+: standard-method? ( method -- ? )
+    dup method-body? [
+        "method-generic" word-prop standard-generic?
+    ] [ drop f ] if ;
+
+: specialized-def ( word -- quot )
+    dup def>> swap {
+        { [ dup standard-method? ] [ specialize-method ] }
+        {
+            [ dup "specializer" word-prop ]
+            [ "specializer" word-prop specialize-quot ]
+        }
+        [ drop ]
+    } cond ;
+
+: build-tree-from-word ( word -- effect dataflow )
+    [
+        [
+            dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
+            dup "no-compile" word-prop [ cannot-infer-effect ] when
+            dup specialized-def over dup 2array 1array infer-quot
+            finish-word
+        ] maybe-cannot-infer
+    ] with-tree-builder ;
+
+: specialized-length ( specializer -- n )
+    dup [ array? ] all? [ first ] when length ;
diff --git a/unfinished/compiler/tree/combinators/combinators-tests.factor b/unfinished/compiler/tree/combinators/combinators-tests.factor
new file mode 100644
index 0000000000..15c07635ad
--- /dev/null
+++ b/unfinished/compiler/tree/combinators/combinators-tests.factor
@@ -0,0 +1,17 @@
+IN: compiler.tree.combinators.tests
+USING: compiler.tree.combinators compiler.tree.builder tools.test
+kernel ;
+
+[ ] [ [ 1 ] build-tree [ ] transform-nodes drop ] unit-test
+[ ] [ [ 1 2 3 ] build-tree [ ] transform-nodes drop ] unit-test
+
+{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
+
+{ 1 0 }
+[
+    [ [ iterate-next ] iterate-nodes ] with-node-iterator
+] must-infer-as
+
+{ 1 0 } [ [ drop ] each-node ] must-infer-as
+
+{ 1 0 } [ [ ] map-children ] must-infer-as
diff --git a/unfinished/compiler/tree/combinators/combinators.factor b/unfinished/compiler/tree/combinators/combinators.factor
index 95373c6e81..1f626163e5 100644
--- a/unfinished/compiler/tree/combinators/combinators.factor
+++ b/unfinished/compiler/tree/combinators/combinators.factor
@@ -5,18 +5,6 @@ sequences words vectors math.intervals effects classes
 accessors combinators compiler.tree ;
 IN: compiler.tree.combinators
 
-: node-exists? ( node quot -- ? )
-    over [
-        2dup 2slip rot [
-            2drop t
-        ] [
-            [ [ children>> ] [ successor>> ] bi suffix ] dip
-            '[ , node-exists? ] contains?
-        ] if
-    ] [
-        2drop f
-    ] if ; inline
-
 SYMBOL: node-stack
 
 : >node ( node -- ) node-stack get push ;
@@ -34,8 +22,8 @@ SYMBOL: node-stack
 
 : (each-node) ( quot -- next )
     node@ [ swap call ] 2keep
-    node-children [
-        [
+    children>> [
+        first>> [
             [ (each-node) ] keep swap
         ] iterate-nodes
     ] each drop
@@ -52,15 +40,7 @@ SYMBOL: node-stack
     ] with-node-iterator ; inline
 
 : map-children ( node quot -- )
-    over [
-        over children>> [
-            '[ , map ] change-children drop
-        ] [
-            2drop
-        ] if
-    ] [
-        2drop
-    ] if ; inline
+    [ children>> ] dip '[ , change-first drop ] each ; inline
 
 : (transform-nodes) ( prev node quot -- )
     dup >r call dup [
diff --git a/unfinished/compiler/tree/comparisons/comparisons.factor b/unfinished/compiler/tree/comparisons/comparisons.factor
new file mode 100644
index 0000000000..5242302411
--- /dev/null
+++ b/unfinished/compiler/tree/comparisons/comparisons.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.order math.intervals assocs combinators ;
+IN: compiler.tree.comparisons
+
+! Some utilities for working with comparison operations.
+
+: comparison-ops { < > <= >= } ;
+
+: generic-comparison-ops { before? after? before=? after=? } ;
+
+: assumption ( i1 i2 op -- i3 )
+    {
+        { \ <  [ assume< ] }
+        { \ >  [ assume> ] }
+        { \ <= [ assume<= ] }
+        { \ >= [ assume>= ] }
+    } case ;
+
+: interval-comparison ( i1 i2 op -- result )
+    {
+        { \ <  [ interval< ] }
+        { \ >  [ interval> ] }
+        { \ <= [ interval<= ] }
+        { \ >= [ interval>= ] }
+    } case ;
+
+: swap-comparison ( op -- op' )
+    {
+        { < > }
+        { > < }
+        { <= >= }
+        { >= <= }
+    } at ;
+
+: negate-comparison ( op -- op' )
+    {
+        { < >= }
+        { > <= }
+        { <= > }
+        { >= < }
+    } at ;
+
+: specific-comparison ( op -- op' )
+    {
+        { before? < }
+        { after? > }
+        { before=? <= }
+        { after=? >= }
+    } at ;
diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
new file mode 100644
index 0000000000..e3a2779376
--- /dev/null
+++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
@@ -0,0 +1,42 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces disjoint-sets sequences assocs
+kernel accessors fry
+compiler.tree compiler.tree.def-use compiler.tree.combinators ;
+IN: compiler.tree.copy-equiv
+
+! Disjoint set of copy equivalence
+SYMBOL: copies
+
+: is-copy-of ( val copy -- ) copies get equate ;
+
+: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
+
+: resolve-copy ( copy -- val ) copies get representative ;
+
+: introduce-value ( val -- ) copies get add-atom ;
+
+GENERIC: compute-copy-equiv* ( node -- )
+
+M: #shuffle compute-copy-equiv*
+    [ out-d>> dup ] [ mapping>> ] bi
+    '[ , at ] map swap are-copies-of ;
+
+M: #>r compute-copy-equiv*
+    [ in-d>> ] [ out-r>> ] bi are-copies-of ;
+
+M: #r> compute-copy-equiv*
+    [ in-r>> ] [ out-d>> ] bi are-copies-of ;
+
+M: #copy compute-copy-equiv*
+    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
+
+M: node compute-copy-equiv* drop ;
+
+: compute-copy-equiv ( node -- node )
+    <disjoint-set> copies set
+    dup [
+        [ node-defs-values [ introduce-value ] each ]
+        [ compute-copy-equiv* ]
+        bi
+    ] each-node ;
diff --git a/unfinished/compiler/tree/dead-code/dead-code-tests.factor b/unfinished/compiler/tree/dead-code/dead-code-tests.factor
index 503c459fae..51a34bcd50 100644
--- a/unfinished/compiler/tree/dead-code/dead-code-tests.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code-tests.factor
@@ -1,4 +1,4 @@
-USING: namespaces assocs sequences compiler.frontend
+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 ;
@@ -7,7 +7,7 @@ IN: compiler.tree.dead-code.tests
 \ remove-dead-code must-infer
 
 : count-live-values ( quot -- n )
-    dataflow
+    build-tree
     compute-def-use
     remove-dead-code
     compute-def-use
diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor
index 4ad61afd19..365a0bdd45 100644
--- a/unfinished/compiler/tree/dead-code/dead-code.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code.factor
@@ -1,106 +1,44 @@
 ! 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.combinators compiler.tree.def-use ;
+kernel sequences words sets stack-checker.inlining
+compiler.tree
+compiler.tree.dfa
+compiler.tree.dfa.backward
+compiler.tree.combinators ;
 IN: compiler.tree.dead-code
 
 ! Dead code elimination: remove #push and flushable #call whose
-! outputs are unused.
-
-SYMBOL: live-values
-SYMBOL: work-list
-
-: live-value? ( value -- ? )
-    live-values get at ;
-
-: look-at-value ( values -- )
-    work-list get push-front ;
-
-: look-at-values ( values -- )
-    work-list get '[ , push-front ] each ;
-
+! outputs are unused using backward DFA.
 GENERIC: mark-live-values ( node -- )
 
-: look-at-inputs ( node -- ) in-d>> look-at-values ;
-
-: look-at-outputs ( node -- ) out-d>> look-at-values ;
-
-M: #introduce mark-live-values look-at-outputs ;
-
 M: #if mark-live-values look-at-inputs ;
 
 M: #dispatch mark-live-values look-at-inputs ;
 
 M: #call mark-live-values
-    dup word>> "flushable" word-prop [ drop ] [
-        [ look-at-inputs ]
-        [ look-at-outputs ]
-        bi
-    ] if ;
+    dup word>> "flushable" word-prop
+    [ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
 
 M: #return mark-live-values
     #! Values returned by local #recursive functions can be
     #! killed if they're unused.
-    dup label>>
-    [ drop ] [ look-at-inputs ] if ;
+    dup label>> [ drop ] [ look-at-inputs ] if ;
 
 M: node mark-live-values drop ;
 
-GENERIC: propagate* ( value node -- )
+SYMBOL: live-values
 
-M: #copy propagate*
-    #! If the output of a copy is live, then the corresponding
-    #! input is live also.
-    [ out-d>> index ] keep in-d>> nth look-at-value ;
-
-M: #call propagate*
-    #! If any of the outputs of a call are live, then all
-    #! inputs and outputs must be live.
-    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
-
-M: #call-recursive propagate*
-    #! If the output of a copy is live, then the corresponding
-    #! inputs to #return nodes are live also.
-    [ out-d>> <reversed> index ] keep label>> returns>>
-    [ <reversed> nth look-at-value ] with each ;
-
-M: #>r propagate* nip in-d>> first look-at-value ;
-
-M: #r> propagate* nip in-r>> first look-at-value ;
-
-M: #shuffle propagate* mapping>> at look-at-value ;
-
-: look-at-corresponding ( value inputs outputs -- )
-    [ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
-
-M: #phi propagate*
-    #! If any of the outputs of a #phi are live, then the
-    #! corresponding inputs are live too.
-    [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
-    [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
-    2bi ;
-
-M: node propagate* 2drop ;
-
-: propogate-liveness ( value -- )
-    live-values get 2dup key? [
-        2drop
-    ] [
-        dupd conjoin
-        dup defined-by propagate*
-    ] if ;
+: live-value? ( value -- ? ) live-values get at ;
 
 : compute-live-values ( node -- )
-    #! We add f initially because #phi nodes can have f in their
-    #! inputs.
-    <hashed-dlist> work-list set
-    H{ { f f } } clone live-values set
-    [ mark-live-values ] each-node
-    work-list get [ propogate-liveness ] slurp-dequeue ;
+    [ mark-live-values ] backward-dfa live-values set ;
 
 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
@@ -118,13 +56,6 @@ M: #push remove-dead-values*
 : filter-corresponding-values ( in out -- in' out' )
     zip live-values get '[ drop _ , key? ] assoc-filter unzip ;
 
-: remove-dead-copies ( node -- )
-    dup
-    [ in-d>> ] [ out-d>> ] bi
-    filter-corresponding-values
-    [ >>in-d ] [ >>out-d ] bi*
-    drop ;
-
 : filter-live ( values -- values' )
     [ live-value? ] filter ;
 
@@ -133,9 +64,16 @@ M: #shuffle remove-dead-values*
     [ filter-live ] change-out-d
     drop ;
 
-M: #declare remove-dead-values* remove-dead-copies ;
+M: #declare remove-dead-values*
+    [ [ drop live-value? ] assoc-filter ] change-declaration
+    drop ;
 
-M: #copy remove-dead-values* remove-dead-copies ;
+M: #copy remove-dead-values*
+    dup
+    [ in-d>> ] [ out-d>> ] bi
+    filter-corresponding-values
+    [ >>in-d ] [ >>out-d ] bi*
+    drop ;
 
 : remove-dead-phi-d ( #phi -- #phi )
     dup
@@ -156,46 +94,54 @@ M: #phi remove-dead-values*
 
 M: node remove-dead-values* drop ;
 
+M: f remove-dead-values* drop ;
+
 GENERIC: remove-dead-nodes* ( node -- newnode/t )
 
+: prune-if-empty ( node seq -- successor/t )
+    empty? [ successor>> ] [ drop t ] if ; inline
+
+M: #introduce remove-dead-nodes* dup values>> prune-if-empty ;
+
 : 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 ;
 
-: prune-if ( node quot -- successor/t )
-    over >r call [ r> successor>> ] [ r> drop t ] if ;
-    inline
+M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
 
-M: #shuffle remove-dead-nodes* 
-    [ in-d>> empty? ] prune-if ;
+M: #push remove-dead-nodes* dup out-d>> prune-if-empty ;
 
-M: #push remove-dead-nodes*
-    [ out-d>> empty? ] prune-if ;
+M: #>r remove-dead-nodes* dup in-d>> prune-if-empty ;
 
-M: #>r remove-dead-nodes*
-    [ in-d>> empty? ] prune-if ;
+M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
 
-M: #r> remove-dead-nodes*
-    [ in-r>> empty? ] prune-if ;
+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: #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 ;
 
-: (remove-dead-code) ( node -- newnode )
-    dup [
-        dup remove-dead-values*
-        dup remove-dead-nodes* dup t eq? [
-            drop dup [ (remove-dead-code) ] map-children
-        ] [
-            nip (remove-dead-code)
-        ] if
-    ] when ;
+M: f remove-dead-nodes* drop t ;
 
 : remove-dead-code ( node -- newnode )
-    [
-        [ compute-live-values ]
-        [ [ (remove-dead-code) ] transform-nodes ] bi
-    ] with-scope ;
+    [ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;
diff --git a/unfinished/compiler/tree/def-use/def-use-tests.factor b/unfinished/compiler/tree/def-use/def-use-tests.factor
index 967f253c06..34e28761ac 100755
--- a/unfinished/compiler/tree/def-use/def-use-tests.factor
+++ b/unfinished/compiler/tree/def-use/def-use-tests.factor
@@ -1,13 +1,13 @@
 USING: accessors namespaces assocs kernel sequences math
 tools.test words sets combinators.short-circuit
-stack-checker.state compiler.tree compiler.frontend
+stack-checker.state compiler.tree compiler.tree.builder
 compiler.tree.def-use arrays kernel.private ;
 IN: compiler.tree.def-use.tests
 
 \ compute-def-use must-infer
 
 [ t ] [
-    [ 1 2 3 ] dataflow compute-def-use drop
+    [ 1 2 3 ] build-tree compute-def-use drop
     def-use get {
         [ assoc-size 3 = ]
         [ values [ uses>> [ #return? ] all? ] all? ]
@@ -29,5 +29,5 @@ IN: compiler.tree.def-use.tests
     [ [ 1 ] [ call 2 ] curry call + ]
     [ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
 } [
-    [ ] swap [ dataflow compute-def-use drop ] curry unit-test
+    [ ] swap [ build-tree compute-def-use drop ] 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 cc5b1aaf57..51899c1dcf 100755
--- a/unfinished/compiler/tree/def-use/def-use.factor
+++ b/unfinished/compiler/tree/def-use/def-use.factor
@@ -28,6 +28,8 @@ TUPLE: definition value node uses ;
 
 GENERIC: node-uses-values ( node -- values )
 
+M: #declare node-uses-values declaration>> keys ;
+
 M: #phi node-uses-values
     [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi
     append sift prune ;
@@ -42,6 +44,8 @@ M: #introduce node-defs-values values>> ;
 
 M: #>r node-defs-values out-r>> ;
 
+M: #phi node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
+
 M: node node-defs-values out-d>> ;
 
 : node-def-use ( node -- )
diff --git a/unfinished/compiler/tree/dfa/backward/backward.factor b/unfinished/compiler/tree/dfa/backward/backward.factor
new file mode 100644
index 0000000000..cb2b13e6bb
--- /dev/null
+++ b/unfinished/compiler/tree/dfa/backward/backward.factor
@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.dfa.backward
+USING: accessors sequences assocs kernel compiler.tree
+compiler.tree.dfa ;
+
+GENERIC: backward ( value node -- )
+
+M: #copy backward
+    #! If the output of a copy is live, then the corresponding
+    #! input is live also.
+    [ out-d>> index ] keep in-d>> nth look-at-value ;
+
+M: #call backward
+    #! If any of the outputs of a call are live, then all
+    #! inputs and outputs must be live.
+    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #call-recursive backward
+    #! If the output of a copy is live, then the corresponding
+    #! inputs to #return nodes are live also.
+    [ out-d>> <reversed> index ] keep label>> returns>>
+    [ <reversed> nth look-at-value ] with each ;
+
+M: #>r backward nip in-d>> first look-at-value ;
+
+M: #r> backward nip in-r>> first look-at-value ;
+
+M: #shuffle backward mapping>> at look-at-value ;
+
+M: #phi backward
+    #! If any of the outputs of a #phi are live, then the
+    #! corresponding inputs are live too.
+    [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
+    [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
+    2bi ;
+
+M: node backward 2drop ;
+
+: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline
diff --git a/unfinished/compiler/tree/dfa/dfa.factor b/unfinished/compiler/tree/dfa/dfa.factor
new file mode 100644
index 0000000000..3a7770c53f
--- /dev/null
+++ b/unfinished/compiler/tree/dfa/dfa.factor
@@ -0,0 +1,40 @@
+! 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 ;
+IN: compiler.tree.dfa
+
+! Dataflow analysis
+SYMBOL: work-list
+
+: look-at-value ( values -- )
+    work-list get push-front ;
+
+: look-at-values ( values -- )
+    work-list get '[ , push-front ] each ;
+
+: look-at-inputs ( node -- ) in-d>> look-at-values ;
+
+: look-at-outputs ( node -- ) out-d>> look-at-values ;
+
+: look-at-corresponding ( value inputs outputs -- )
+    [ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
+
+: init-dfa ( -- )
+    #! We add f initially because #phi nodes can have f in their
+    #! inputs.
+    <hashed-dlist> work-list set ;
+
+: iterate-dfa ( value assoc quot -- )
+    2over key? [
+        3drop
+    ] [
+        [ dupd conjoin dup defined-by ] dip call
+    ] if ; inline
+
+: dfa ( node mark-quot iterate-quot -- assoc )
+    init-dfa
+    [ each-node ] dip
+    work-list get H{ { f f } } clone
+    [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline
diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor
index b95b7f0750..22f0978e22 100644
--- a/unfinished/compiler/tree/propagation/branches/branches.factor
+++ b/unfinished/compiler/tree/propagation/branches/branches.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry kernel sequences assocs accessors namespaces
-math.intervals arrays classes.algebra
+math.intervals arrays classes.algebra locals
 compiler.tree
 compiler.tree.def-use
 compiler.tree.propagation.info
@@ -14,19 +14,36 @@ IN: compiler.tree.propagation.branches
 GENERIC: child-constraints ( node -- seq )
 
 M: #if child-constraints
-    in-d>> first
-    [ <true-constraint> ] [ <false-constraint> ] bi
-    2array ;
+    in-d>> first [ =t ] [ =f ] bi 2array ;
 
-M: #dispatch child-constraints drop f ;
+M: #dispatch child-constraints
+    children>> length f <repetition> ;
+
+GENERIC: live-children ( #branch -- children )
+
+M: #if live-children
+    [ children>> ] [ in-d>> first value-info possible-boolean-values ] bi
+    [ t swap memq? [ first ] [ drop f ] if ]
+    [ f swap memq? [ second ] [ drop f ] if ]
+    2bi 2array ;
+
+M: #dispatch live-children
+    [ children>> ] [ in-d>> first value-info interval>> ] bi
+    '[ , interval-contains? [ drop f ] unless ] map-index ;
 
 : infer-children ( node -- assocs )
-    [ children>> ] [ child-constraints ] bi [
+    [ live-children ] [ child-constraints ] bi [
         [
-            value-infos [ clone ] change
-            constraints [ clone ] change
-            assume
-            (propagate)
+            over [
+                value-infos [ clone ] change
+                constraints [ clone ] change
+                assume
+                first>> (propagate)
+            ] [
+                2drop
+                value-infos off
+                constraints off
+            ] if
         ] H{ } make-assoc
     ] 2map ;
 
@@ -37,13 +54,23 @@ M: #dispatch child-constraints drop f ;
     [ swap (merge-value-infos) ] dip set-value-infos ;
 
 : propagate-branch-phi ( results #phi -- )
-    [ nip node-defs-values [ introduce-value ] each ]
     [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
     [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
-    2tri ;
+    2bi ;
+
+:: branch-phi-constraints ( x #phi -- )
+    #phi [ out-d>> ] [ phi-in-d>> ] bi [
+        first2 2dup and [ USE: prettyprint
+            [ [ =t x =t /\ ] [ =t x =f /\ ] bi* \/ swap t--> dup  . assume ]
+            [ [ =f x =t /\ ] [ =f x =f /\ ] bi* \/ swap f--> dup  . assume ]
+            3bi
+        ] [ 3drop ] if
+    ] 2each ;
 
 : merge-children ( results node -- )
-    successor>> propagate-branch-phi ;
+    [ successor>> propagate-branch-phi ]
+    [ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ]
+    bi ;
 
 M: #branch propagate-around
     [ infer-children ] [ merge-children ] [ annotate-node ] tri ;
diff --git a/unfinished/compiler/tree/propagation/constraints/constraints.factor b/unfinished/compiler/tree/propagation/constraints/constraints.factor
index 0d4216a649..42c094db5a 100644
--- a/unfinished/compiler/tree/propagation/constraints/constraints.factor
+++ b/unfinished/compiler/tree/propagation/constraints/constraints.factor
@@ -2,7 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs math math.intervals kernel accessors
 sequences namespaces disjoint-sets classes classes.algebra
-combinators words compiler.tree compiler.tree.propagation.info ;
+combinators words
+compiler.tree compiler.tree.propagation.info
+compiler.tree.copy-equiv ;
 IN: compiler.tree.propagation.constraints
 
 ! A constraint is a statement about a value.
@@ -12,25 +14,25 @@ SYMBOL: constraints
 
 GENERIC: assume ( constraint -- )
 GENERIC: satisfied? ( constraint -- ? )
+GENERIC: satisfiable? ( constraint -- ? )
 
 ! Boolean constraints
 TUPLE: true-constraint value ;
 
-: <true-constraint> ( value -- constriant )
-    resolve-copy true-constraint boa ;
+: =t ( value -- constriant ) resolve-copy true-constraint boa ;
 
 M: true-constraint assume
     [ constraints get at [ assume ] when* ]
     [ \ f class-not <class-info> swap value>> refine-value-info ]
     bi ;
 
-M: true-constraint satisfied?
-    value>> value-info class>> \ f class-not class<= ;
+M: true-constraint satisfied? value>> \ f class-not value-is? ;
+
+M: true-constraint satisfiable? value>> \ f class-not value-is? ;
 
 TUPLE: false-constraint value ;
 
-: <false-constraint> ( value -- constriant )
-    resolve-copy false-constraint boa ;
+: =f ( value -- constriant ) resolve-copy false-constraint boa ;
 
 M: false-constraint assume
     [ constraints get at [ assume ] when* ]
@@ -38,12 +40,15 @@ M: false-constraint assume
     bi ;
 
 M: false-constraint satisfied?
-    value>> value-info class>> \ f class-not class<= ;
+    value>> value-info class>> \ f class<= ;
+
+M: false-constraint satisfiable?
+    value>> value-info class>> \ f classes-intersect? ;
 
 ! Class constraints
 TUPLE: class-constraint value class ;
 
-: <class-constraint> ( value class -- constraint )
+: is-instance-of ( value class -- constraint )
     [ resolve-copy ] dip class-constraint boa ;
 
 M: class-constraint assume
@@ -52,7 +57,7 @@ M: class-constraint assume
 ! Interval constraints
 TUPLE: interval-constraint value interval ;
 
-: <interval-constraint> ( value interval -- constraint )
+: is-in-interval ( value interval -- constraint )
     [ resolve-copy ] dip interval-constraint boa ;
 
 M: interval-constraint assume
@@ -61,7 +66,7 @@ M: interval-constraint assume
 ! Literal constraints
 TUPLE: literal-constraint value literal ;
 
-: <literal-constraint> ( value literal -- constraint )
+: is-equal-to ( value literal -- constraint )
     [ resolve-copy ] dip literal-constraint boa ;
 
 M: literal-constraint assume
@@ -70,29 +75,48 @@ M: literal-constraint assume
 ! Implication constraints
 TUPLE: implication p q ;
 
-C: <implication> implication
+C: --> implication
 
 M: implication assume
     [ q>> ] [ p>> ] bi
     [ constraints get set-at ]
     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
 
+M: implication satisfiable?
+    [ q>> satisfiable? ] [ p>> satisfiable? not ] bi or ;
+
 ! Conjunction constraints
 TUPLE: conjunction p q ;
 
-C: <conjunction> conjunction
+C: /\ conjunction
 
 M: conjunction assume [ p>> assume ] [ q>> assume ] bi ;
 
+M: conjunction satisfiable?
+    [ p>> satisfiable? ] [ q>> satisfiable? ] bi and ;
+
+! Disjunction constraints
+TUPLE: disjunction p q ;
+
+C: \/ disjunction
+
+M: disjunction assume
+    {
+        { [ dup p>> satisfiable? not ] [ q>> assume ] }
+        { [ dup q>> satisfiable? not ] [ p>> assume ] }
+        [ drop ]
+    } cond ;
+
+M: disjunction satisfiable?
+    [ p>> satisfiable? ] [ q>> satisfiable? ] bi or ;
+
 ! No-op
 M: f assume drop ;
 
 ! Utilities
-: if-true ( constraint boolean-value -- constraint' )
-   <true-constraint> swap <implication> ;
+: t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
 
-: if-false ( constraint boolean-value -- constraint' )
-    <false-constraint> swap <implication> ;
+: f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
 
 : <conditional> ( true-constr false-constr boolean-value -- constraint )
-    tuck [ if-true ] [ if-false ] 2bi* <conjunction> ;
+    tuck [ t--> ] [ f--> ] 2bi* /\ ;
diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor
index 18b9977f7f..41da9e6014 100644
--- a/unfinished/compiler/tree/propagation/info/info-tests.factor
+++ b/unfinished/compiler/tree/propagation/info/info-tests.factor
@@ -2,6 +2,8 @@ USING: accessors math math.intervals sequences classes.algebra
 math kernel tools.test compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.info.tests
 
+[ f ] [ 0.0 -0.0 eql? ] unit-test
+
 [ t ] [
     number <class-info>
     sequence <class-info>
@@ -48,3 +50,14 @@ IN: compiler.tree.propagation.info.tests
     2 3 (a,b] <interval-info> fixnum <class-info>
     value-info-intersect >literal<
 ] unit-test
+
+[ T{ value-info f null empty-interval f f } ] [
+    fixnum -10 0 [a,b] <class/interval-info>
+    fixnum 19 29 [a,b] <class/interval-info>
+    value-info-intersect
+] unit-test
+
+[ 3 t ] [
+    3 <literal-info>
+    null <class-info> value-info-union >literal<
+] unit-test
diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor
index 25872173d0..2572e167a1 100644
--- a/unfinished/compiler/tree/propagation/info/info.factor
+++ b/unfinished/compiler/tree/propagation/info/info.factor
@@ -1,77 +1,99 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs classes classes.algebra kernel accessors math
-math.intervals namespaces disjoint-sets sequences words
-combinators ;
+math.intervals namespaces sequences words combinators arrays
+compiler.tree.copy-equiv ;
 IN: compiler.tree.propagation.info
 
 SYMBOL: +interval+
 
 GENERIC: eql? ( obj1 obj2 -- ? )
 M: object eql? eq? ;
-M: number eql? [ [ class ] bi@ = ] [ number= ] 2bi and ;
-
-! Disjoint set of copy equivalence
-SYMBOL: copies
-
-: is-copy-of ( val copy -- ) copies get equate ;
-
-: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
-
-: resolve-copy ( copy -- val ) copies get representative ;
-
-: introduce-value ( val -- ) copies get add-atom ;
+M: fixnum eql? eq? ;
+M: bignum eql? over bignum? [ = ] [ 2drop f ] if ;
+M: ratio eql? over ratio? [ = ] [ 2drop f ] if ;
+M: float eql? over float? [ [ double>bits ] bi@ = ] [ 2drop f ] if ;
+M: complex eql? over complex? [ = ] [ 2drop f ] if ;
 
 ! Value info represents a set of objects. Don't mutate value infos
 ! you receive, always construct new ones. We don't declare the
 ! slots read-only to allow cloning followed by writing.
 TUPLE: value-info
 { class initial: null }
-interval
+{ interval initial: empty-interval }
 literal
-literal? ;
+literal?
+length ;
 
 : class-interval ( class -- interval )
     dup real class<=
     [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
 
 : interval>literal ( class interval -- literal literal? )
-    dup from>> first {
-        { [ over interval-length 0 > ] [ 3drop f f ] }
-        { [ over from>> second not ] [ 3drop f f ] }
-        { [ over to>> second not ] [ 3drop f f ] }
-        { [ pick fixnum class<= ] [ 2nip >fixnum t ] }
-        { [ pick bignum class<= ] [ 2nip >bignum t ] }
-        { [ pick float class<= ] [ 2nip >float t ] }
-        [ 3drop f f ]
-    } cond ;
-
-: <value-info> ( class interval literal literal? -- info )
-    [
-        2nip
-        [ class ]
-        [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ]
-        [ ]
-        tri t
+    #! If interval has zero length and the class is sufficiently
+    #! precise, we can turn it into a literal
+    dup empty-interval eq? [
+        2drop f f
     ] [
-        drop
-        over null class<= [ drop f f f ] [
-            over integer class<= [ integral-closure ] when
-            2dup interval>literal
+        dup from>> first {
+            { [ over interval-length 0 > ] [ 3drop f f ] }
+            { [ pick bignum class<= ] [ 2nip >bignum t ] }
+            { [ pick integer class<= ] [ 2nip >fixnum t ] }
+            { [ pick float class<= ] [
+                2nip dup zero? [ drop f f ] [ >float t ] if
+            ] }
+            [ 3drop f f ]
+        } cond
+    ] if ;
+
+: <value-info> ( -- info ) \ value-info new ;
+
+: init-value-info ( info -- info )
+    dup literal?>> [
+        dup literal>> class >>class
+        dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
+    ] [
+        dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [
+            null >>class
+            empty-interval >>interval
+        ] [
+            dup class>> integer class<= [ [ integral-closure ] change-interval ] when
+            dup [ class>> ] [ interval>> ] bi interval>literal
+            [ >>literal ] [ >>literal? ] bi*
         ] if
-    ] if
-    \ value-info boa ; foldable
+    ] if ;
+
+: <class/interval-info> ( class interval -- info )
+    <value-info>
+        swap >>interval
+        swap >>class
+    init-value-info ; foldable
 
 : <class-info> ( class -- info )
-    [-inf,inf] f f <value-info> ; foldable
+    dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
+    <class/interval-info> ; foldable
 
 : <interval-info> ( interval -- info )
-    real swap f f <value-info> ; foldable
+    <value-info>
+        real >>class
+        swap >>interval
+    init-value-info ; foldable
 
 : <literal-info> ( literal -- info )
-    f [-inf,inf] rot t <value-info> ; foldable
+    <value-info>
+        swap >>literal
+        t >>literal?
+    init-value-info ; foldable
 
-: >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ;
+: <sequence-info> ( value -- info )
+    <value-info>
+        object >>class
+        [-inf,inf] >>interval
+        swap value-info >>length
+    init-value-info ; foldable
+
+: >literal< ( info -- literal literal? )
+    [ literal>> ] [ literal?>> ] bi ;
 
 : intersect-literals ( info1 info2 -- literal literal? )
     {
@@ -81,21 +103,30 @@ literal? ;
         [ drop >literal< ]
     } cond ;
 
-: interval-intersect' ( i1 i2 -- i3 )
-    #! Change core later.
-    2dup and [ interval-intersect ] [ 2drop f ] if ;
+DEFER: value-info-intersect
 
-: value-info-intersect ( info1 info2 -- info )
-    [ [ class>> ] bi@ class-and ]
-    [ [ interval>> ] bi@ interval-intersect' ]
-    [ intersect-literals ]
-    2tri <value-info> ;
-
-: interval-union' ( i1 i2 -- i3 )
-    {
+: intersect-lengths ( info1 info2 -- length )
+    [ length>> ] bi@ {
         { [ dup not ] [ drop ] }
         { [ over not ] [ nip ] }
-        [ interval-union ]
+        [ value-info-intersect ]
+    } cond ;
+
+: (value-info-intersect) ( info1 info2 -- info )
+    [ <value-info> ] 2dip
+    {
+        [ [ class>> ] bi@ class-and >>class ]
+        [ [ interval>> ] bi@ interval-intersect >>interval ]
+        [ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
+        [ intersect-lengths >>length ]
+    } 2cleave
+    init-value-info ;
+
+: value-info-intersect ( info1 info2 -- info )
+    {
+        { [ dup class>> null class<= ] [ nip ] }
+        { [ over class>> null class<= ] [ drop ] }
+        [ (value-info-intersect) ]
     } cond ;
 
 : union-literals ( info1 info2 -- literal literal? )
@@ -103,11 +134,31 @@ literal? ;
         [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
     ] [ 2drop f f ] if ;
 
+DEFER: value-info-union
+
+: union-lengths ( info1 info2 -- length )
+    [ length>> ] bi@ {
+        { [ dup not ] [ nip ] }
+        { [ over not ] [ drop ] }
+        [ value-info-union ]
+    } cond ;
+
+: (value-info-union) ( info1 info2 -- info )
+    [ <value-info> ] 2dip
+    {
+        [ [ class>> ] bi@ class-or >>class ]
+        [ [ interval>> ] bi@ interval-union >>interval ]
+        [ union-literals [ >>literal ] [ >>literal? ] bi* ]
+        [ union-lengths >>length ]
+    } 2cleave
+    init-value-info ;
+
 : value-info-union ( info1 info2 -- info )
-    [ [ class>> ] bi@ class-or ]
-    [ [ interval>> ] bi@ interval-union' ]
-    [ union-literals ]
-    2tri <value-info> ;
+    {
+        { [ dup class>> null class<= ] [ drop ] }
+        { [ over class>> null class<= ] [ nip ] }
+        [ (value-info-union) ]
+    } cond ;
 
 : value-infos-union ( infos -- info )
     dup first [ value-info-union ] reduce ;
@@ -126,3 +177,18 @@ SYMBOL: value-infos
 
 : value-literal ( value -- obj ? )
     value-info >literal< ;
+
+: possible-boolean-values ( info -- values )
+    dup literal?>> [
+        literal>> 1array
+    ] [
+        class>> {
+            { [ dup null class<= ] [ { } ] }
+            { [ dup \ f class-not class<= ] [ { t } ] }
+            { [ dup \ f class<= ] [ { f } ] }
+            [ { t f } ]
+        } cond nip
+    ] if ;
+
+: value-is? ( value class -- ? )
+    [ value-info class>> ] dip class<= ;
diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor
index 900060feb5..e358dd5be1 100644
--- a/unfinished/compiler/tree/propagation/known-words/known-words.factor
+++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor
@@ -1,12 +1,13 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel effects accessors math math.private math.libm
-math.partial-dispatch math.intervals layouts words sequences
-sequences.private arrays assocs classes classes.algebra
-combinators generic.math fry locals
-compiler.tree.propagation.info
-compiler.tree.propagation.nodes
-compiler.tree.propagation.constraints ;
+math.partial-dispatch math.intervals math.parser math.order
+layouts words sequences sequences.private arrays assocs classes
+classes.algebra combinators generic.math splitting fry locals
+classes.tuple alien.accessors classes.tuple.private
+compiler.tree.propagation.info compiler.tree.propagation.nodes
+compiler.tree.propagation.constraints
+compiler.tree.comparisons ;
 IN: compiler.tree.propagation.known-words
 
 \ fixnum
@@ -66,40 +67,38 @@ most-negative-fixnum most-positive-fixnum [a,b]
 \ abs [ [ interval-abs ] ?change-interval ] +outputs+ set-word-prop
 
 : math-closure ( class -- newclass )
-    { null fixnum bignum integer rational float real number }
-    [ class<= ] with find nip number or ;
-
-: interval-subset?' ( i1 i2 -- ? )
-    {
-        { [ over not ] [ 2drop t ] }
-        { [ dup not ] [ 2drop f ] }
-        [ interval-subset? ]
-    } cond ;
+    { fixnum bignum integer rational float real number object }
+    [ class<= ] with find nip ;
 
 : fits? ( interval class -- ? )
-    +interval+ word-prop interval-subset?' ;
+    +interval+ word-prop interval-subset? ;
 
 : binary-op-class ( info1 info2 -- newclass )
-    [ class>> math-closure ] bi@ math-class-max ;
+    [ class>> ] bi@
+    2dup [ null class<= ] either? [ 2drop null ] [
+        [ math-closure ] bi@ math-class-max
+    ] if ;
 
 : binary-op-interval ( info1 info2 quot -- newinterval )
-    [ [ interval>> ] bi@ 2dup and ] dip [ 2drop f ] if ; inline
-
-: <class/interval-info> ( class interval -- info )
-    [ f f <value-info> ] [ <class-info> ] if* ;
+    [ [ interval>> ] bi@ ] dip call ; inline
 
 : won't-overflow? ( class interval -- ? )
     [ fixnum class<= ] [ fixnum fits? ] bi* and ;
 
 : may-overflow ( class interval -- class' interval' )
-    2dup won't-overflow?
-    [ [ integer math-class-max ] dip ] unless ;
+    over null class<= [
+        2dup won't-overflow?
+        [ [ integer math-class-max ] dip ] unless
+    ] unless ;
 
 : may-be-rational ( class interval -- class' interval' )
     over null class<= [
         [ rational math-class-max ] dip
     ] unless ;
 
+: number-valued ( class interval -- class' interval' )
+    [ number math-class-min ] dip ;
+
 : integer-valued ( class interval -- class' interval' )
     [ integer math-class-min ] dip ;
 
@@ -118,63 +117,35 @@ most-negative-fixnum most-positive-fixnum [a,b]
         <class/interval-info>
     ] +outputs+ set-word-prop ;
 
-\ + [ [ interval+ ] [ may-overflow ] binary-op ] each-derived-op
-\ + [ [ interval+ ] [ ] binary-op ] each-fast-derived-op
+\ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
+\ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
 
-\ - [ [ interval+ ] [ may-overflow ] binary-op ] each-derived-op
-\ - [ [ interval+ ] [ ] binary-op ] each-fast-derived-op
+\ - [ [ interval- ] [ may-overflow number-valued ] binary-op ] each-derived-op
+\ - [ [ interval- ] [ number-valued ] binary-op ] each-fast-derived-op
 
-\ * [ [ interval* ] [ may-overflow ] binary-op ] each-derived-op
-\ * [ [ interval* ] [ ] binary-op ] each-fast-derived-op
+\ * [ [ interval* ] [ may-overflow number-valued ] binary-op ] each-derived-op
+\ * [ [ interval* ] [ number-valued ] binary-op ] each-fast-derived-op
 
-\ shift [ [ interval-shift-safe ] [ may-overflow ] binary-op ] each-derived-op
-\ shift [ [ interval-shift-safe ] [ ] binary-op ] each-fast-derived-op
-
-\ / [ [ interval/-safe ] [ may-be-rational ] binary-op ] each-derived-op
+\ / [ [ interval/-safe ] [ may-be-rational number-valued ] binary-op ] each-derived-op
 \ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
 \ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
 
 \ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
 \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
 
+\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
+\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
+
 \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
 \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
 \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
 
-: assume-interval ( i1 i2 op -- i3 )
-    {
-        { \ < [ assume< ] }
-        { \ > [ assume> ] }
-        { \ <= [ assume<= ] }
-        { \ >= [ assume>= ] }
-    } case ;
-
-: swap-comparison ( op -- op' )
-    {
-        { < > }
-        { > < }
-        { <= >= }
-        { >= <= }
-    } at ;
-
-: negate-comparison ( op -- op' )
-    {
-        { < >= }
-        { > <= }
-        { <= > }
-        { >= < }
-    } at ;
-
 :: (comparison-constraints) ( in1 in2 op -- constraint )
     [let | i1 [ in1 value-info interval>> ]
            i2 [ in2 value-info interval>> ] |
-       i1 i2 and [
-           in1 i1 i2 op assume-interval <interval-constraint>
-           in2 i2 i1 op swap-comparison assume-interval <interval-constraint>
-           <conjunction>
-       ] [
-           f
-       ] if
+       in1 i1 i2 op assumption is-in-interval
+       in2 i2 i1 op swap-comparison assumption is-in-interval
+       /\
     ] ;
 
 : comparison-constraints ( in1 in2 out op -- constraint )
@@ -184,13 +155,35 @@ most-negative-fixnum most-positive-fixnum [a,b]
         3bi
     ] dip <conditional> ;
 
-: comparison-op ( word op -- )
-    '[
-        [ in-d>> first2 ] [ out-d>> first ] bi
-        , comparison-constraints
-    ] +constraints+ set-word-prop ;
+: define-comparison-constraints ( word op -- )
+    '[ , comparison-constraints ] +constraints+ set-word-prop ;
 
-{ < > <= >= } [ dup [ comparison-op ] curry each-derived-op ] each
+comparison-ops
+[ dup '[ , define-comparison-constraints ] each-derived-op ] each
+
+generic-comparison-ops [
+    dup specific-comparison
+    '[ , , define-comparison-constraints ] each-derived-op
+] each
+
+! Remove redundant comparisons
+: fold-comparison ( info1 info2 word -- info )
+    [ [ interval>> ] bi@ ] dip interval-comparison {
+        { incomparable [ object <class-info> ] }
+        { t [ t <literal-info> ] }
+        { f [ f <literal-info> ] }
+    } case ;
+
+comparison-ops [
+    [
+        dup '[ , fold-comparison ] +outputs+ set-word-prop
+    ] each-derived-op
+] each
+
+generic-comparison-ops [
+    dup specific-comparison
+    '[ , fold-comparison ] +outputs+ set-word-prop
+] each
 
 {
     { >fixnum fixnum }
@@ -201,71 +194,46 @@ most-negative-fixnum most-positive-fixnum [a,b]
         ,
         [ nip ] [
             [ interval>> ] [ class-interval ] bi*
-            interval-intersect'
+            interval-intersect
         ] 2bi
         <class/interval-info>
     ] +outputs+ set-word-prop
 ] assoc-each
 
-! 
-! {
-!     alien-signed-1
-!     alien-unsigned-1
-!     alien-signed-2
-!     alien-unsigned-2
-!     alien-signed-4
-!     alien-unsigned-4
-!     alien-signed-8
-!     alien-unsigned-8
-! } [
-!     dup name>> {
-!         {
-!             [ "alien-signed-" ?head ]
-!             [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
-!         }
-!         {
-!             [ "alien-unsigned-" ?head ]
-!             [ string>number 8 * 2^ 1- 0 swap [a,b] ]
-!         }
-!     } cond 1array
-!     [ nip f swap ] curry "output-classes" set-word-prop
-! ] each
-! 
-! 
-! { <tuple> <tuple-boa> (tuple) } [
-!     [
-!         dup node-in-d peek node-literal
-!         dup tuple-layout? [ class>> ] [ drop tuple ] if
-!         1array f
-!     ] "output-classes" set-word-prop
-! ] each
-! 
-! \ new [
-!     dup node-in-d peek node-literal
-!     dup class? [ drop tuple ] unless 1array f
-! ] "output-classes" set-word-prop
-! 
-! ! the output of clone has the same type as the input
-! { clone (clone) } [
-!     [
-!         node-in-d [ value-class* ] map f
-!     ] "output-classes" set-word-prop
-! ] each
-! 
-! ! if the result of eq? is t and the second input is a literal,
-! ! the first input is equal to the second
-! \ eq? [
-!     dup node-in-d second dup value? [
-!         swap [
-!             value-literal 0 `input literal,
-!             \ f class-not 0 `output class,
-!         ] set-constraints
-!     ] [
-!         2drop
-!     ] if
-! ] "constraints" set-word-prop
+{
+    alien-signed-1
+    alien-unsigned-1
+    alien-signed-2
+    alien-unsigned-2
+    alien-signed-4
+    alien-unsigned-4
+    alien-signed-8
+    alien-unsigned-8
+} [
+    dup name>> {
+        {
+            [ "alien-signed-" ?head ]
+            [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
+        }
+        {
+            [ "alien-unsigned-" ?head ]
+            [ string>number 8 * 2^ 1- 0 swap [a,b] ]
+        }
+    } cond
+    [ fixnum fits? fixnum bignum ? ] keep <class/interval-info>
+    [ 2nip ] curry +outputs+ set-word-prop
+] each
 
-: and-constraints ( in1 in2 out -- constraint )
-    [ [ <true-constraint> ] bi@ ] dip <conditional> ;
+{ <tuple> <tuple-boa> } [
+    [
+        literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if
+        [ clear ] dip
+    ] +outputs+ set-word-prop
+] each
 
-! XXX...
+\ new [
+    literal>> dup tuple-class? [ drop tuple ] unless <class-info>
+] +outputs+ set-word-prop
+
+! the output of clone has the same type as the input
+{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each
diff --git a/unfinished/compiler/tree/propagation/nodes/nodes.factor b/unfinished/compiler/tree/propagation/nodes/nodes.factor
index a996e32959..8da5b91f64 100644
--- a/unfinished/compiler/tree/propagation/nodes/nodes.factor
+++ b/unfinished/compiler/tree/propagation/nodes/nodes.factor
@@ -16,9 +16,6 @@ GENERIC: propagate-around ( node -- )
 
 : (propagate) ( node -- )
     [
-        [ node-defs-values [ introduce-value ] each ]
-        [ propagate-around ]
-        [ successor>> ]
-        tri
+        [ propagate-around ] [ successor>> ] bi
         (propagate)
     ] when* ;
diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor
index 06374e7783..5d278b27b0 100644
--- a/unfinished/compiler/tree/propagation/propagation-tests.factor
+++ b/unfinished/compiler/tree/propagation/propagation-tests.factor
@@ -1,10 +1,20 @@
-USING: kernel compiler.frontend compiler.tree
-compiler.tree.propagation tools.test math accessors
-sequences arrays kernel.private ;
+USING: kernel compiler.tree.builder compiler.tree
+compiler.tree.propagation compiler.tree.copy-equiv
+compiler.tree.def-use tools.test math math.order
+accessors sequences arrays kernel.private vectors
+alien.accessors alien.c-types sequences.private
+byte-arrays ;
 IN: compiler.tree.propagation.tests
 
+\ propagate must-infer
+\ propagate/node must-infer
+
 : final-info ( quot -- seq )
-    dataflow propagate last-node node-input-infos ;
+    build-tree
+    compute-def-use
+    compute-copy-equiv
+    propagate
+    last-node node-input-infos ;
 
 : final-classes ( quot -- seq )
     final-info [ class>> ] map ;
@@ -64,7 +74,7 @@ IN: compiler.tree.propagation.tests
     [ { null null } declare + ] final-classes
 ] unit-test
 
-[ V{ fixnum } ] [
+[ V{ null } ] [
     [ { null fixnum } declare + ] final-classes
 ] unit-test
 
@@ -87,3 +97,145 @@ IN: compiler.tree.propagation.tests
 [ V{ fixnum } ] [
     [ >fixnum dup 10 > [ 1 - ] when ] final-classes
 ] unit-test
+
+[ V{ integer } ] [ [ >fixnum 2 * ] final-classes ] unit-test
+
+[ V{ integer } ] [
+    [ >fixnum dup 10 < drop 2 * ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+    [ >fixnum dup 10 < [ 2 * ] when ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+    [ >fixnum dup 10 < [ 2 * ] [ 2 * ] if ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ >fixnum dup 10 < [ dup -10 > [ 2 * ] when ] when ] final-classes
+] unit-test
+
+[ V{ f } ] [
+    [ dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if ] final-literals
+] unit-test
+
+[ V{ 9 } ] [
+    [
+        123 bitand
+        dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if
+    ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [
+        >fixnum
+        dup [ 10 < ] [ -10 > ] bi and not [ 2 * ] unless
+    ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare (clone) ] final-classes
+] unit-test
+
+[ V{ vector } ] [
+    [ vector new ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [
+        [ uchar-nth ] 2keep [ uchar-nth ] 2keep uchar-nth
+        >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
+        255 min 0 max
+    ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 0 dup 10 > [ 2 * ] when ] final-classes
+] unit-test
+
+[ V{ f } ] [
+    [ [ 0.0 ] [ -0.0 ] if ] final-literals
+] unit-test
+
+[ V{ 1.5 } ] [
+    [ /f 1.5 min 1.5 max ] final-literals
+] unit-test
+
+[ V{ 1.5 } ] [
+    [
+        /f
+        dup 1.5 <= [ dup 1.5 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+    ] final-literals
+] unit-test
+
+[ V{ 1.5 } ] [
+    [
+        /f
+        dup 1.5 <= [ dup 10 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+    ] final-literals
+] unit-test
+
+[ V{ f } ] [
+    [
+        /f
+        dup 0.0 <= [ dup 0.0 >= [ drop 0.0 ] unless ] [ drop 0.0 ] if
+    ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 0 dup 10 > [ 100 * ] when ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 0 dup 10 > [ drop "foo" ] when ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare 3 3 - + ] final-classes
+] unit-test
+
+[ V{ t } ] [
+    [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
+] unit-test
+
+[ V{ "d" } ] [
+    [
+        3 {
+            [ "a" ]
+            [ "b" ]
+            [ "c" ]
+            [ "d" ]
+            [ "e" ]
+            [ "f" ]
+            [ "g" ]
+            [ "h" ]
+        } dispatch
+    ] final-literals
+] unit-test
+
+[ V{ "hi" } ] [
+    [ [ "hi" ] [ 123 3 throw ] if ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [ >fixnum dup 100 < [ 1+ ] [ "Oops" throw ] if ] final-classes
+] unit-test
+
+[ V{ -1 } ] [
+    [ 0 dup 100 < not [ 1+ ] [ 1- ] if ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [ [ 1 >r ] [ 2 >r ] if r> 3 + ] final-classes
+] unit-test
+
+[ V{ 2 } ] [
+    [ [ 1 ] [ 1 ] if 1 + ] final-literals
+] unit-test
+
+[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
+
+[ V{ t } ] [ [ [ 10 f <array> ] [ 10 <byte-array> ] if length 10 = ] final-literals ] unit-test
+
+[ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
diff --git a/unfinished/compiler/tree/propagation/propagation.factor b/unfinished/compiler/tree/propagation/propagation.factor
index ff822f6f92..4a8686a1e4 100755
--- a/unfinished/compiler/tree/propagation/propagation.factor
+++ b/unfinished/compiler/tree/propagation/propagation.factor
@@ -1,7 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences namespaces hashtables
-disjoint-sets
 compiler.tree
 compiler.tree.def-use
 compiler.tree.propagation.info
@@ -17,7 +16,6 @@ IN: compiler.tree.propagation
     [
         H{ } clone constraints set
         >hashtable value-infos set
-        <disjoint-set> copies set
         (propagate)
     ] with-scope ;
 
diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor
index 2223e1dd13..731b0d06f7 100644
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor
@@ -8,6 +8,12 @@ compiler.tree.propagation.simple
 compiler.tree.propagation.branches ;
 IN: compiler.tree.propagation.recursive
 
+! What if we reach a fixed point for the phi but not for the
+! #call-label output?
+
+! We need to compute scalar evolution so that sccp doesn't
+! evaluate loops
+
 : (merge-value-infos) ( inputs -- infos )
     [ [ value-info ] map value-infos-union ] map ;
 
@@ -22,11 +28,9 @@ IN: compiler.tree.propagation.recursive
 
 M: #recursive propagate-around ( #recursive -- )
     dup
-    [ children>> (propagate) ]
-    [ node-child propagate-recursive-phi ] bi
+    node-child
+    [ first>> (propagate) ] [ propagate-recursive-phi ] bi
     [ drop ] [ propagate-around ] if ;
 
 M: #call-recursive propagate-before ( #call-label -- )
-    #! What if we reach a fixed point for the phi but not for the
-    #! #call-label output?
     [ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;
diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor
index 1c77fe1fc6..6b8efd77e9 100644
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/unfinished/compiler/tree/propagation/simple/simple.factor
@@ -1,8 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors kernel sequences assocs words namespaces
-classes.algebra combinators classes
+USING: fry accessors kernel sequences sequences.private assocs
+words namespaces classes.algebra combinators classes
+continuations arrays byte-arrays strings
 compiler.tree
+compiler.tree.def-use
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.constraints ;
@@ -25,34 +27,20 @@ M: #push propagate-before
     [ set-value-info ] 2each ;
 
 M: #declare propagate-before
-    [ [ in-d>> ] [ out-d>> ] bi are-copies-of ]
-    [
-        [ declaration>> class-infos ] [ out-d>> ] bi
-        refine-value-infos
-    ] bi ;
-
-M: #shuffle propagate-before
-    [ out-d>> dup ] [ mapping>> ] bi
-    '[ , at ] map swap are-copies-of ;
-
-M: #>r propagate-before
-    [ in-d>> ] [ out-r>> ] bi are-copies-of ;
-
-M: #r> propagate-before
-    [ in-r>> ] [ out-d>> ] bi are-copies-of ;
-
-M: #copy propagate-before
-    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
+    declaration>> [ <class-info> swap refine-value-info ] assoc-each ;
 
 : predicate-constraints ( value class boolean-value -- constraint )
-    [ [ <class-constraint> ] dip if-true ]
-    [ [ class-not <class-constraint> ] dip if-false ]
-    3bi <conjunction> ;
+    [ [ is-instance-of ] dip t--> ]
+    [ [ class-not is-instance-of ] dip f--> ]
+    3bi /\ ;
 
-: compute-constraints ( #call -- constraint )
-    dup word>> +constraints+ word-prop [ call assume ] [
-        dup word>> predicate?
-        [
+: custom-constraints ( #call quot -- )
+    [ [ in-d>> ] [ out-d>> ] bi append ] dip
+    with-datastack first assume ;
+
+: compute-constraints ( #call -- )
+    dup word>> +constraints+ word-prop [ custom-constraints ] [
+        dup word>> predicate? [
             [ in-d>> first ]
             [ word>> "predicating" word-prop ]
             [ out-d>> first ]
@@ -60,6 +48,24 @@ M: #copy propagate-before
         ] [ drop ] if
     ] if* ;
 
+: call-outputs-quot ( node -- infos )
+    [ in-d>> [ value-info ] map ]
+    [ word>> +outputs+ word-prop ]
+    bi with-datastack ;
+
+: foldable-call? ( #call -- ? )
+    dup word>> "foldable" word-prop [
+        in-d>> [ value-info literal?>> ] all?
+    ] [
+        drop f
+    ] if ;
+
+: fold-call ( #call -- infos )
+    [ in-d>> [ value-info literal>> ] map ]
+    [ word>> [ execute ] curry ]
+    bi with-datastack
+    [ <literal-info> ] map ;
+
 : default-output-value-infos ( node -- infos )
     dup word>> "default-output-classes" word-prop [
         class-infos
@@ -67,16 +73,37 @@ M: #copy propagate-before
         out-d>> length object <class-info> <repetition>
     ] ?if ;
 
-: call-outputs-quot ( node quot -- infos )
-    [ in-d>> [ value-info ] map ] dip with-datastack ;
+UNION: fixed-length-sequence array byte-array string ;
 
-: output-value-infos ( node word -- infos )
-    dup word>> +outputs+ word-prop
-    [ call-outputs-quot ] [ default-output-value-infos ] if* ;
+: sequence-constructor? ( node -- ? )
+    word>> { <array> <byte-array> <string> } memq? ;
+
+: propagate-sequence-constructor ( node -- infos )
+    [ default-output-value-infos first ]
+    [ in-d>> first <sequence-info> ]
+    bi value-info-intersect 1array ;
+
+: length-accessor? ( node -- ? )
+    dup in-d>> first fixed-length-sequence value-is?
+    [ word>> \ length eq? ] [ drop f ] if ;
+
+: propagate-length ( node -- infos )
+    in-d>> first value-info length>>
+    [ array-capacity <class-info> ] unless* 1array ;
+
+: output-value-infos ( node -- infos )
+    {
+        { [ dup foldable-call? ] [ fold-call ] }
+        { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
+        { [ dup length-accessor? ] [ propagate-length ] }
+        { [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
+        [ default-output-value-infos ]
+    } cond ;
 
 M: #call propagate-before
+    [ [ output-value-infos ] [ out-d>> ] bi set-value-infos ]
     [ compute-constraints ]
-    [ [ output-value-infos ] [ out-d>> ] bi set-value-infos ] bi ;
+    bi ;
 
 M: node propagate-before drop ;
 
@@ -90,7 +117,10 @@ M: #call propagate-after
 M: node propagate-after drop ;
 
 : annotate-node ( node -- )
-    dup node-values [ dup value-info ] H{ } map>assoc >>info drop ;
+    dup
+    [ node-defs-values ] [ node-uses-values ] bi append
+    [ dup value-info ] H{ } map>assoc
+    >>info drop ;
 
 M: node propagate-around
     [ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;
diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor
index e528a48db9..5d15fc9185 100755
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic assocs kernel math namespaces parser
 sequences words vectors math.intervals effects classes
-accessors combinators stack-checker.state ;
+accessors combinators stack-checker.state stack-checker.visitor ;
 IN: compiler.tree
 
 ! High-level tree SSA form.
@@ -16,20 +16,12 @@ IN: compiler.tree
 ! case of a #phi node, the sequence of sequences in the phi-in-r
 ! and phi-in-d slots.
 ! 3) A value is never used in the same node where it is defined.
-
 TUPLE: node < identity-tuple
 in-d out-d in-r out-r info
-history successor children ;
+successor children ;
 
 M: node hashcode* drop node hashcode* ;
 
-: node-shuffle ( node -- shuffle )
-    [ in-d>> ] [ out-d>> ] bi <effect> ;
-
-: node-values ( node -- values )
-    { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
-    4array concat ;
-
 : node-child ( node -- child ) children>> first ;
 
 : last-node ( node -- last )
@@ -57,7 +49,7 @@ TUPLE: #introduce < node values ;
 : #introduce ( values -- node )
     \ #introduce new swap >>values ;
 
-TUPLE: #call < node word ;
+TUPLE: #call < node word history ;
 
 : #call ( inputs outputs word -- node )
     \ #call new
@@ -137,11 +129,9 @@ TUPLE: #phi < node phi-in-d phi-in-r ;
 
 TUPLE: #declare < node declaration ;
 
-: #declare ( inputs outputs declaration -- node )
+: #declare ( declaration -- node )
     \ #declare new
-        swap >>declaration
-        swap >>out-d
-        swap >>in-d ;
+        swap >>declaration ;
 
 TUPLE: #return < node label ;
 
@@ -172,3 +162,30 @@ DEFER: #tail?
 PREDICATE: #tail-phi < #phi successor>> #tail? ;
 
 UNION: #tail POSTPONE: f #return #tail-phi #terminate ;
+
+TUPLE: node-list first last ;
+
+: node, ( node -- )
+    stack-visitor get swap
+    over last>>
+    [ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
+    [ [ >>first ] [ >>last ] bi drop ]
+    if ;
+
+M: node-list child-visitor node-list new ;
+M: node-list #introduce, #introduce node, ;
+M: node-list #call, #call node, ;
+M: node-list #call-recursive, #call-recursive node, ;
+M: node-list #push, #push node, ;
+M: node-list #shuffle, #shuffle node, ;
+M: node-list #drop, #drop node, ;
+M: node-list #>r, #>r node, ;
+M: node-list #r>, #r> node, ;
+M: node-list #return, #return node, ;
+M: node-list #terminate, #terminate node, ;
+M: node-list #if, #if node, ;
+M: node-list #dispatch, #dispatch node, ;
+M: node-list #phi, #phi node, ;
+M: node-list #declare, #declare node, ;
+M: node-list #recursive, #recursive node, ;
+M: node-list #copy, #copy node, ;
diff --git a/unfinished/compiler/tree/untupling/untupling-tests.factor b/unfinished/compiler/tree/untupling/untupling-tests.factor
new file mode 100644
index 0000000000..27d8a66153
--- /dev/null
+++ b/unfinished/compiler/tree/untupling/untupling-tests.factor
@@ -0,0 +1,50 @@
+IN: compiler.tree.untupling.tests
+USING: assocs math kernel quotations.private slots.private
+compiler.tree.builder
+compiler.tree.def-use
+compiler.tree.copy-equiv
+compiler.tree.untupling
+tools.test ;
+
+: check-untupling ( quot -- sizes )
+    build-tree
+    compute-copy-equiv
+    compute-def-use
+    compute-untupling
+    values ;
+
+[ { } ] [ [ 1 [ + ] curry ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry drop ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry 3 slot ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry 3 slot drop ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 1 [ + ] curry uncurry ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
+
+[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
+
+[ { } ] [ [ [ 1 [ + ] curry ] [ [ ] ] if ] check-untupling ] unit-test
+
+[ { 2 2 } ] [
+    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if uncurry ] check-untupling
+] unit-test
+
+[ { } ] [
+    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if ] check-untupling
+] unit-test
+
+[ { 2 2 2 } ] [
+    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if uncurry ] check-untupling
+] unit-test
+
+[ { 2 2 } ] [
+    [ [ 1 [ + ] curry 4 ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if uncurry ] if ] check-untupling
+] unit-test
+
+[ { } ] [
+    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if ] check-untupling
+] unit-test
diff --git a/unfinished/compiler/tree/untupling/untupling.factor b/unfinished/compiler/tree/untupling/untupling.factor
new file mode 100644
index 0000000000..6fb51e3fa1
--- /dev/null
+++ b/unfinished/compiler/tree/untupling/untupling.factor
@@ -0,0 +1,59 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors slots.private kernel namespaces disjoint-sets
+math sequences assocs classes.tuple.private combinators fry sets
+compiler.tree compiler.tree.combinators compiler.tree.copy-equiv
+compiler.tree.dfa compiler.tree.dfa.backward ;
+IN: compiler.tree.untupling
+
+SYMBOL: escaping-values
+
+: mark-escaping-values ( node -- )
+    in-d>> escaping-values get '[ resolve-copy , conjoin ] each ;
+
+SYMBOL: untupling-candidates
+
+: untupling-candidate ( #call class -- )
+    #! 1- for delegate
+    size>> 1- swap out-d>> first resolve-copy
+    untupling-candidates get set-at ;
+
+GENERIC: compute-untupling* ( node -- )
+
+M: #call compute-untupling*
+    dup word>> {
+        { \ <tuple-boa> [ dup in-d>> peek untupling-candidate ] }
+        { \ curry [ \ curry tuple-layout untupling-candidate ] }
+        { \ compose [ \ compose tuple-layout untupling-candidate ] }
+        { \ slot [ drop ] }
+        [ drop mark-escaping-values ]
+    } case ;
+
+M: #return compute-untupling*
+    dup label>> [ drop ] [ mark-escaping-values ] if ;
+
+M: node compute-untupling* drop ;
+
+GENERIC: check-consistency* ( node -- )
+
+: check-value-consistency ( out-value in-values -- )
+    swap escaping-values get key? [
+        escaping-values get '[ , conjoin ] each
+    ] [
+        untupling-candidates get 2dup '[ , at ] map all-equal?
+        [ 2drop ] [ '[ , delete-at ] each ] if
+    ] if ;
+
+M: #phi check-consistency*
+    [ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ]
+    [ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ]
+    bi ;
+
+M: node check-consistency* drop ;
+
+: compute-untupling ( node -- assoc )
+    H{ } clone escaping-values set
+    H{ } clone untupling-candidates set
+    [ [ compute-untupling* ] each-node ]
+    [ [ check-consistency* ] each-node ] bi
+    untupling-candidates get escaping-values get assoc-diff ;
diff --git a/unfinished/stack-checker/backend/backend.factor b/unfinished/stack-checker/backend/backend.factor
index 645e4d0c1e..900980c0ea 100755
--- a/unfinished/stack-checker/backend/backend.factor
+++ b/unfinished/stack-checker/backend/backend.factor
@@ -11,6 +11,8 @@ IN: stack-checker.backend
 ! Word properties we use
 SYMBOL: +inferred-effect+
 SYMBOL: +cannot-infer+
+SYMBOL: +special+
+SYMBOL: +shuffle+
 SYMBOL: +infer+
 
 SYMBOL: visited
@@ -174,7 +176,7 @@ M: object apply-object push-literal ;
         [
             init-inference
             init-known-values
-            dataflow-visitor off
+            stack-visitor off
             dependencies off
             [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
             [ finish-word current-effect ]
@@ -191,32 +193,19 @@ M: object apply-object push-literal ;
 : call-recursive-word ( word -- )
     dup required-stack-effect apply-word/effect ;
 
-: custom-infer ( word -- )
-    [ +inlined+ depends-on ] [ +infer+ word-prop call ] bi ;
-
 : cached-infer ( word -- )
     dup +inferred-effect+ word-prop apply-word/effect ;
 
-: non-inline-word ( word -- )
-    dup +called+ depends-on
-    {
-        { [ dup recursive-label ] [ call-recursive-word ] }
-        { [ dup +infer+ word-prop ] [ custom-infer ] }
-        { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
-        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
-        [ dup infer-word apply-word/effect ]
-    } cond ;
-
 : with-infer ( quot -- effect visitor )
     [
         [
             V{ } clone recorded set
             init-inference
             init-known-values
-            dataflow-visitor off
+            stack-visitor off
             call
             end-infer
             current-effect
-            dataflow-visitor get
+            stack-visitor get
         ] [ ] [ undo-infer ] cleanup
-    ] with-scope ;
+    ] with-scope ; inline
diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor
index 55aa452c10..613cf31161 100644
--- a/unfinished/stack-checker/branches/branches.factor
+++ b/unfinished/stack-checker/branches/branches.factor
@@ -65,10 +65,21 @@ SYMBOL: quotations
 : infer-branches ( branches -- input children data )
     [ pop-d ] dip
     [ infer-branch ] map
-    [ dataflow-visitor branch-variable ] keep ;
+    [ stack-visitor branch-variable ] keep ;
 
-: infer-if ( branches -- )
+: (infer-if) ( branches -- )
     infer-branches [ first2 #if, ] dip compute-phi-function ;
 
-: infer-dispatch ( branches -- )
+: infer-if ( -- )
+    2 consume-d
+    dup [ known [ curry? ] [ composed? ] bi or ] contains? [
+        output-d
+        [ rot [ drop call ] [ nip call ] if ]
+        recursive-state get infer-quot
+    ] [
+        [ #drop, ] [ [ literal ] map (infer-if) ] bi
+    ] if ;
+
+: infer-dispatch ( -- )
+    pop-literal nip [ <literal> ] map
     infer-branches [ #dispatch, ] dip compute-phi-function ;
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index 45252f117f..7c24ddf9ea 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -6,7 +6,8 @@ stack-checker.state
 stack-checker.visitor
 stack-checker.backend
 stack-checker.branches
-stack-checker.errors ;
+stack-checker.errors
+stack-checker.known-words ;
 IN: stack-checker.inlining
 
 ! Code to handle inline words. Much of the complexity stems from
@@ -80,7 +81,7 @@ SYMBOL: phi-out
 
         dup recursive-word-inputs
         meta-d get
-        dataflow-visitor get
+        stack-visitor get
     ] with-scope ;
 
 : inline-recursive-word ( word -- )
diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index 362c4f1394..01991147f7 100755
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -2,26 +2,25 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors alien alien.accessors arrays byte-arrays
 classes sequences.private continuations.private effects generic
-hashtables hashtables.private io io.backend io.files io.files.private
-io.streams.c kernel kernel.private math math.private memory
-namespaces namespaces.private parser prettyprint quotations
-quotations.private sbufs sbufs.private sequences
-sequences.private slots.private strings strings.private system
-threads.private classes.tuple classes.tuple.private vectors
-vectors.private words words.private assocs summary
-compiler.units system.private
-stack-checker.state stack-checker.backend stack-checker.branches
-stack-checker.errors stack-checker.visitor ;
+hashtables hashtables.private io io.backend io.files
+io.files.private io.streams.c kernel kernel.private math
+math.private memory namespaces namespaces.private parser
+prettyprint quotations quotations.private sbufs sbufs.private
+sequences sequences.private slots.private strings
+strings.private system threads.private classes.tuple
+classes.tuple.private vectors vectors.private words definitions
+words.private assocs summary compiler.units system.private
+combinators locals.backend stack-checker.state
+stack-checker.backend stack-checker.branches
+stack-checker.errors stack-checker.transforms
+stack-checker.visitor ;
 IN: stack-checker.known-words
 
-: infer-shuffle ( shuffle -- )
-    [ in>> length consume-d ] keep ! inputs shuffle
-    [ drop ] [ shuffle* dup copy-values dup output-d ] 2bi ! inputs outputs copies
-    [ nip ] [ swap zip ] 2bi ! inputs copies mapping
-    #shuffle, ;
-
-: define-shuffle ( word shuffle -- )
-    '[ , infer-shuffle ] +infer+ set-word-prop ;
+: infer-primitive ( word -- )
+    dup
+    [ "input-classes" word-prop ]
+    [ "default-output-classes" word-prop ] bi <effect>
+    apply-word/effect ;
 
 {
     { drop  (( x     --             )) }
@@ -40,19 +39,22 @@ IN: stack-checker.known-words
     { over  (( x y   -- x y x       )) }
     { pick  (( x y z -- x y z x     )) }
     { swap  (( x y   -- y x         )) }
-} [ define-shuffle ] assoc-each
+} [ +shuffle+ set-word-prop ] assoc-each
 
-\ >r [ 1 infer->r ] +infer+ set-word-prop
-\ r> [ 1 infer-r> ] +infer+ set-word-prop
+: infer-shuffle ( shuffle -- )
+    [ in>> length consume-d ] keep ! inputs shuffle
+    [ drop ] [ shuffle* dup copy-values dup output-d ] 2bi ! inputs outputs copies
+    [ nip ] [ swap zip ] 2bi ! inputs copies mapping
+    #shuffle, ;
 
+: infer-shuffle-word ( word -- )
+    +shuffle+ word-prop infer-shuffle ;
 
-\ declare [
+: infer-declare ( -- )
     pop-literal nip
-    [ length consume-d dup copy-values dup output-d ] keep
-    #declare,
-] +infer+ set-word-prop
+    [ length ensure-d ] keep zip
+    #declare, ;
 
-! Primitive combinators
 GENERIC: infer-call* ( value known -- )
 
 : infer-call ( value -- ) dup known infer-call* ;
@@ -73,495 +75,524 @@ M: composed infer-call*
     [ quot2>> known pop-d [ set-known ] keep ]
     [ quot1>> known pop-d [ set-known ] keep ] bi
     push-d push-d
-    [ slip call ] recursive-state get infer-quot ;
+    1 infer->r pop-d infer-call
+    terminated? get [ 1 infer-r> pop-d infer-call ] unless ;
 
 M: object infer-call*
     \ literal-expected inference-warning ;
 
-\ call [ pop-d infer-call ] +infer+ set-word-prop
-
-\ call t "no-compile" set-word-prop
-
-\ curry [
+: infer-curry ( -- )
     2 consume-d
     dup first2 <curried> make-known
     [ push-d ] [ 1array ] bi
-    \ curry #call,
-] +infer+ set-word-prop
+    \ curry #call, ;
 
-\ compose [
+: infer-compose ( -- )
     2 consume-d
     dup first2 <composed> make-known
     [ push-d ] [ 1array ] bi
-    \ compose #call,
-] +infer+ set-word-prop
+    \ compose #call, ;
 
-\ execute [
+: infer-execute ( -- )
     pop-literal nip
     dup word? [
         apply-object
     ] [
         drop
         "execute must be given a word" time-bomb
-    ] if
-] +infer+ set-word-prop
+    ] if ;
 
-\ execute t "no-compile" set-word-prop
-
-\ if [
-    2 consume-d
-    dup [ known [ curry? ] [ composed? ] bi or ] contains? [
-        output-d
-        [ rot [ drop call ] [ nip call ] if ]
-        recursive-state get infer-quot
-    ] [
-        [ #drop, ] [ [ literal ] map infer-if ] bi
-    ] if
-] +infer+ set-word-prop
-
-\ dispatch [
-    pop-literal nip [ <literal> ] map infer-dispatch
-] +infer+ set-word-prop
-
-\ dispatch t "no-compile" set-word-prop
-
-! Variadic tuple constructor
-\ <tuple-boa> [
+: infer-<tuple-boa> ( -- )
     \ <tuple-boa>
     peek-d literal value>> size>> { tuple } <effect>
-    apply-word/effect
-] +infer+ set-word-prop
+    apply-word/effect ;
 
-! Non-standard control flow
-\ (throw) [
+: infer-(throw) ( -- )
     \ (throw)
     peek-d literal value>> 2 + f <effect> t >>terminated?
-    apply-word/effect
-] +infer+ set-word-prop
+    apply-word/effect ;
 
-:  set-primitive-effect ( word effect -- )
-    [ in>> "input-classes" set-word-prop ]
-    [ out>> "default-output-classes" set-word-prop ]
-    [ dupd '[ , , apply-word/effect ] +infer+ set-word-prop ]
-    2tri ;
+: infer-exit ( -- )
+    \ exit
+    { integer } { } t >>terminated? <effect>
+    apply-word/effect ;
+
+: infer-load-locals ( -- )
+    pop-literal nip
+    [ dup reverse <effect> infer-shuffle ]
+    [ infer->r ]
+    bi ;
+
+: infer-get-local ( -- )
+    pop-literal nip
+    [ infer-r> ]
+    [ dup 0 prefix <effect> infer-shuffle ]
+    [ infer->r ]
+    tri ;
+
+: infer-drop-locals ( -- )
+    pop-literal nip
+    [ infer-r> ]
+    [ { } <effect> infer-shuffle ] bi ;
+
+: infer-special ( word -- )
+    {
+        { \ >r [ 1 infer->r ] }
+        { \ r> [ 1 infer-r> ] }
+        { \ declare [ infer-declare ] }
+        { \ call [ pop-d infer-call ] }
+        { \ curry [ infer-curry ] }
+        { \ compose [ infer-compose ] }
+        { \ execute [ infer-execute ] }
+        { \ if [ infer-if ] }
+        { \ dispatch [ infer-dispatch ] }
+        { \ <tuple-boa> [ infer-<tuple-boa> ] }
+        { \ (throw) [ infer-(throw) ] }
+        { \ exit [ infer-exit ] }
+        { \ load-locals [ infer-load-locals ] }
+        { \ get-local [ infer-get-local ] }
+        { \ drop-locals [ infer-drop-locals ] }
+        { \ do-primitive [ \ do-primitive cannot-infer-effect ] }
+    } case ;
+
+{
+    >r r> declare call curry compose
+    execute if dispatch <tuple-boa>
+    (throw) load-locals get-local drop-locals
+    do-primitive
+} [ t +special+ set-word-prop ] each
+
+{ call execute dispatch load-locals get-local drop-locals }
+[ t "no-compile" set-word-prop ] each
+
+: 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 +cannot-infer+ word-prop ] [ cannot-infer-effect ] }
+        { [ dup +inferred-effect+ word-prop ] [ cached-infer ] }
+        { [ dup +transform-quot+ word-prop ] [ apply-transform ] }
+        { [ dup "macro" word-prop ] [ apply-macro ] }
+        { [ dup recursive-label ] [ call-recursive-word ] }
+        [ dup infer-word apply-word/effect ]
+    } cond ;
+
+: define-primitive ( word inputs outputs -- )
+    [ drop "input-classes" set-word-prop ]
+    [ nip "default-output-classes" set-word-prop ]
+    3bi ;
 
 ! Stack effects for all primitives
-\ fixnum< { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum< { fixnum fixnum } { object } define-primitive
 \ fixnum< make-foldable
 
-\ fixnum<= { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum<= { fixnum fixnum } { object } define-primitive
 \ fixnum<= make-foldable
 
-\ fixnum> { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum> { fixnum fixnum } { object } define-primitive
 \ fixnum> make-foldable
 
-\ fixnum>= { fixnum fixnum } { object } <effect> set-primitive-effect
+\ fixnum>= { fixnum fixnum } { object } define-primitive
 \ fixnum>= make-foldable
 
-\ eq? { object object } { object } <effect> set-primitive-effect
+\ eq? { object object } { object } define-primitive
 \ eq? make-foldable
 
-\ rehash-string { string } { } <effect> set-primitive-effect
-
-\ bignum>fixnum { bignum } { fixnum } <effect> set-primitive-effect
+\ bignum>fixnum { bignum } { fixnum } define-primitive
 \ bignum>fixnum make-foldable
 
-\ float>fixnum { float } { fixnum } <effect> set-primitive-effect
+\ float>fixnum { float } { fixnum } define-primitive
 \ bignum>fixnum make-foldable
 
-\ fixnum>bignum { fixnum } { bignum } <effect> set-primitive-effect
+\ fixnum>bignum { fixnum } { bignum } define-primitive
 \ fixnum>bignum make-foldable
 
-\ float>bignum { float } { bignum } <effect> set-primitive-effect
+\ float>bignum { float } { bignum } define-primitive
 \ float>bignum make-foldable
 
-\ fixnum>float { fixnum } { float } <effect> set-primitive-effect
+\ fixnum>float { fixnum } { float } define-primitive
 \ fixnum>float make-foldable
 
-\ bignum>float { bignum } { float } <effect> set-primitive-effect
+\ bignum>float { bignum } { float } define-primitive
 \ bignum>float make-foldable
 
-\ <ratio> { integer integer } { ratio } <effect> set-primitive-effect
+\ <ratio> { integer integer } { ratio } define-primitive
 \ <ratio> make-foldable
 
-\ string>float { string } { float } <effect> set-primitive-effect
+\ string>float { string } { float } define-primitive
 \ string>float make-foldable
 
-\ float>string { float } { string } <effect> set-primitive-effect
+\ float>string { float } { string } define-primitive
 \ float>string make-foldable
 
-\ float>bits { real } { integer } <effect> set-primitive-effect
+\ float>bits { real } { integer } define-primitive
 \ float>bits make-foldable
 
-\ double>bits { real } { integer } <effect> set-primitive-effect
+\ double>bits { real } { integer } define-primitive
 \ double>bits make-foldable
 
-\ bits>float { integer } { float } <effect> set-primitive-effect
+\ bits>float { integer } { float } define-primitive
 \ bits>float make-foldable
 
-\ bits>double { integer } { float } <effect> set-primitive-effect
+\ bits>double { integer } { float } define-primitive
 \ bits>double make-foldable
 
-\ <complex> { real real } { complex } <effect> set-primitive-effect
+\ <complex> { real real } { complex } define-primitive
 \ <complex> make-foldable
 
-\ fixnum+ { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum+ { fixnum fixnum } { integer } define-primitive
 \ fixnum+ make-foldable
 
-\ fixnum+fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum+fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum+fast make-foldable
 
-\ fixnum- { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum- { fixnum fixnum } { integer } define-primitive
 \ fixnum- make-foldable
 
-\ fixnum-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-fast make-foldable
 
-\ fixnum* { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum* { fixnum fixnum } { integer } define-primitive
 \ fixnum* make-foldable
 
-\ fixnum*fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum*fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum*fast make-foldable
 
-\ fixnum/i { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum/i { fixnum fixnum } { integer } define-primitive
 \ fixnum/i make-foldable
 
-\ fixnum-mod { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-mod { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-mod make-foldable
 
-\ fixnum/mod { fixnum fixnum } { integer fixnum } <effect> set-primitive-effect
+\ fixnum/mod { fixnum fixnum } { integer fixnum } define-primitive
 \ fixnum/mod make-foldable
 
-\ fixnum-bitand { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitand { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-bitand make-foldable
 
-\ fixnum-bitor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitor { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-bitor make-foldable
 
-\ fixnum-bitxor { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitxor { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-bitxor make-foldable
 
-\ fixnum-bitnot { fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-bitnot { fixnum } { fixnum } define-primitive
 \ fixnum-bitnot make-foldable
 
-\ fixnum-shift { fixnum fixnum } { integer } <effect> set-primitive-effect
+\ fixnum-shift { fixnum fixnum } { integer } define-primitive
 \ fixnum-shift make-foldable
 
-\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> set-primitive-effect
+\ fixnum-shift-fast { fixnum fixnum } { fixnum } define-primitive
 \ fixnum-shift-fast make-foldable
 
-\ bignum= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum= { bignum bignum } { object } define-primitive
 \ bignum= make-foldable
 
-\ bignum+ { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum+ { bignum bignum } { bignum } define-primitive
 \ bignum+ make-foldable
 
-\ bignum- { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum- { bignum bignum } { bignum } define-primitive
 \ bignum- make-foldable
 
-\ bignum* { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum* { bignum bignum } { bignum } define-primitive
 \ bignum* make-foldable
 
-\ bignum/i { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum/i { bignum bignum } { bignum } define-primitive
 \ bignum/i make-foldable
 
-\ bignum-mod { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-mod { bignum bignum } { bignum } define-primitive
 \ bignum-mod make-foldable
 
-\ bignum/mod { bignum bignum } { bignum bignum } <effect> set-primitive-effect
+\ bignum/mod { bignum bignum } { bignum bignum } define-primitive
 \ bignum/mod make-foldable
 
-\ bignum-bitand { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitand { bignum bignum } { bignum } define-primitive
 \ bignum-bitand make-foldable
 
-\ bignum-bitor { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitor { bignum bignum } { bignum } define-primitive
 \ bignum-bitor make-foldable
 
-\ bignum-bitxor { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitxor { bignum bignum } { bignum } define-primitive
 \ bignum-bitxor make-foldable
 
-\ bignum-bitnot { bignum } { bignum } <effect> set-primitive-effect
+\ bignum-bitnot { bignum } { bignum } define-primitive
 \ bignum-bitnot make-foldable
 
-\ bignum-shift { bignum bignum } { bignum } <effect> set-primitive-effect
+\ bignum-shift { bignum bignum } { bignum } define-primitive
 \ bignum-shift make-foldable
 
-\ bignum< { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum< { bignum bignum } { object } define-primitive
 \ bignum< make-foldable
 
-\ bignum<= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum<= { bignum bignum } { object } define-primitive
 \ bignum<= make-foldable
 
-\ bignum> { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum> { bignum bignum } { object } define-primitive
 \ bignum> make-foldable
 
-\ bignum>= { bignum bignum } { object } <effect> set-primitive-effect
+\ bignum>= { bignum bignum } { object } define-primitive
 \ bignum>= make-foldable
 
-\ bignum-bit? { bignum integer } { object } <effect> set-primitive-effect
+\ bignum-bit? { bignum integer } { object } define-primitive
 \ bignum-bit? make-foldable
 
-\ bignum-log2 { bignum } { bignum } <effect> set-primitive-effect
+\ bignum-log2 { bignum } { bignum } define-primitive
 \ bignum-log2 make-foldable
 
-\ byte-array>bignum { byte-array } { bignum } <effect> set-primitive-effect
+\ byte-array>bignum { byte-array } { bignum } define-primitive
 \ byte-array>bignum make-foldable
 
-\ float= { float float } { object } <effect> set-primitive-effect
+\ float= { float float } { object } define-primitive
 \ float= make-foldable
 
-\ float+ { float float } { float } <effect> set-primitive-effect
+\ float+ { float float } { float } define-primitive
 \ float+ make-foldable
 
-\ float- { float float } { float } <effect> set-primitive-effect
+\ float- { float float } { float } define-primitive
 \ float- make-foldable
 
-\ float* { float float } { float } <effect> set-primitive-effect
+\ float* { float float } { float } define-primitive
 \ float* make-foldable
 
-\ float/f { float float } { float } <effect> set-primitive-effect
+\ float/f { float float } { float } define-primitive
 \ float/f make-foldable
 
-\ float< { float float } { object } <effect> set-primitive-effect
+\ float< { float float } { object } define-primitive
 \ float< make-foldable
 
-\ float-mod { float float } { float } <effect> set-primitive-effect
+\ float-mod { float float } { float } define-primitive
 \ float-mod make-foldable
 
-\ float<= { float float } { object } <effect> set-primitive-effect
+\ float<= { float float } { object } define-primitive
 \ float<= make-foldable
 
-\ float> { float float } { object } <effect> set-primitive-effect
+\ float> { float float } { object } define-primitive
 \ float> make-foldable
 
-\ float>= { float float } { object } <effect> set-primitive-effect
+\ float>= { float float } { object } define-primitive
 \ float>= make-foldable
 
-\ <word> { object object } { word } <effect> set-primitive-effect
+\ <word> { object object } { word } define-primitive
 \ <word> make-flushable
 
-\ word-xt { word } { integer integer } <effect> set-primitive-effect
+\ word-xt { word } { integer integer } define-primitive
 \ word-xt make-flushable
 
-\ getenv { fixnum } { object } <effect> set-primitive-effect
+\ getenv { fixnum } { object } define-primitive
 \ getenv make-flushable
 
-\ setenv { object fixnum } { } <effect> set-primitive-effect
+\ setenv { object fixnum } { } define-primitive
 
-\ (exists?) { string } { object } <effect> set-primitive-effect
+\ (exists?) { string } { object } define-primitive
 
-\ (directory) { string } { array } <effect> set-primitive-effect
+\ (directory) { string } { array } define-primitive
 
-\ gc { } { } <effect> set-primitive-effect
+\ gc { } { } define-primitive
 
-\ gc-stats { } { array } <effect> set-primitive-effect
+\ gc-stats { } { array } define-primitive
 
-\ save-image { string } { } <effect> set-primitive-effect
+\ save-image { string } { } define-primitive
 
-\ save-image-and-exit { string } { } <effect> set-primitive-effect
+\ save-image-and-exit { string } { } define-primitive
 
-\ exit { integer } { } <effect> t >>terminated? set-primitive-effect
-
-\ data-room { } { integer integer array } <effect> set-primitive-effect
+\ data-room { } { integer integer array } define-primitive
 \ data-room make-flushable
 
-\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
+\ code-room { } { integer integer integer integer } define-primitive
 \ code-room  make-flushable
 
-\ os-env { string } { object } <effect> set-primitive-effect
+\ os-env { string } { object } define-primitive
 
-\ millis { } { integer } <effect> set-primitive-effect
+\ millis { } { integer } define-primitive
 \ millis make-flushable
 
-\ tag { object } { fixnum } <effect> set-primitive-effect
+\ tag { object } { fixnum } define-primitive
 \ tag make-foldable
 
-\ cwd { } { string } <effect> set-primitive-effect
+\ dlopen { string } { dll } define-primitive
 
-\ cd { string } { } <effect> set-primitive-effect
+\ dlsym { string object } { c-ptr } define-primitive
 
-\ dlopen { string } { dll } <effect> set-primitive-effect
+\ dlclose { dll } { } define-primitive
 
-\ dlsym { string object } { c-ptr } <effect> set-primitive-effect
-
-\ dlclose { dll } { } <effect> set-primitive-effect
-
-\ <byte-array> { integer } { byte-array } <effect> set-primitive-effect
+\ <byte-array> { integer } { byte-array } define-primitive
 \ <byte-array> make-flushable
 
-\ <displaced-alien> { integer c-ptr } { c-ptr } <effect> set-primitive-effect
+\ <displaced-alien> { integer c-ptr } { c-ptr } define-primitive
 \ <displaced-alien> make-flushable
 
-\ alien-signed-cell { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-cell { c-ptr integer } { integer } define-primitive
 \ alien-signed-cell make-flushable
 
-\ set-alien-signed-cell { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-cell { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-cell { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-cell { c-ptr integer } { integer } define-primitive
 \ alien-unsigned-cell make-flushable
 
-\ set-alien-unsigned-cell { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-cell { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-8 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-8 { c-ptr integer } { integer } define-primitive
 \ alien-signed-8 make-flushable
 
-\ set-alien-signed-8 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-8 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-8 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-8 { c-ptr integer } { integer } define-primitive
 \ alien-unsigned-8 make-flushable
 
-\ set-alien-unsigned-8 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-8 { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-4 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-signed-4 { c-ptr integer } { integer } define-primitive
 \ alien-signed-4 make-flushable
 
-\ set-alien-signed-4 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-4 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-4 { c-ptr integer } { integer } <effect> set-primitive-effect
+\ alien-unsigned-4 { c-ptr integer } { integer } define-primitive
 \ alien-unsigned-4 make-flushable
 
-\ set-alien-unsigned-4 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-4 { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-signed-2 { c-ptr integer } { fixnum } define-primitive
 \ alien-signed-2 make-flushable
 
-\ set-alien-signed-2 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-2 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-2 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-unsigned-2 { c-ptr integer } { fixnum } define-primitive
 \ alien-unsigned-2 make-flushable
 
-\ set-alien-unsigned-2 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-2 { integer c-ptr integer } { } define-primitive
 
-\ alien-signed-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-signed-1 { c-ptr integer } { fixnum } define-primitive
 \ alien-signed-1 make-flushable
 
-\ set-alien-signed-1 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-signed-1 { integer c-ptr integer } { } define-primitive
 
-\ alien-unsigned-1 { c-ptr integer } { fixnum } <effect> set-primitive-effect
+\ alien-unsigned-1 { c-ptr integer } { fixnum } define-primitive
 \ alien-unsigned-1 make-flushable
 
-\ set-alien-unsigned-1 { integer c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-unsigned-1 { integer c-ptr integer } { } define-primitive
 
-\ alien-float { c-ptr integer } { float } <effect> set-primitive-effect
+\ alien-float { c-ptr integer } { float } define-primitive
 \ alien-float make-flushable
 
-\ set-alien-float { float c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-float { float c-ptr integer } { } define-primitive
 
-\ alien-double { c-ptr integer } { float } <effect> set-primitive-effect
+\ alien-double { c-ptr integer } { float } define-primitive
 \ alien-double make-flushable
 
-\ set-alien-double { float c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-double { float c-ptr integer } { } define-primitive
 
-\ alien-cell { c-ptr integer } { simple-c-ptr } <effect> set-primitive-effect
+\ alien-cell { c-ptr integer } { simple-c-ptr } define-primitive
 \ alien-cell make-flushable
 
-\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
+\ set-alien-cell { c-ptr c-ptr integer } { } define-primitive
 
-\ alien-address { alien } { integer } <effect> set-primitive-effect
+\ alien-address { alien } { integer } define-primitive
 \ alien-address make-flushable
 
-\ slot { object fixnum } { object } <effect> set-primitive-effect
+\ slot { object fixnum } { object } define-primitive
 \ slot make-flushable
 
-\ set-slot { object object fixnum } { } <effect> set-primitive-effect
+\ set-slot { object object fixnum } { } define-primitive
 
-\ string-nth { fixnum string } { fixnum } <effect> set-primitive-effect
+\ string-nth { fixnum string } { fixnum } define-primitive
 \ string-nth make-flushable
 
-\ set-string-nth { fixnum fixnum string } { } <effect> set-primitive-effect
+\ set-string-nth { fixnum fixnum string } { } define-primitive
 
-\ resize-array { integer array } { array } <effect> set-primitive-effect
+\ resize-array { integer array } { array } define-primitive
 \ resize-array make-flushable
 
-\ resize-byte-array { integer byte-array } { byte-array } <effect> set-primitive-effect
+\ resize-byte-array { integer byte-array } { byte-array } define-primitive
 \ resize-byte-array make-flushable
 
-\ resize-string { integer string } { string } <effect> set-primitive-effect
+\ resize-string { integer string } { string } define-primitive
 \ resize-string make-flushable
 
-\ <array> { integer object } { array } <effect> set-primitive-effect
+\ <array> { integer object } { array } define-primitive
 \ <array> make-flushable
 
-\ begin-scan { } { } <effect> set-primitive-effect
+\ begin-scan { } { } define-primitive
 
-\ next-object { } { object } <effect> set-primitive-effect
+\ next-object { } { object } define-primitive
 
-\ end-scan { } { } <effect> set-primitive-effect
+\ end-scan { } { } define-primitive
 
-\ size { object } { fixnum } <effect> set-primitive-effect
+\ size { object } { fixnum } define-primitive
 \ size make-flushable
 
-\ die { } { } <effect> set-primitive-effect
+\ die { } { } define-primitive
 
-\ fopen { string string } { alien } <effect> set-primitive-effect
+\ fopen { string string } { alien } define-primitive
 
-\ fgetc { alien } { object } <effect> set-primitive-effect
+\ fgetc { alien } { object } define-primitive
 
-\ fwrite { string alien } { } <effect> set-primitive-effect
+\ fwrite { string alien } { } define-primitive
 
-\ fputc { object alien } { } <effect> set-primitive-effect
+\ fputc { object alien } { } define-primitive
 
-\ fread { integer string } { object } <effect> set-primitive-effect
+\ fread { integer string } { object } define-primitive
 
-\ fflush { alien } { } <effect> set-primitive-effect
+\ fflush { alien } { } define-primitive
 
-\ fclose { alien } { } <effect> set-primitive-effect
+\ fclose { alien } { } define-primitive
 
-\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
+\ <wrapper> { object } { wrapper } define-primitive
 \ <wrapper> make-foldable
 
-\ (clone) { object } { object } <effect> set-primitive-effect
+\ (clone) { object } { object } define-primitive
 \ (clone) make-flushable
 
-\ <string> { integer integer } { string } <effect> set-primitive-effect
+\ <string> { integer integer } { string } define-primitive
 \ <string> make-flushable
 
-\ array>quotation { array } { quotation } <effect> set-primitive-effect
+\ array>quotation { array } { quotation } define-primitive
 \ array>quotation make-flushable
 
-\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
+\ quotation-xt { quotation } { integer } define-primitive
 \ quotation-xt make-flushable
 
-\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
+\ <tuple> { tuple-layout } { tuple } define-primitive
 \ <tuple> make-flushable
 
-\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
+\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } define-primitive
 \ <tuple-layout> make-foldable
 
-\ datastack { } { array } <effect> set-primitive-effect
+\ datastack { } { array } define-primitive
 \ datastack make-flushable
 
-\ retainstack { } { array } <effect> set-primitive-effect
+\ retainstack { } { array } define-primitive
 \ retainstack make-flushable
 
-\ callstack { } { callstack } <effect> set-primitive-effect
+\ callstack { } { callstack } define-primitive
 \ callstack make-flushable
 
-\ callstack>array { callstack } { array } <effect> set-primitive-effect
+\ callstack>array { callstack } { array } define-primitive
 \ callstack>array make-flushable
 
-\ (sleep) { integer } { } <effect> set-primitive-effect
+\ (sleep) { integer } { } define-primitive
 
-\ become { array array } { } <effect> set-primitive-effect
+\ become { array array } { } define-primitive
 
-\ innermost-frame-quot { callstack } { quotation } <effect> set-primitive-effect
+\ innermost-frame-quot { callstack } { quotation } define-primitive
 
-\ innermost-frame-scan { callstack } { fixnum } <effect> set-primitive-effect
+\ innermost-frame-scan { callstack } { fixnum } define-primitive
 
-\ set-innermost-frame-quot { quotation callstack } { } <effect> set-primitive-effect
+\ set-innermost-frame-quot { quotation callstack } { } define-primitive
 
-\ (os-envs) { } { array } <effect> set-primitive-effect
+\ (os-envs) { } { array } define-primitive
 
-\ set-os-env { string string } { } <effect> set-primitive-effect
+\ set-os-env { string string } { } define-primitive
 
-\ unset-os-env { string } { } <effect> set-primitive-effect
+\ unset-os-env { string } { } define-primitive
 
-\ (set-os-envs) { array } { } <effect> set-primitive-effect
+\ (set-os-envs) { array } { } define-primitive
 
 \ do-primitive [ \ do-primitive cannot-infer-effect ] +infer+ set-word-prop
 
-\ dll-valid? { object } { object } <effect> set-primitive-effect
+\ dll-valid? { object } { object } define-primitive
 
-\ modify-code-heap { array object } { } <effect> set-primitive-effect
+\ modify-code-heap { array object } { } define-primitive
 
-\ unimplemented { } { } <effect> set-primitive-effect
+\ unimplemented { } { } define-primitive
diff --git a/unfinished/stack-checker/stack-checker-tests.factor b/unfinished/stack-checker/stack-checker-tests.factor
index acc3d7c0a4..e6dfbbdf26 100755
--- a/unfinished/stack-checker/stack-checker-tests.factor
+++ b/unfinished/stack-checker/stack-checker-tests.factor
@@ -9,6 +9,8 @@ threads.private io.streams.string io.timeouts io.thread
 sequences.private destructors combinators ;
 IN: stack-checker.tests
 
+\ infer. must-infer
+
 { 0 2 } [ 2 "Hello" ] must-infer-as
 { 1 2 } [ dup ] must-infer-as
 
diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor
index c379bced75..8b0f903074 100755
--- a/unfinished/stack-checker/transforms/transforms.factor
+++ b/unfinished/stack-checker/transforms/transforms.factor
@@ -3,24 +3,43 @@
 USING: fry accessors arrays kernel words sequences generic math
 namespaces quotations assocs combinators classes.tuple
 classes.tuple.private effects summary hashtables classes generic
-sets definitions generic.standard slots.private
+sets definitions generic.standard slots.private continuations
 stack-checker.backend stack-checker.state stack-checker.errors ;
 IN: stack-checker.transforms
 
-: transform-quot ( quot n -- newquot )
+SYMBOL: +transform-quot+
+SYMBOL: +transform-n+
+
+: (apply-transform) ( quot n -- newquot )
     dup zero? [
-        drop '[ recursive-state get @ ]
+        drop recursive-state get 1array
     ] [
-        swap '[
-            , consume-d
-            [ first literal recursion>> ]
-            [ [ literal value>> ] each ] bi @
-        ]
+        consume-d
+        [ [ literal value>> ] map ]
+        [ first literal recursion>> ] bi prefix
     ] if
-    '[ @ swap infer-quot ] ;
+    swap with-datastack ;
+
+: apply-transform ( word -- )
+    [ +inlined+ depends-on ] [
+        [ +transform-quot+ word-prop ]
+        [ +transform-n+ word-prop ]
+        bi (apply-transform)
+        first2 swap infer-quot
+    ] bi ;
+
+: apply-macro ( word -- )
+    [ +inlined+ depends-on ] [
+        [ "macro" word-prop ]
+        [ "declared-effect" word-prop in>> length ]
+        bi (apply-transform)
+        first2 swap infer-quot
+    ] bi ;
 
 : define-transform ( word quot n -- )
-    transform-quot +infer+ set-word-prop ;
+    [ drop +transform-quot+ set-word-prop ]
+    [ nip +transform-n+ set-word-prop ]
+    3bi ;
 
 ! Combinators
 \ cond [ cond>quot ] 1 define-transform
diff --git a/unfinished/stack-checker/visitor/dummy/dummy.factor b/unfinished/stack-checker/visitor/dummy/dummy.factor
index 0bbf25193c..dc20d6acb1 100644
--- a/unfinished/stack-checker/visitor/dummy/dummy.factor
+++ b/unfinished/stack-checker/visitor/dummy/dummy.factor
@@ -16,7 +16,7 @@ M: f #terminate, ;
 M: f #if, 3drop ;
 M: f #dispatch, 2drop ;
 M: f #phi, 2drop 2drop ;
-M: f #declare, 3drop ;
+M: f #declare, drop ;
 M: f #recursive, drop drop drop drop drop ;
 M: f #copy, 2drop ;
 M: f #drop, drop ;
diff --git a/unfinished/stack-checker/visitor/visitor.factor b/unfinished/stack-checker/visitor/visitor.factor
index 18c914ba1c..de9fa947c7 100644
--- a/unfinished/stack-checker/visitor/visitor.factor
+++ b/unfinished/stack-checker/visitor/visitor.factor
@@ -3,25 +3,25 @@
 USING: kernel arrays namespaces ;
 IN: stack-checker.visitor
 
-SYMBOL: dataflow-visitor
+SYMBOL: stack-visitor
 
-HOOK: child-visitor dataflow-visitor ( -- visitor )
+HOOK: child-visitor stack-visitor ( -- visitor )
 
-: nest-visitor ( -- ) child-visitor dataflow-visitor set ;
+: nest-visitor ( -- ) child-visitor stack-visitor set ;
 
-HOOK: #introduce, dataflow-visitor ( values -- )
-HOOK: #call, dataflow-visitor ( inputs outputs word -- )
-HOOK: #call-recursive, dataflow-visitor ( inputs outputs word -- )
-HOOK: #push, dataflow-visitor ( literal value -- )
-HOOK: #shuffle, dataflow-visitor ( inputs outputs mapping -- )
-HOOK: #drop, dataflow-visitor ( values -- )
-HOOK: #>r, dataflow-visitor ( inputs outputs -- )
-HOOK: #r>, dataflow-visitor ( inputs outputs -- )
-HOOK: #terminate, dataflow-visitor ( -- )
-HOOK: #if, dataflow-visitor ( ? true false -- )
-HOOK: #dispatch, dataflow-visitor ( n branches -- )
-HOOK: #phi, dataflow-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
-HOOK: #declare, dataflow-visitor ( inputs outputs declaration -- )
-HOOK: #return, dataflow-visitor ( label stack -- )
-HOOK: #recursive, dataflow-visitor ( word label inputs outputs visitor -- )
-HOOK: #copy, dataflow-visitor ( inputs outputs -- )
+HOOK: #introduce, stack-visitor ( values -- )
+HOOK: #call, stack-visitor ( inputs outputs word -- )
+HOOK: #call-recursive, stack-visitor ( inputs outputs word -- )
+HOOK: #push, stack-visitor ( literal value -- )
+HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
+HOOK: #drop, stack-visitor ( values -- )
+HOOK: #>r, stack-visitor ( inputs outputs -- )
+HOOK: #r>, stack-visitor ( inputs outputs -- )
+HOOK: #terminate, stack-visitor ( -- )
+HOOK: #if, stack-visitor ( ? true false -- )
+HOOK: #dispatch, stack-visitor ( n branches -- )
+HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
+HOOK: #declare, stack-visitor ( declaration -- )
+HOOK: #return, stack-visitor ( label stack -- )
+HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- )
+HOOK: #copy, stack-visitor ( inputs outputs -- )