diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor
index 89e2397045..4ad61afd19 100644
--- a/unfinished/compiler/tree/dead-code/dead-code.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code.factor
@@ -77,8 +77,8 @@ M: #shuffle propagate* mapping>> at look-at-value ;
 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>> flip ] bi look-at-corresponding ]
-    [ [ out-r>> ] [ phi-in-r>> flip ] bi look-at-corresponding ]
+    [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
+    [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
     2bi ;
 
 M: node propagate* 2drop ;
@@ -139,15 +139,15 @@ M: #copy remove-dead-values* remove-dead-copies ;
 
 : remove-dead-phi-d ( #phi -- #phi )
     dup
-    [ phi-in-d>> flip ] [ out-d>> ] bi
+    [ phi-in-d>> ] [ out-d>> ] bi
     filter-corresponding-values
-    [ flip >>phi-in-d ] [ >>out-d ] bi* ;
+    [ >>phi-in-d ] [ >>out-d ] bi* ;
 
 : remove-dead-phi-r ( #phi -- #phi )
     dup
-    [ phi-in-r>> flip ] [ out-r>> ] bi
+    [ phi-in-r>> ] [ out-r>> ] bi
     filter-corresponding-values
-    [ flip >>phi-in-r ] [ >>out-r ] bi* ;
+    [ >>phi-in-r ] [ >>out-r ] bi* ;
 
 M: #phi remove-dead-values*
     remove-dead-phi-d
diff --git a/unfinished/compiler/tree/def-use/def-use.factor b/unfinished/compiler/tree/def-use/def-use.factor
index 7a1485826b..cc5b1aaf57 100755
--- a/unfinished/compiler/tree/def-use/def-use.factor
+++ b/unfinished/compiler/tree/def-use/def-use.factor
@@ -29,7 +29,8 @@ TUPLE: definition value node uses ;
 GENERIC: node-uses-values ( node -- values )
 
 M: #phi node-uses-values
-    [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi append ;
+    [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi
+    append sift prune ;
 
 M: #r> node-uses-values in-r>> ;
 
@@ -43,12 +44,9 @@ M: #>r node-defs-values out-r>> ;
 
 M: node node-defs-values out-d>> ;
 
-: each-value ( node values quot -- )
-    [ sift ] dip with each ; inline
-
 : node-def-use ( node -- )
-    [ dup node-uses-values [ use-value ] each-value ]
-    [ dup node-defs-values [ def-value ] each-value ] bi ;
+    [ dup node-uses-values [ use-value ] with each ]
+    [ dup node-defs-values [ def-value ] with each ] bi ;
 
 : check-def-use ( -- )
     def-use get [
diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor
index 98ca00df9e..b95b7f0750 100644
--- a/unfinished/compiler/tree/propagation/branches/branches.factor
+++ b/unfinished/compiler/tree/propagation/branches/branches.factor
@@ -3,6 +3,9 @@
 USING: fry kernel sequences assocs accessors namespaces
 math.intervals arrays classes.algebra
 compiler.tree
+compiler.tree.def-use
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
 compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.branches
@@ -11,60 +14,36 @@ IN: compiler.tree.propagation.branches
 GENERIC: child-constraints ( node -- seq )
 
 M: #if child-constraints
-    [
-        \ f class-not 0 `input class,
-        f 0 `input literal,
-    ] make-constraints ;
+    in-d>> first
+    [ <true-constraint> ] [ <false-constraint> ] bi
+    2array ;
 
-M: #dispatch child-constraints
-    dup [
-        children>> length [ 0 `input literal, ] each
-    ] make-constraints ;
-
-DEFER: (propagate)
+M: #dispatch child-constraints drop f ;
 
 : infer-children ( node -- assocs )
     [ children>> ] [ child-constraints ] bi [
         [
-            value-classes [ clone ] change
-            value-literals [ clone ] change
-            value-intervals [ clone ] change
+            value-infos [ clone ] change
             constraints [ clone ] change
-            apply-constraint
+            assume
             (propagate)
         ] H{ } make-assoc
     ] 2map ;
 
-: merge-classes ( inputs outputs results -- )
-    '[
-        , null
-        [ [ value-class ] bind class-or ] 2reduce
-        _ set-value-class
-    ] 2each ;
+: (merge-value-infos) ( inputs results -- infos )
+    '[ , [ [ value-info ] bind ] 2map value-infos-union ] map ;
 
-: merge-intervals ( inputs outputs results -- )
-    '[
-        , [ [ value-interval ] bind ] 2map
-        dup first [ interval-union ] reduce
-        _ set-value-interval
-    ] 2each ;
+: merge-value-infos ( results inputs outputs -- )
+    [ swap (merge-value-infos) ] dip set-value-infos ;
 
-: merge-literals ( inputs outputs results -- )
-    '[
-        , [ [ value-literal 2array ] bind ] 2map
-        dup all-eq? [ first first2 ] [ drop f f ] if
-        _ swap [ set-value-literal ] [ 2drop ] if
-    ] 2each ;
-
-: merge-stuff ( inputs outputs results -- )
-    [ merge-classes ] [ merge-intervals ] [ merge-literals ] 3tri ;
+: 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 ;
 
 : merge-children ( results node -- )
-    successor>> dup #phi? [
-        [ [ phi-in-d>> ] [ out-d>> ] bi rot merge-stuff ]
-        [ [ phi-in-r>> ] [ out-r>> ] bi rot merge-stuff ]
-        2bi
-    ] [ 2drop ] if ;
+    successor>> propagate-branch-phi ;
 
 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 628de3e039..0d4216a649 100644
--- a/unfinished/compiler/tree/propagation/constraints/constraints.factor
+++ b/unfinished/compiler/tree/propagation/constraints/constraints.factor
@@ -2,145 +2,97 @@
 ! 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 ;
+combinators words compiler.tree compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.constraints
 
 ! A constraint is a statement about a value.
 
-! We need a notion of equality which doesn't recurse so cannot
-! infinite loop on circular data
-GENERIC: eql? ( obj1 obj2 -- ? )
-M: object eql? eq? ;
-M: number eql? number= ;
-
-! Maps constraints to constraints
+! Maps constraints to constraints ("A implies B")
 SYMBOL: constraints
 
-TUPLE: literal-constraint literal value ;
+GENERIC: assume ( constraint -- )
+GENERIC: satisfied? ( constraint -- ? )
 
-C: <literal-constraint> literal-constraint
+! Boolean constraints
+TUPLE: true-constraint value ;
 
-M: literal-constraint equal?
-    over literal-constraint? [
-        [ [ literal>> ] bi@ eql? ]
-        [ [ value>>   ] bi@ =    ]
-        2bi and
-    ] [ 2drop f ] if ;
+: <true-constraint> ( value -- constriant )
+    resolve-copy true-constraint boa ;
 
-TUPLE: class-constraint class value ;
+M: true-constraint assume
+    [ constraints get at [ assume ] when* ]
+    [ \ f class-not <class-info> swap value>> refine-value-info ]
+    bi ;
 
-C: <class-constraint> class-constraint
+M: true-constraint satisfied?
+    value>> value-info class>> \ f class-not class<= ;
 
-TUPLE: interval-constraint interval value ;
+TUPLE: false-constraint value ;
 
-C: <interval-constraint> interval-constraint
+: <false-constraint> ( value -- constriant )
+    resolve-copy false-constraint boa ;
 
-GENERIC: apply-constraint ( constraint -- )
-GENERIC: constraint-satisfied? ( constraint -- ? )
+M: false-constraint assume
+    [ constraints get at [ assume ] when* ]
+    [ \ f <class-info> swap value>> refine-value-info ]
+    bi ;
 
-: `input ( n -- value ) node get in-d>> nth ;
-: `output ( n -- value ) node get out-d>> nth ;
-: class, ( class value -- ) <class-constraint> , ;
-: literal, ( literal value -- ) <literal-constraint> , ;
-: interval, ( interval value -- ) <interval-constraint> , ;
+M: false-constraint satisfied?
+    value>> value-info class>> \ f class-not class<= ;
 
-M: f apply-constraint drop ;
+! Class constraints
+TUPLE: class-constraint value class ;
 
-: make-constraints ( node quot -- constraint )
-    [ swap node set call ] { } make ; inline
+: <class-constraint> ( value class -- constraint )
+    [ resolve-copy ] dip class-constraint boa ;
 
-: set-constraints ( node quot -- )
-    make-constraints
-    unclip [ 2array ] reduce
-    apply-constraint ; inline
+M: class-constraint assume
+    [ class>> <class-info> ] [ value>> ] bi refine-value-info ;
 
-: assume ( constraint -- )
-    constraints get at [ apply-constraint ] when* ;
+! Interval constraints
+TUPLE: interval-constraint value interval ;
 
-! Disjoint set of copy equivalence
-SYMBOL: copies
+: <interval-constraint> ( value interval -- constraint )
+    [ resolve-copy ] dip interval-constraint boa ;
 
-: is-copy-of ( val copy -- ) copies get equate ;
+M: interval-constraint assume
+    [ interval>> <interval-info> ] [ value>> ] bi refine-value-info ;
 
-: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
+! Literal constraints
+TUPLE: literal-constraint value literal ;
 
-: resolve-copy ( copy -- val ) copies get representative ;
+: <literal-constraint> ( value literal -- constraint )
+    [ resolve-copy ] dip literal-constraint boa ;
 
-: introduce-value ( val -- ) copies get add-atom ;
+M: literal-constraint assume
+    [ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
 
-! Current value --> literal mapping
-SYMBOL: value-literals
+! Implication constraints
+TUPLE: implication p q ;
 
-! Current value --> interval mapping
-SYMBOL: value-intervals
+C: <implication> implication
 
-! Current value --> class mapping
-SYMBOL: value-classes
-
-: value-interval ( value -- interval/f )
-    resolve-copy value-intervals get at ;
-
-: set-value-interval ( interval value -- )
-    resolve-copy value-intervals get set-at ;
-
-: intersect-value-interval ( interval value -- )
-    resolve-copy value-intervals get [ interval-intersect ] change-at ;
-
-M: interval-constraint apply-constraint
-    [ interval>> ] [ value>> ] bi intersect-value-interval ;
-
-: set-class-interval ( class value -- )
-    over class? [
-        [ "interval" word-prop ] dip over
-        [ resolve-copy set-value-interval ] [ 2drop ] if
-    ] [ 2drop ] if ;
-
-: value-class ( value -- class )
-    resolve-copy value-classes get at null or ;
-
-: set-value-class ( class value -- )
-    resolve-copy over [
-        dup value-intervals get at [
-            2dup set-class-interval
-        ] unless
-        2dup <class-constraint> assume
-    ] when
-    value-classes get set-at ;
-
-: intersect-value-class ( class value -- )
-    resolve-copy value-classes get [ class-and ] change-at ;
-
-M: class-constraint apply-constraint
-    [ class>> ] [ value>> ] bi intersect-value-class ;
-
-: literal-interval ( value -- interval/f )
-    dup real? [ [a,a] ] [ drop f ] if ;
-
-: value-literal ( value -- obj ? )
-    resolve-copy value-literals get at* ;
-
-: set-value-literal ( literal value -- )
-    resolve-copy {
-        [ [ class ] dip set-value-class ]
-        [ [ literal-interval ] dip set-value-interval ]
-        [ <literal-constraint> assume ]
-        [ value-literals get set-at ]
-    } 2cleave ;
-
-M: literal-constraint apply-constraint
-    [ literal>> ] [ value>> ] bi set-value-literal ;
-
-M: literal-constraint constraint-satisfied?
-    dup value>> value-literal
-    [ swap literal>> eql? ] [ 2drop f ] if ;
-
-M: class-constraint constraint-satisfied?
-    [ value>> value-class ] [ class>> ] bi class<= ;
-
-M: pair apply-constraint
-    first2
+M: implication assume
+    [ q>> ] [ p>> ] bi
     [ constraints get set-at ]
-    [ constraint-satisfied? [ apply-constraint ] [ drop ] if ] 2bi ;
+    [ satisfied? [ assume ] [ drop ] if ] 2bi ;
 
-M: pair constraint-satisfied?
-    first constraint-satisfied? ;
+! Conjunction constraints
+TUPLE: conjunction p q ;
+
+C: <conjunction> conjunction
+
+M: conjunction assume [ p>> assume ] [ q>> assume ] bi ;
+
+! No-op
+M: f assume drop ;
+
+! Utilities
+: if-true ( constraint boolean-value -- constraint' )
+   <true-constraint> swap <implication> ;
+
+: if-false ( constraint boolean-value -- constraint' )
+    <false-constraint> swap <implication> ;
+
+: <conditional> ( true-constr false-constr boolean-value -- constraint )
+    tuck [ if-true ] [ if-false ] 2bi* <conjunction> ;
diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor
new file mode 100644
index 0000000000..18b9977f7f
--- /dev/null
+++ b/unfinished/compiler/tree/propagation/info/info-tests.factor
@@ -0,0 +1,50 @@
+USING: accessors math math.intervals sequences classes.algebra
+math kernel tools.test compiler.tree.propagation.info ;
+IN: compiler.tree.propagation.info.tests
+
+[ t ] [
+    number <class-info>
+    sequence <class-info>
+    value-info-intersect
+    class>> integer class=
+] unit-test
+
+[ t t ] [
+    0 10 [a,b] <interval-info>
+    5 20 [a,b] <interval-info>
+    value-info-intersect
+    [ class>> real class= ]
+    [ interval>> 5 10 [a,b] = ]
+    bi
+] unit-test
+
+[ float 10.0 t ] [
+    10.0 <literal-info>
+    10.0 <literal-info>
+    value-info-intersect
+    [ class>> ] [ >literal< ] bi
+] unit-test
+
+[ null ] [
+    10 <literal-info>
+    10.0 <literal-info>
+    value-info-intersect
+    class>>
+] unit-test
+
+[ fixnum 10 t ] [
+    10 <literal-info>
+    10 <literal-info>
+    value-info-union
+    [ class>> ] [ >literal< ] bi
+] unit-test
+
+[ 3.0 t ] [
+    3 3 [a,b] <interval-info> float <class-info>
+    value-info-intersect >literal<
+] unit-test
+
+[ 3 t ] [
+    2 3 (a,b] <interval-info> fixnum <class-info>
+    value-info-intersect >literal<
+] unit-test
diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor
new file mode 100644
index 0000000000..25872173d0
--- /dev/null
+++ b/unfinished/compiler/tree/propagation/info/info.factor
@@ -0,0 +1,128 @@
+! 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 ;
+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 ;
+
+! 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
+literal
+literal? ;
+
+: 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
+    ] [
+        drop
+        over null class<= [ drop f f f ] [
+            over integer class<= [ integral-closure ] when
+            2dup interval>literal
+        ] if
+    ] if
+    \ value-info boa ; foldable
+
+: <class-info> ( class -- info )
+    [-inf,inf] f f <value-info> ; foldable
+
+: <interval-info> ( interval -- info )
+    real swap f f <value-info> ; foldable
+
+: <literal-info> ( literal -- info )
+    f [-inf,inf] rot t <value-info> ; foldable
+
+: >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ;
+
+: intersect-literals ( info1 info2 -- literal literal? )
+    {
+        { [ dup literal?>> not ] [ drop >literal< ] }
+        { [ over literal?>> not ] [ nip >literal< ] }
+        { [ 2dup [ literal>> ] bi@ eql? not ] [ 2drop f f ] }
+        [ drop >literal< ]
+    } cond ;
+
+: interval-intersect' ( i1 i2 -- i3 )
+    #! Change core later.
+    2dup and [ interval-intersect ] [ 2drop f ] if ;
+
+: value-info-intersect ( info1 info2 -- info )
+    [ [ class>> ] bi@ class-and ]
+    [ [ interval>> ] bi@ interval-intersect' ]
+    [ intersect-literals ]
+    2tri <value-info> ;
+
+: interval-union' ( i1 i2 -- i3 )
+    {
+        { [ dup not ] [ drop ] }
+        { [ over not ] [ nip ] }
+        [ interval-union ]
+    } cond ;
+
+: union-literals ( info1 info2 -- literal literal? )
+    2dup [ literal?>> ] both? [
+        [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
+    ] [ 2drop f f ] if ;
+
+: value-info-union ( info1 info2 -- info )
+    [ [ class>> ] bi@ class-or ]
+    [ [ interval>> ] bi@ interval-union' ]
+    [ union-literals ]
+    2tri <value-info> ;
+
+: value-infos-union ( infos -- info )
+    dup first [ value-info-union ] reduce ;
+
+! Current value --> info mapping
+SYMBOL: value-infos
+
+: value-info ( value -- info )
+    resolve-copy value-infos get at T{ value-info } or ;
+
+: set-value-info ( info value -- )
+    resolve-copy value-infos get set-at ;
+
+: refine-value-info ( info value -- )
+    resolve-copy value-infos get [ value-info-intersect ] change-at ;
+
+: value-literal ( value -- obj ? )
+    value-info >literal< ;
diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor
new file mode 100644
index 0000000000..900060feb5
--- /dev/null
+++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor
@@ -0,0 +1,271 @@
+! 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 ;
+IN: compiler.tree.propagation.known-words
+
+\ fixnum
+most-negative-fixnum most-positive-fixnum [a,b]
++interval+ set-word-prop
+
+\ array-capacity
+0 max-array-capacity [a,b]
++interval+ set-word-prop
+
+{ + - * / }
+[ { number number } "input-classes" set-word-prop ] each
+
+{ /f < > <= >= }
+[ { real real } "input-classes" set-word-prop ] each
+
+{ /i mod /mod }
+[ { rational rational } "input-classes" set-word-prop ] each
+
+{ bitand bitor bitxor bitnot shift }
+[ { integer integer } "input-classes" set-word-prop ] each
+
+\ bitnot { integer } "input-classes" set-word-prop
+
+{
+    fcosh
+    flog
+    fsinh
+    fexp
+    fasin
+    facosh
+    fasinh
+    ftanh
+    fatanh
+    facos
+    fpow
+    fatan
+    fatan2
+    fcos
+    ftan
+    fsin
+    fsqrt
+} [
+    dup stack-effect
+    [ in>> length real <repetition> "input-classes" set-word-prop ]
+    [ out>> length float <repetition> "default-output-classes" set-word-prop ]
+    2bi
+] each
+
+: ?change-interval ( info quot -- quot' )
+    over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
+
+{ bitnot fixnum-bitnot bignum-bitnot } [
+    [ [ interval-bitnot ] ?change-interval ] +outputs+ set-word-prop
+] each
+
+\ 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 ;
+
+: fits? ( interval class -- ? )
+    +interval+ word-prop interval-subset?' ;
+
+: binary-op-class ( info1 info2 -- newclass )
+    [ class>> math-closure ] bi@ math-class-max ;
+
+: 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* ;
+
+: 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 ;
+
+: may-be-rational ( class interval -- class' interval' )
+    over null class<= [
+        [ rational math-class-max ] dip
+    ] unless ;
+
+: integer-valued ( class interval -- class' interval' )
+    [ integer math-class-min ] dip ;
+
+: real-valued ( class interval -- class' interval' )
+    [ real math-class-min ] dip ;
+
+: float-valued ( class interval -- class' interval' )
+    over null class<= [
+        [ drop float ] dip
+    ] unless ;
+
+: binary-op ( word interval-quot post-proc-quot -- )
+    '[
+        [ binary-op-class ] [ , binary-op-interval ] 2bi
+        @
+        <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 ] binary-op ] each-derived-op
+\ - [ [ interval+ ] [ ] binary-op ] each-fast-derived-op
+
+\ * [ [ interval* ] [ may-overflow ] binary-op ] each-derived-op
+\ * [ [ interval* ] [ ] 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
+\ /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
+
+\ 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
+    ] ;
+
+: comparison-constraints ( in1 in2 out op -- constraint )
+    swap [
+        [ (comparison-constraints) ]
+        [ negate-comparison (comparison-constraints) ]
+        3bi
+    ] dip <conditional> ;
+
+: comparison-op ( word op -- )
+    '[
+        [ in-d>> first2 ] [ out-d>> first ] bi
+        , comparison-constraints
+    ] +constraints+ set-word-prop ;
+
+{ < > <= >= } [ dup [ comparison-op ] curry each-derived-op ] each
+
+{
+    { >fixnum fixnum }
+    { >bignum bignum }
+    { >float float }
+} [
+    '[
+        ,
+        [ nip ] [
+            [ interval>> ] [ class-interval ] bi*
+            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
+
+: and-constraints ( in1 in2 out -- constraint )
+    [ [ <true-constraint> ] bi@ ] dip <conditional> ;
+
+! XXX...
diff --git a/unfinished/compiler/tree/propagation/nodes/nodes.factor b/unfinished/compiler/tree/propagation/nodes/nodes.factor
new file mode 100644
index 0000000000..a996e32959
--- /dev/null
+++ b/unfinished/compiler/tree/propagation/nodes/nodes.factor
@@ -0,0 +1,24 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences accessors kernel
+compiler.tree.def-use
+compiler.tree.propagation.info ;
+IN: compiler.tree.propagation.nodes
+
+SYMBOL: +constraints+
+SYMBOL: +outputs+
+
+GENERIC: propagate-before ( node -- )
+
+GENERIC: propagate-after ( node -- )
+
+GENERIC: propagate-around ( node -- )
+
+: (propagate) ( node -- )
+    [
+        [ node-defs-values [ introduce-value ] each ]
+        [ propagate-around ]
+        [ successor>> ]
+        tri
+        (propagate)
+    ] when* ;
diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor
new file mode 100644
index 0000000000..06374e7783
--- /dev/null
+++ b/unfinished/compiler/tree/propagation/propagation-tests.factor
@@ -0,0 +1,89 @@
+USING: kernel compiler.frontend compiler.tree
+compiler.tree.propagation tools.test math accessors
+sequences arrays kernel.private ;
+IN: compiler.tree.propagation.tests
+
+: final-info ( quot -- seq )
+    dataflow propagate last-node node-input-infos ;
+
+: final-classes ( quot -- seq )
+    final-info [ class>> ] map ;
+
+: final-literals ( quot -- seq )
+    final-info [ literal>> ] map ;
+
+[ V{ } ] [ [ ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 1 >r r> ] final-classes ] unit-test
+
+[ V{ fixnum object } ] [ [ 1 swap ] final-classes ] unit-test
+
+[ V{ array } ] [ [ 10 f <array> ] final-classes ] unit-test
+
+[ V{ array } ] [ [ { array } declare ] final-classes ] unit-test
+
+[ V{ array } ] [ [ 10 f <array> swap [ ] [ ] if ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ dup fixnum? [ ] [ drop 3 ] if ] final-classes ] unit-test
+
+[ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
+
+[ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
+
+[ V{ number } ] [ [ + ] final-classes ] unit-test
+
+[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test
+
+[ V{ float } ] [ [ /f ] final-classes ] unit-test
+
+[ V{ integer } ] [ [ /i ] final-classes ] unit-test
+
+[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
+
+[ V{ integer } ] [
+    [ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [
+        { fixnum } declare [ 255 bitand ] [ 65535 bitand ] bi +
+    ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+    [ { fixnum } declare [ 255 bitand ] keep + ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+    [ { fixnum } declare 615949 * ] final-classes
+] unit-test
+
+[ V{ null } ] [
+    [ { null null } declare + ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { null fixnum } declare + ] final-classes
+] unit-test
+
+[ V{ float } ] [
+    [ { float fixnum } declare + ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 255 bitand >fixnum 3 bitor ] final-classes
+] unit-test
+
+[ V{ 0 } ] [
+    [ >fixnum 1 mod ] final-literals
+] unit-test
+
+[ V{ 69 } ] [
+    [ >fixnum swap [ 1 mod 69 + ] [ drop 69 ] if ] final-literals
+] unit-test
+
+[ V{ fixnum } ] [
+    [ >fixnum dup 10 > [ 1 - ] when ] final-classes
+] unit-test
diff --git a/unfinished/compiler/tree/propagation/propagation.factor b/unfinished/compiler/tree/propagation/propagation.factor
index f8e760ea0c..ff822f6f92 100755
--- a/unfinished/compiler/tree/propagation/propagation.factor
+++ b/unfinished/compiler/tree/propagation/propagation.factor
@@ -1,37 +1,28 @@
 ! 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.constraints
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
 compiler.tree.propagation.branches
-compiler.tree.propagation.recursive ;
+compiler.tree.propagation.recursive
+compiler.tree.propagation.constraints
+compiler.tree.propagation.known-words ;
 IN: compiler.tree.propagation
 
-: (propagate) ( node -- )
-    [
-        [ node-defs-values [ introduce-value ] each ]
-        [ propagate-around ]
-        [ successor>> ]
-        tri
-        (propagate)
-    ] when* ;
-
-: propagate-with ( node classes literals intervals -- )
+: propagate-with ( node infos -- )
     [
         H{ } clone constraints set
-        >hashtable value-intervals set
-        >hashtable value-literals set
-        >hashtable value-classes set
+        >hashtable value-infos set
+        <disjoint-set> copies set
         (propagate)
     ] with-scope ;
 
 : propagate ( node -- node )
-    dup f f f propagate-with ;
+    dup f propagate-with ;
 
 : propagate/node ( node existing -- )
-    #! Infer classes, using the existing node's class info as a
-    #! starting point.
-    [ classes>> ] [ literals>> ] [ intervals>> ] tri
-    propagate-with ;
+    info>> propagate-with ;
diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor
index b19dbd9052..2223e1dd13 100644
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor
@@ -1,72 +1,32 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.tree compiler.tree.propagation.simple
+USING: kernel sequences accessors
+compiler.tree
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
+compiler.tree.propagation.simple
 compiler.tree.propagation.branches ;
 IN: compiler.tree.propagation.recursive
 
-! M: #recursive child-constraints
-!     drop { f } ;
-! 
-! M: #recursive propagate-around
-!     [ infer-children ] [ merge-children ] [ annotate-node ] tri ;
-! 
-! : classes= ( inferred current -- ? )
-!     2dup min-length '[ , tail* ] bi@ sequence= ;
-! 
-! SYMBOL: fixed-point?
-! 
-! SYMBOL: nested-labels
-! 
-! : annotate-entry ( nodes #label -- )
-!     [ (merge-classes) ] dip node-child
-!     2dup node-output-classes classes=
-!     [ 2drop ] [ set-classes fixed-point? off ] if ;
-! 
-! : init-recursive-calls ( #label -- )
-!     #! We set recursive calls to output the empty type, then
-!     #! repeat inference until a fixed point is reached.
-!     #! Hopefully, our type functions are monotonic so this
-!     #! will always converge.
-!     returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
-! 
-! M: #label propagate-before ( #label -- )
-!     [ init-recursive-calls ]
-!     [ [ 1array ] keep annotate-entry ] bi ;
-! 
-! : infer-label-loop ( #label -- )
-!     fixed-point? on
-!     dup node-child (propagate)
-!     dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
-!     fixed-point? get [ drop ] [ infer-label-loop ] if ;
-! 
-! M: #label propagate-around ( #label -- )
-!     #! Now merge the types at every recursion point with the
-!     #! entry types.
-!     [
-!         {
-!             [ nested-labels get push ]
-!             [ annotate-node ]
-!             [ propagate-before ]
-!             [ infer-label-loop ]
-!             [ drop nested-labels get pop* ]
-!         } cleave
-!     ] with-scope ;
-! 
-! : find-label ( param -- #label )
-!     word>> nested-labels get [ word>> eq? ] with find nip ;
-! 
-! M: #call-recursive propagate-before ( #call-label -- )
-!     [ label>> returns>> (merge-classes) ] [ out-d>> ] bi
-!     [ set-value-class ] 2each ;
-! 
-! M: #return propagate-around
-!     nested-labels get length 0 > [
-!         dup word>> nested-labels get peek word>> eq? [
-!             [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
-!             classes= not [
-!                 fixed-point? off
-!                 [ in-d>> value-classes get valid-keys ] keep
-!                 set-node-classes
-!             ] [ drop ] if
-!         ] [ call-next-method ] if
-!     ] [ call-next-method ] if ;
+: (merge-value-infos) ( inputs -- infos )
+    [ [ value-info ] map value-infos-union ] map ;
+
+: merge-value-infos ( inputs outputs -- fixed-point? )
+    [ (merge-value-infos) ] dip
+    [ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ;
+
+: propagate-recursive-phi ( #phi -- fixed-point? )
+    [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
+    [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
+    bi and ;
+
+M: #recursive propagate-around ( #recursive -- )
+    dup
+    [ children>> (propagate) ]
+    [ node-child 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 21aa9c9522..1c77fe1fc6 100644
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/unfinished/compiler/tree/propagation/simple/simple.factor
@@ -1,25 +1,39 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors kernel sequences assocs words namespaces
-combinators classes.algebra compiler.tree
+classes.algebra combinators classes
+compiler.tree
+compiler.tree.propagation.info
+compiler.tree.propagation.nodes
 compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.simple
 
-GENERIC: propagate-before ( node -- )
-
 M: #introduce propagate-before
-    values>> [ object swap set-value-class ] each ;
+    object <class-info> swap values>> [ set-value-info ] with each ;
 
 M: #push propagate-before
-    [ literal>> ] [ out-d>> first ] bi set-value-literal ;
+    [ literal>> value>> <literal-info> ] [ out-d>> first ] bi
+    set-value-info ;
+
+: refine-value-infos ( classes values -- )
+    [ refine-value-info ] 2each ;
+
+: class-infos ( classes -- infos )
+    [ <class-info> ] map ;
+
+: set-value-infos ( infos values -- )
+    [ set-value-info ] 2each ;
 
 M: #declare propagate-before
     [ [ in-d>> ] [ out-d>> ] bi are-copies-of ]
-    [ [ declaration>> ] [ out-d>> ] bi [ intersect-value-class ] 2each ]
-    bi ;
+    [
+        [ declaration>> class-infos ] [ out-d>> ] bi
+        refine-value-infos
+    ] bi ;
 
 M: #shuffle propagate-before
-    [ out-r>> dup ] [ mapping>> ] bi '[ , at ] map are-copies-of ;
+    [ out-d>> dup ] [ mapping>> ] bi
+    '[ , at ] map swap are-copies-of ;
 
 M: #>r propagate-before
     [ in-d>> ] [ out-r>> ] bi are-copies-of ;
@@ -30,83 +44,53 @@ M: #r> propagate-before
 M: #copy propagate-before
     [ in-d>> ] [ out-d>> ] bi are-copies-of ;
 
-: intersect-classes ( classes values -- )
-    [ intersect-value-class ] 2each ;
+: predicate-constraints ( value class boolean-value -- constraint )
+    [ [ <class-constraint> ] dip if-true ]
+    [ [ class-not <class-constraint> ] dip if-false ]
+    3bi <conjunction> ;
 
-: intersect-intervals ( intervals values -- )
-    [ intersect-value-interval ] 2each ;
-
-: predicate-constraints ( class #call -- )
-    [
-        ! If word outputs true, input is an instance of class
+: compute-constraints ( #call -- constraint )
+    dup word>> +constraints+ word-prop [ call assume ] [
+        dup word>> predicate?
         [
-            0 `input class,
-            \ f class-not 0 `output class,
-        ] set-constraints
-    ] [
-        ! If word outputs false, input is not an instance of class
-        [
-            class-not 0 `input class,
-            \ f 0 `output class,
-        ] set-constraints
-    ] 2bi ;
-
-: compute-constraints ( #call -- )
-    dup word>> "constraints" word-prop [
-        call
-    ] [
-        dup word>> "predicating" word-prop dup
-        [ swap predicate-constraints ] [ 2drop ] if
+            [ in-d>> first ]
+            [ word>> "predicating" word-prop ]
+            [ out-d>> first ]
+            tri predicate-constraints assume
+        ] [ drop ] if
     ] if* ;
 
-: compute-output-classes ( node word -- classes intervals )
-    dup word>> "output-classes" word-prop
-    dup [ call ] [ 2drop f f ] if ;
+: default-output-value-infos ( node -- infos )
+    dup word>> "default-output-classes" word-prop [
+        class-infos
+    ] [
+        out-d>> length object <class-info> <repetition>
+    ] ?if ;
 
-: output-classes ( node -- classes intervals )
-    dup compute-output-classes [
-        [ ] [ word>> "default-output-classes" word-prop ] ?if
-    ] dip ;
+: call-outputs-quot ( node quot -- infos )
+    [ in-d>> [ value-info ] map ] dip with-datastack ;
 
-: intersect-values ( classes intervals values -- )
-    tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
+: output-value-infos ( node word -- infos )
+    dup word>> +outputs+ word-prop
+    [ call-outputs-quot ] [ default-output-value-infos ] if* ;
 
 M: #call propagate-before
     [ compute-constraints ]
-    [ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
+    [ [ output-value-infos ] [ out-d>> ] bi set-value-infos ] bi ;
 
 M: node propagate-before drop ;
 
-GENERIC: propagate-after ( node -- )
-
-: input-classes ( #call -- classes )
-    word>> "input-classes" word-prop ;
-
 M: #call propagate-after
-    [ input-classes ] [ in-d>> ] bi intersect-classes ;
+    dup word>> "input-classes" word-prop dup [
+        class-infos swap in-d>> refine-value-infos
+    ] [
+        2drop
+    ] if ;
 
 M: node propagate-after drop ;
 
-GENERIC: propagate-around ( node -- )
-
-: valid-keys ( seq assoc -- newassoc )
-    '[ dup resolve-copy , at ] H{ } map>assoc
-    [ nip ] assoc-filter
-    f assoc-like ;
-
 : annotate-node ( node -- )
-    #! Annotate the node with the currently-inferred set of
-    #! value classes.
-    dup node-values {
-        [ value-intervals get valid-keys >>intervals ]
-        [ value-classes   get valid-keys >>classes   ]
-        [ value-literals  get valid-keys >>literals  ]
-        [ 2drop ]
-    } cleave ;
+    dup node-values [ dup value-info ] H{ } map>assoc >>info drop ;
 
-M: object propagate-around
-    {
-        [ propagate-before ]
-        [ annotate-node ]
-        [ propagate-after ]
-    } cleave ;
+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 6f87869a66..e528a48db9 100755
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -18,8 +18,7 @@ IN: compiler.tree
 ! 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
-classes literals intervals
+in-d out-d in-r out-r info
 history successor children ;
 
 M: node hashcode* drop node hashcode* ;
@@ -31,7 +30,7 @@ M: node hashcode* drop node hashcode* ;
     { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
     4array concat ;
 
-: node-child ( node -- child ) node-children first ;
+: node-child ( node -- child ) children>> first ;
 
 : last-node ( node -- last )
     dup successor>> [ last-node ] [ ] ?if ;
@@ -44,29 +43,14 @@ M: node hashcode* drop node hashcode* ;
         2drop f
     ] if ;
 
-: node-literal? ( node value -- ? )
-    swap literals>> key? ;
+: node-value-info ( node value -- info )
+    swap info>> at ;
 
-: node-literal ( node value -- obj )
-    swap literals>> at ;
+: node-input-infos ( node -- seq )
+    dup in-d>> [ node-value-info ] with map ;
 
-: node-interval ( node value -- interval )
-    swap intervals>> at ;
-
-: node-class ( node value -- class )
-    swap classes>> at ;
-
-: node-input-classes ( node -- seq )
-    dup in-d>> [ node-class ] with map ;
-
-: node-output-classes ( node -- seq )
-    dup out-d>> [ node-class ] with map ;
-
-: node-input-intervals ( node -- seq )
-    dup in-d>> [ node-interval ] with map ;
-
-: node-class-first ( node -- class )
-    dup in-d>> first node-class ;
+: node-output-infos ( node -- seq )
+    dup out-d>> [ node-value-info ] with map ;
 
 TUPLE: #introduce < node values ;
 
diff --git a/unfinished/math/partial-dispatch/partial-dispatch-tests.factor b/unfinished/math/partial-dispatch/partial-dispatch-tests.factor
new file mode 100644
index 0000000000..92a5b849a4
--- /dev/null
+++ b/unfinished/math/partial-dispatch/partial-dispatch-tests.factor
@@ -0,0 +1,12 @@
+IN: optimizer.math.partial.tests
+USING: math.partial-dispatch tools.test math kernel sequences ;
+
+[ t ] [ \ + integer fixnum math-both-known? ] unit-test
+[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
+[ t ] [ \ + integer bignum math-both-known? ] unit-test
+[ t ] [ \ + float fixnum math-both-known? ] unit-test
+[ f ] [ \ + real fixnum math-both-known? ] unit-test
+[ f ] [ \ + object number math-both-known? ] unit-test
+[ f ] [ \ number= fixnum object math-both-known? ] unit-test
+[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
+[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
diff --git a/unfinished/math/partial-dispatch/partial-dispatch.factor b/unfinished/math/partial-dispatch/partial-dispatch.factor
new file mode 100644
index 0000000000..625770e09f
--- /dev/null
+++ b/unfinished/math/partial-dispatch/partial-dispatch.factor
@@ -0,0 +1,174 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel kernel.private math math.private words
+sequences parser namespaces assocs quotations arrays
+generic generic.math hashtables effects compiler.units ;
+IN: math.partial-dispatch
+
+! Partial dispatch.
+
+! This code will be overhauled and generalized when
+! multi-methods go into the core.
+PREDICATE: math-partial < word
+    "derived-from" word-prop >boolean ;
+
+: fixnum-integer-op ( a b fix-word big-word -- c )
+    pick tag 0 eq? [
+        drop execute
+    ] [
+        >r drop >r fixnum>bignum r> r> execute
+    ] if ; inline
+
+: integer-fixnum-op ( a b fix-word big-word -- c )
+    >r pick tag 0 eq? [
+        r> drop execute
+    ] [
+        drop fixnum>bignum r> execute
+    ] if ; inline
+
+: integer-integer-op ( a b fix-word big-word -- c )
+    pick tag 0 eq? [
+        integer-fixnum-op
+    ] [
+        >r drop over tag 0 eq? [
+            >r fixnum>bignum r> r> execute
+        ] [
+            r> execute
+        ] if
+    ] if ; inline
+
+: integer-op-combinator ( triple -- word )
+    [
+        [ second name>> % "-" % ]
+        [ third name>> % "-op" % ]
+        bi
+    ] "" make "math.partial-dispatch" lookup ;
+
+: integer-op-word ( triple fix-word big-word -- word )
+    [
+        drop
+        name>> "fast" tail? >r
+        [ "-" % ] [ name>> % ] interleave
+        r> [ "-fast" % ] when
+    ] "" make "math.partial-dispatch" create ;
+
+: integer-op-quot ( word fix-word big-word -- quot )
+    rot integer-op-combinator 1quotation 2curry ;
+
+: define-integer-op-word ( word fix-word big-word -- )
+    [
+        [ integer-op-word ] [ integer-op-quot ] 3bi
+        (( x y -- z )) define-declared
+    ]
+    [
+        [ integer-op-word ] [ 2drop ] 3bi
+        "derived-from" set-word-prop
+    ] 3bi ;
+
+: define-integer-op-words ( words fix-word big-word -- )
+    [ define-integer-op-word ] 2curry each ;
+
+: integer-op-triples ( word -- triples )
+    {
+        { fixnum integer }
+        { integer fixnum }
+        { integer integer }
+    } swap [ prefix ] curry map ;
+
+: define-integer-ops ( word fix-word big-word -- )
+    >r >r integer-op-triples r> r>
+    [ define-integer-op-words ]
+    [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
+    3bi ;
+
+: define-math-ops ( op -- )
+    { fixnum bignum float }
+    [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
+    [ nip ] assoc-filter
+    [ def>> peek ] assoc-map % ;
+
+SYMBOL: math-ops
+
+SYMBOL: fast-math-ops
+
+: math-op ( word left right -- word' ? )
+    3array math-ops get at* ;
+
+: math-method* ( word left right -- quot )
+    3dup math-op
+    [ >r 3drop r> 1quotation ] [ drop math-method ] if ;
+
+: math-both-known? ( word left right -- ? )
+    3dup math-op
+    [ 2drop 2drop t ]
+    [ drop math-class-max swap specific-method >boolean ] if ;
+
+: (derived-ops) ( word assoc -- words )
+    swap [ rot first eq? nip ] curry assoc-filter values ;
+
+: derived-ops ( word -- words )
+    [ 1array ]
+    [ math-ops get (derived-ops) ]
+    bi append ;
+
+: fast-derived-ops ( word -- words )
+    fast-math-ops get (derived-ops) ;
+
+: all-derived-ops ( word -- words )
+    [ derived-ops ] [ fast-derived-ops ] bi append ;
+
+: each-derived-op ( word quot -- )
+    >r derived-ops r> each ; inline
+
+: each-fast-derived-op ( word quot -- )
+    >r fast-derived-ops r> each ; inline
+
+[
+    [
+        \ +       define-math-ops
+        \ -       define-math-ops
+        \ *       define-math-ops
+        \ shift   define-math-ops
+        \ mod     define-math-ops
+        \ /i      define-math-ops
+
+        \ bitand  define-math-ops
+        \ bitor   define-math-ops
+        \ bitxor  define-math-ops
+
+        \ <       define-math-ops
+        \ <=      define-math-ops
+        \ >       define-math-ops
+        \ >=      define-math-ops
+        \ number= define-math-ops
+
+        \ + \ fixnum+ \ bignum+ define-integer-ops
+        \ - \ fixnum- \ bignum- define-integer-ops
+        \ * \ fixnum* \ bignum* define-integer-ops
+        \ shift \ fixnum-shift \ bignum-shift define-integer-ops
+        \ mod \ fixnum-mod \ bignum-mod define-integer-ops
+        \ /i \ fixnum/i \ bignum/i define-integer-ops
+
+        \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
+        \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
+        \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
+
+        \ < \ fixnum< \ bignum< define-integer-ops
+        \ <= \ fixnum<= \ bignum<= define-integer-ops
+        \ > \ fixnum> \ bignum> define-integer-ops
+        \ >= \ fixnum>= \ bignum>= define-integer-ops
+        \ number= \ eq? \ bignum= define-integer-ops
+    ] { } make >hashtable math-ops set-global
+
+    [
+        { { + fixnum fixnum } fixnum+fast } ,
+        { { - fixnum fixnum } fixnum-fast } ,
+        { { * fixnum fixnum } fixnum*fast } ,
+        { { shift fixnum fixnum } fixnum-shift-fast } ,
+
+        \ + \ fixnum+fast \ bignum+ define-integer-ops
+        \ - \ fixnum-fast \ bignum- define-integer-ops
+        \ * \ fixnum*fast \ bignum* define-integer-ops
+        \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
+    ] { } make >hashtable fast-math-ops set-global
+] with-compilation-unit
diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor
index 1c4e5ddfe4..55aa452c10 100644
--- a/unfinished/stack-checker/branches/branches.factor
+++ b/unfinished/stack-checker/branches/branches.factor
@@ -12,7 +12,7 @@ IN: stack-checker.branches
 : phi-inputs ( seq -- newseq )
     dup empty? [
         dup [ length ] map supremum
-        '[ , f pad-left ] map
+        '[ , f pad-left ] map flip
     ] unless ;
 
 : unify-values ( values -- phi-out )
@@ -20,7 +20,7 @@ IN: stack-checker.branches
     [ nip first make-known ] [ 2drop <value> ] if ;
 
 : phi-outputs ( phi-in -- stack )
-    flip [ unify-values ] map ;
+    [ unify-values ] map ;
 
 SYMBOL: quotations
 
@@ -47,7 +47,7 @@ SYMBOL: quotations
 : retainstack-phi ( seq -- phi-in phi-out )
     [ length 0 <repetition> ] [ meta-r active-variable ] bi
     unify-branches
-    [ drop ] [ ] [ dup meta-r set ] tri* ;
+    [ drop ] [ ] [ dup >vector meta-r set ] tri* ;
 
 : compute-phi-function ( seq -- )
     [ quotation active-variable sift quotations set ]
diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index 560fd89496..45252f117f 100644
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -104,7 +104,7 @@ SYMBOL: phi-out
     [
         [ call-site-stack ] dip
         [ check-call-site-stack ]
-        [ phi-in>> push ]
+        [ phi-in>> swap [ suffix ] 2change-each ]
         2bi
     ] 2bi ;
 
diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index d3ca657c14..362c4f1394 100755
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -48,7 +48,7 @@ IN: stack-checker.known-words
 
 \ declare [
     pop-literal nip
-    [ length consume-d dup copy-values ] keep
+    [ length consume-d dup copy-values dup output-d ] keep
     #declare,
 ] +infer+ set-word-prop
 
diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor
index 4572d9532c..c379bced75 100755
--- a/unfinished/stack-checker/transforms/transforms.factor
+++ b/unfinished/stack-checker/transforms/transforms.factor
@@ -11,7 +11,7 @@ IN: stack-checker.transforms
     dup zero? [
         drop '[ recursive-state get @ ]
     ] [
-        '[
+        swap '[
             , consume-d
             [ first literal recursion>> ]
             [ [ literal value>> ] each ] bi @