diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor
index df1dd15bfb..19ab08c03c 100644
--- a/basis/alien/parser/parser.factor
+++ b/basis/alien/parser/parser.factor
@@ -1,18 +1,30 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays assocs effects grouping kernel
-parser sequences splitting words fry locals lexer namespaces ;
+parser sequences splitting words fry locals lexer namespaces
+summary math ;
 IN: alien.parser
 
+: normalize-c-arg ( type name -- type' name' )
+    [ length ]
+    [
+        [ CHAR: * = ] trim-head
+        [ length - CHAR: * <array> append ] keep
+    ] bi ;
+
 : parse-arglist ( parameters return -- types effect )
-    [ 2 group unzip [ "," ?tail drop ] map ]
+    [
+        2 group [ first2 normalize-c-arg 2array ] map
+        unzip [ "," ?tail drop ] map
+    ]
     [ [ { } ] [ 1array ] if-void ]
     bi* <effect> ;
 
 : function-quot ( return library function types -- quot )
     '[ _ _ _ _ alien-invoke ] ;
 
-:: make-function ( return library function parameters -- word quot effect )
+:: make-function ( return! library function! parameters -- word quot effect )
+    return function normalize-c-arg function! return!
     function create-in dup reset-generic
     return library function
     parameters return parse-arglist [ function-quot ] dip ;
diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor
index 2930843ad7..ce5f0cc233 100644
--- a/basis/cairo/ffi/ffi.factor
+++ b/basis/cairo/ffi/ffi.factor
@@ -896,7 +896,7 @@ FUNCTION: cairo_status_t
 cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
 
 FUNCTION: cairo_status_t
-cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
+cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t** surface ) ;
 
 FUNCTION: cairo_status_t
 cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
diff --git a/basis/calendar/unix/unix.factor b/basis/calendar/unix/unix.factor
index 9848d0c164..aa4e8f7e9a 100644
--- a/basis/calendar/unix/unix.factor
+++ b/basis/calendar/unix/unix.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax arrays calendar
-kernel math unix unix.time namespaces system ;
+kernel math unix unix.time unix.types namespaces system ;
 IN: calendar.unix
 
 : timeval>seconds ( timeval -- seconds )
@@ -19,7 +19,7 @@ IN: calendar.unix
     timespec>seconds since-1970 ;
 
 : get-time ( -- alien )
-    f time <uint> localtime ;
+    f time <time_t> localtime ;
 
 : timezone-name ( -- string )
     get-time tm-zone ;
diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index d0bb792f72..f6834c131d 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -3,8 +3,7 @@
 USING: kernel math namespaces assocs hashtables sequences arrays
 accessors vectors combinators sets classes compiler.cfg
 compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.copy-prop compiler.cfg.rpo
-compiler.cfg.liveness compiler.cfg.local ;
+compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
 IN: compiler.cfg.alias-analysis
 
 ! We try to eliminate redundant slot operations using some simple heuristics.
@@ -197,7 +196,7 @@ M: ##set-slot insn-object obj>> resolve ;
 M: ##set-slot-imm insn-object obj>> resolve ;
 M: ##alien-global insn-object drop \ ##alien-global ;
 
-: init-alias-analysis ( live-in -- )
+: init-alias-analysis ( insns -- insns' )
     H{ } clone histories set
     H{ } clone vregs>acs set
     H{ } clone acs>vregs set
@@ -208,7 +207,7 @@ M: ##alien-global insn-object drop \ ##alien-global ;
     0 ac-counter set
     next-ac heap-ac set
 
-    [ set-heap-ac ] each ;
+    dup local-live-in [ set-heap-ac ] each ;
 
 GENERIC: analyze-aliases* ( insn -- insn' )
 
@@ -280,9 +279,10 @@ M: insn eliminate-dead-stores* ;
     [ insn# set eliminate-dead-stores* ] map-index sift ;
 
 : alias-analysis-step ( insns -- insns' )
+    init-alias-analysis
     analyze-aliases
     compute-live-stores
     eliminate-dead-stores ;
 
 : alias-analysis ( cfg -- cfg' )
-    [ init-alias-analysis ] [ alias-analysis-step ] local-optimization ;
\ No newline at end of file
+    [ alias-analysis-step ] local-optimization ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
index 2ab476e20c..89e3604aec 100644
--- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor
+++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
@@ -6,18 +6,8 @@ compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
 compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.branch-splitting
 
-: clone-renamings ( insns -- assoc )
-    [ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
-
 : clone-instructions ( insns -- insns' )
-    dup clone-renamings renamings [
-        [
-            clone
-            dup rename-insn-defs
-            dup rename-insn-uses
-            dup fresh-insn-temps
-        ] map
-    ] with-variable ;
+    [ clone dup fresh-insn-temps ] map ;
 
 : clone-basic-block ( bb -- bb' )
     ! The new block gets the same RPO number as the old one.
@@ -62,10 +52,7 @@ IN: compiler.cfg.branch-splitting
 
 UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
 
-: split-instructions? ( insns -- ? )
-    [ [ irrelevant? not ] count 5 <= ]
-    [ last ##fixnum-overflow? not ]
-    bi and ;
+: split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ;
 
 : split-branch? ( bb -- ? )
     {
diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor
new file mode 100644
index 0000000000..8e96255bdd
--- /dev/null
+++ b/basis/compiler/cfg/builder/blocks/blocks.factor
@@ -0,0 +1,74 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays fry kernel make math namespaces sequences
+compiler.cfg compiler.cfg.instructions compiler.cfg.stacks
+compiler.cfg.stacks.local ;
+IN: compiler.cfg.builder.blocks
+
+: set-basic-block ( basic-block -- )
+    [ basic-block set ] [ instructions>> building set ] bi
+    begin-local-analysis ;
+
+: initial-basic-block ( -- )
+    <basic-block> set-basic-block ;
+
+: end-basic-block ( -- )
+    basic-block get [ end-local-analysis ] when
+    building off
+    basic-block off ;
+
+: (begin-basic-block) ( -- )
+    <basic-block>
+    basic-block get [ dupd successors>> push ] when*
+    set-basic-block ;
+
+: begin-basic-block ( -- )
+    basic-block get [ end-local-analysis ] when
+    (begin-basic-block) ;
+
+: emit-trivial-block ( quot -- )
+    ##branch begin-basic-block
+    call
+    ##branch begin-basic-block ; inline
+
+: call-height ( #call -- n )
+    [ out-d>> length ] [ in-d>> length ] bi - ;
+
+: emit-primitive ( node -- )
+    [
+        [ word>> ##call ]
+        [ call-height adjust-d ] bi
+    ] emit-trivial-block ;
+
+: begin-branch ( -- ) clone-current-height (begin-basic-block) ;
+
+: end-branch ( -- pair/f )
+    ! pair is { final-bb final-height }
+    basic-block get dup [
+        ##branch
+        end-local-analysis
+        current-height get clone 2array
+    ] when ;
+
+: with-branch ( quot -- pair/f )
+    [ begin-branch call end-branch ] with-scope ; inline
+
+: set-successors ( branches -- )
+    ! Set the successor of each branch's final basic block to the
+    ! current block.
+    basic-block get dup [
+        '[ [ [ _ ] dip first successors>> push ] when* ] each
+    ] [ 2drop ] if ;
+
+: merge-heights ( branches -- )
+    ! If all elements are f, that means every branch ended with a backward
+    ! jump so the height is irrelevant since this block is unreachable.
+    [ ] find nip [ second current-height set ] [ end-basic-block ] if* ;
+
+: emit-conditional ( branches -- )
+    ! branchies is a sequence of pairs as above
+    end-basic-block
+    [ merge-heights begin-basic-block ]
+    [ set-successors ]
+    bi ;
+
diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index 90e42912a1..812ef18e86 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -2,12 +2,21 @@ IN: compiler.cfg.builder.tests
 USING: tools.test kernel sequences words sequences.private fry
 prettyprint alien alien.accessors math.private compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
-compiler.cfg.predecessors compiler.cfg.checker arrays locals
-byte-arrays kernel.private math slots.private ;
+compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
+arrays locals byte-arrays kernel.private math slots.private ;
 
 ! Just ensure that various CFGs build correctly.
 : unit-test-cfg ( quot -- )
-    '[ _ test-cfg [ compute-predecessors check-cfg ] each ] [ ] swap unit-test ;
+    '[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ;
+
+: blahblah ( nodes -- ? )
+    { fixnum } declare [
+        dup 3 bitand 1 = [ drop t ] [
+            dup 3 bitand 2 = [
+                blahblah
+            ] [ drop f ] if
+        ] if
+    ] any? ; inline recursive
 
 {
     [ ]
@@ -52,6 +61,7 @@ byte-arrays kernel.private math slots.private ;
     [ "int" { "int" } "cdecl" [ ] alien-callback ]
     [ swap - + * ]
     [ swap slot ]
+    [ blahblah ]
 } [
     unit-test-cfg
 ] each
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index e3c502e66e..ed1069d043 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -10,30 +10,39 @@ compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.cfg
 compiler.cfg.hats
-compiler.cfg.stacks
 compiler.cfg.utilities
 compiler.cfg.registers
 compiler.cfg.intrinsics
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
 compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.builder.blocks
+compiler.cfg.stacks
 compiler.alien ;
 IN: compiler.cfg.builder
 
-! Convert tree SSA IR to CFG SSA IR.
+! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
+! constructed later by calling compiler.cfg.ssa:construct-ssa.
 
 SYMBOL: procedures
 SYMBOL: loops
 
-: begin-procedure ( word label -- )
-    end-basic-block
-    begin-basic-block
+: begin-cfg ( word label -- cfg )
+    initial-basic-block
     H{ } clone loops set
-    [ basic-block get ] 2dip
-    <cfg> procedures get push ;
+    [ basic-block get ] 2dip <cfg> dup cfg set ;
+
+: begin-procedure ( word label -- )
+    begin-cfg procedures get push ;
 
 : with-cfg-builder ( nodes word label quot -- )
-    '[ begin-procedure @ ] with-scope ; inline
+    '[
+        begin-stack-analysis
+        begin-procedure
+        @
+        end-stack-analysis
+    ] with-scope ; inline
 
 GENERIC: emit-node ( node -- )
 
@@ -61,17 +70,12 @@ GENERIC: emit-node ( node -- )
 : emit-loop-call ( basic-block -- )
     ##branch
     basic-block get successors>> push
-    basic-block off ;
-
-: emit-trivial-block ( quot -- )
-    basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless
-    call
-    ##branch begin-basic-block ; inline
+    end-basic-block ;
 
 : emit-call ( word height -- )
     over loops get key?
     [ drop loops get at emit-loop-call ]
-    [ [ ##call ] emit-trivial-block ]
+    [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
     if ;
 
 ! #recursive
@@ -86,7 +90,6 @@ GENERIC: emit-node ( node -- )
     basic-block get swap loops get set-at ;
 
 : emit-loop ( node -- )
-    ##loop-entry
     ##branch
     begin-basic-block
     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
@@ -101,9 +104,6 @@ M: #recursive emit-node
 : emit-if ( node -- )
     children>> [ emit-branch ] map emit-conditional ;
 
-: ##branch-t ( vreg -- )
-    \ f tag-number cc/= ##compare-imm-branch ;
-
 : trivial-branch? ( nodes -- value ? )
     dup length 1 = [
         first dup #push? [ literal>> t ] [ drop f f ] if
@@ -127,15 +127,23 @@ M: #recursive emit-node
 : emit-trivial-not-if ( -- )
     ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
 
+: emit-actual-if ( #if -- )
+    ! Inputs to the final instruction need to be copied because of
+    ! loc>vreg sync
+    ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
+
 M: #if emit-node
     {
         { [ dup trivial-if? ] [ drop emit-trivial-if ] }
         { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
-        [ ds-pop ##branch-t emit-if ]
+        [ emit-actual-if ]
     } cond ;
 
 ! #dispatch
 M: #dispatch emit-node
+    ! Inputs to the final instruction need to be copied because of
+    ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
+    ! though.
     ds-pop ^^offset>slot i ##dispatch emit-if ;
 
 ! #call
@@ -161,15 +169,16 @@ M: #shuffle emit-node
     [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
 
 ! #return
-M: #return emit-node
-    drop ##branch begin-basic-block ##epilogue ##return ;
+: emit-return ( -- )
+    ##branch begin-basic-block ##epilogue ##return ;
+
+M: #return emit-node drop emit-return ;
 
 M: #return-recursive emit-node
-    label>> id>> loops get key?
-    [ ##epilogue ##return ] unless ;
+    label>> id>> loops get key? [ emit-return ] unless ;
 
 ! #terminate
-M: #terminate emit-node drop ##no-tco basic-block off ;
+M: #terminate emit-node drop ##no-tco end-basic-block ;
 
 ! FFI
 : return-size ( ctype -- n )
@@ -186,9 +195,13 @@ M: #terminate emit-node drop ##no-tco basic-block off ;
         [ return>> return-size >>return ]
         [ alien-parameters parameter-sizes drop >>params ] bi ;
 
+: alien-node-height ( params -- )
+    [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
+
 : emit-alien-node ( node quot -- )
     [
-        [ params>> dup <alien-stack-frame> ] dip call
+        [ params>> dup dup <alien-stack-frame> ] dip call
+        alien-node-height
     ] emit-trivial-block ; inline
 
 M: #alien-invoke emit-node
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
index f9f5211c9c..22b6f03231 100644
--- a/basis/compiler/cfg/checker/checker.factor
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -1,16 +1,18 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators.short-circuit accessors math sequences sets
-assocs compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use
-compiler.cfg.linearization compiler.cfg.liveness
-compiler.cfg.utilities ;
+USING: kernel compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities
+compiler.cfg.mr combinators.short-circuit accessors math
+sequences sets assocs ;
 IN: compiler.cfg.checker
 
 ERROR: bad-kill-block bb ;
 
 : check-kill-block ( bb -- )
     dup instructions>> first2
-    swap ##epilogue? [ [ ##return? ] [ ##callback-return? ] bi or ] [ ##branch? ] if
+    swap ##epilogue? [
+        { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1||
+    ] [ ##branch? ] if
     [ drop ] [ bad-kill-block ] if ;
 
 ERROR: last-insn-not-a-jump bb ;
@@ -27,14 +29,6 @@ ERROR: last-insn-not-a-jump bb ;
         [ ##no-tco? ]
     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
 
-ERROR: bad-loop-entry bb ;
-
-: check-loop-entry ( bb -- )
-    dup instructions>> dup length 2 >= [
-        2 head* [ ##loop-entry? ] any?
-        [ bad-loop-entry ] [ drop ] if
-    ] [ 2drop ] if ;
-
 ERROR: bad-kill-insn bb ;
 
 : check-kill-instructions ( bb -- )
@@ -42,10 +36,9 @@ ERROR: bad-kill-insn bb ;
     [ bad-kill-insn ] [ drop ] if ;
 
 : check-normal-block ( bb -- )
-    [ check-loop-entry ]
     [ check-last-instruction ]
     [ check-kill-instructions ]
-    tri ;
+    bi ;
 
 ERROR: bad-successors ;
 
@@ -70,8 +63,6 @@ ERROR: undefined-values uses defs ;
     2dup subset? [ 2drop ] [ undefined-values ] if ;
 
 : check-cfg ( cfg -- )
-    compute-liveness
-    [ entry>> live-in assoc-empty? [ bad-live-in ] unless ]
     [ [ check-basic-block ] each-basic-block ]
-    [ flatten-cfg check-mr ]
-    tri ;
+    [ build-mr check-mr ]
+    bi ;
diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor
index d526ea9c1d..b13aa5d75b 100644
--- a/basis/compiler/cfg/copy-prop/copy-prop.factor
+++ b/basis/compiler/cfg/copy-prop/copy-prop.factor
@@ -1,8 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs accessors ;
+USING: kernel namespaces assocs accessors sequences
+compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ;
 IN: compiler.cfg.copy-prop
 
+! The first three definitions are also used in compiler.cfg.alias-analysis.
 SYMBOL: copies
 
 : resolve ( vreg -- vreg )
@@ -10,3 +12,25 @@ SYMBOL: copies
 
 : record-copy ( insn -- )
     [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
+
+: collect-copies ( cfg -- )
+    H{ } clone copies set
+    [
+        instructions>>
+        [ dup ##copy? [ record-copy ] [ drop ] if ] each
+    ] each-basic-block ;
+
+: rename-copies ( cfg -- )
+    copies get dup assoc-empty? [ 2drop ] [
+        renamings set
+        [
+            instructions>>
+            [ dup ##copy? [ drop f ] [ rename-insn-uses t ] if ] filter-here
+        ] each-basic-block
+    ] if ;
+
+: copy-propagation ( cfg -- cfg' )
+    [ collect-copies ]
+    [ rename-copies ]
+    [ ]
+    tri ;
diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor
new file mode 100644
index 0000000000..975adfa6cb
--- /dev/null
+++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor
@@ -0,0 +1,140 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs deques dlists kernel locals sequences lexer
+namespaces functors compiler.cfg.rpo compiler.cfg.utilities
+compiler.cfg ;
+IN: compiler.cfg.dataflow-analysis
+
+GENERIC: join-sets ( sets dfa -- set )
+GENERIC: transfer-set ( in-set bb dfa -- out-set )
+GENERIC: block-order ( cfg dfa -- bbs )
+GENERIC: successors ( bb dfa -- seq )
+GENERIC: predecessors ( bb dfa -- seq )
+
+<PRIVATE
+
+MIXIN: dataflow-analysis
+
+: <dfa-worklist> ( cfg dfa -- queue )
+    block-order <hashed-dlist> [ push-all-front ] keep ;
+
+GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
+
+M: kill-block compute-in-set 3drop f ;
+
+M:: basic-block compute-in-set ( bb out-sets dfa -- set )
+    bb dfa predecessors [ out-sets at ] map dfa join-sets ;
+
+:: update-in-set ( bb in-sets out-sets dfa -- ? )
+    bb out-sets dfa compute-in-set
+    bb in-sets maybe-set-at ; inline
+
+GENERIC# compute-out-set 2 ( bb out-sets dfa -- set )
+
+M: kill-block compute-out-set 3drop f ;
+
+M:: basic-block compute-out-set ( bb in-sets dfa -- set )
+    bb in-sets at bb dfa transfer-set ;
+
+:: update-out-set ( bb in-sets out-sets dfa -- ? )
+    bb in-sets dfa compute-out-set
+    bb out-sets maybe-set-at ; inline
+
+:: dfa-step ( bb in-sets out-sets dfa work-list -- )
+    bb in-sets out-sets dfa update-in-set [
+        bb in-sets out-sets dfa update-out-set [
+            bb dfa successors work-list push-all-front
+        ] when
+    ] when ; inline
+
+:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
+    H{ } clone :> in-sets
+    H{ } clone :> out-sets
+    cfg dfa <dfa-worklist> :> work-list
+    work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque
+    in-sets
+    out-sets ; inline
+
+M: dataflow-analysis join-sets drop assoc-refine ;
+
+FUNCTOR: define-analysis ( name -- )
+
+name-analysis DEFINES-CLASS ${name}-analysis
+name-ins DEFINES ${name}-ins
+name-outs DEFINES ${name}-outs
+name-in DEFINES ${name}-in
+name-out DEFINES ${name}-out
+
+WHERE
+
+SINGLETON: name-analysis
+
+SYMBOL: name-ins
+
+: name-in ( bb -- set ) name-ins get at ;
+
+SYMBOL: name-outs
+
+: name-out ( bb -- set ) name-outs get at ;
+
+;FUNCTOR
+
+! ! ! Forward dataflow analysis
+
+MIXIN: forward-analysis
+INSTANCE: forward-analysis dataflow-analysis
+
+M: forward-analysis block-order  drop reverse-post-order ;
+M: forward-analysis successors   drop successors>> ;
+M: forward-analysis predecessors drop predecessors>> ;
+
+FUNCTOR: define-forward-analysis ( name -- )
+
+name-analysis IS ${name}-analysis
+name-ins IS ${name}-ins
+name-outs IS ${name}-outs
+compute-name-sets DEFINES compute-${name}-sets
+
+WHERE
+
+INSTANCE: name-analysis forward-analysis
+
+: compute-name-sets ( cfg -- )
+    name-analysis run-dataflow-analysis
+    [ name-ins set ] [ name-outs set ] bi* ;
+
+;FUNCTOR
+
+! ! ! Backward dataflow analysis
+
+MIXIN: backward-analysis
+INSTANCE: backward-analysis dataflow-analysis
+
+M: backward-analysis block-order  drop post-order ;
+M: backward-analysis successors   drop predecessors>> ;
+M: backward-analysis predecessors drop successors>> ;
+
+FUNCTOR: define-backward-analysis ( name -- )
+
+name-analysis IS ${name}-analysis
+name-ins IS ${name}-ins
+name-outs IS ${name}-outs
+compute-name-sets DEFINES compute-${name}-sets
+
+WHERE
+
+INSTANCE: name-analysis backward-analysis
+
+: compute-name-sets ( cfg -- )
+    \ name-analysis run-dataflow-analysis
+    [ name-outs set ] [ name-ins set ] bi* ;
+
+;FUNCTOR
+
+PRIVATE>
+
+SYNTAX: FORWARD-ANALYSIS:
+    scan [ define-analysis ] [ define-forward-analysis ] bi ;
+
+SYNTAX: BACKWARD-ANALYSIS:
+    scan [ define-analysis ] [ define-backward-analysis ] bi ;
diff --git a/basis/compiler/cfg/dcn/dcn-tests.factor b/basis/compiler/cfg/dcn/dcn-tests.factor
deleted file mode 100644
index 43a66a8012..0000000000
--- a/basis/compiler/cfg/dcn/dcn-tests.factor
+++ /dev/null
@@ -1,621 +0,0 @@
-IN: compiler.cfg.dcn.tests
-USING: tools.test kernel accessors namespaces assocs math
-cpu.architecture vectors sequences classes
-compiler.cfg
-compiler.cfg.utilities
-compiler.cfg.debugger
-compiler.cfg.registers
-compiler.cfg.predecessors
-compiler.cfg.instructions
-compiler.cfg.checker
-compiler.cfg.dcn
-compiler.cfg.dcn.height
-compiler.cfg.dcn.local
-compiler.cfg.dcn.local.private
-compiler.cfg.dcn.global
-compiler.cfg.dcn.global.private
-compiler.cfg.dcn.rewrite ;
-
-: test-local-dcn ( insns -- insns' )
-    <basic-block> swap >>instructions
-    [ local-analysis ] keep
-    instructions>> ;
-
-: inserting-peeks' ( from to -- assoc )
-    [ inserting-peeks ] keep untranslate-locs keys ;
-
-: inserting-replaces' ( from to -- assoc )
-    [ inserting-replaces ] keep untranslate-locs remove-dead-stores keys ;
-
-[
-    V{
-        T{ ##copy f V int-regs 1 V int-regs 0 }
-        T{ ##copy f V int-regs 3 V int-regs 2 }
-        T{ ##copy f V int-regs 5 V int-regs 4 }
-        T{ ##inc-d f -1 }
-        T{ ##branch }
-    }
-] [
-    V{
-        T{ ##peek f V int-regs 0 D 0 }
-        T{ ##peek f V int-regs 1 D 0 }
-        T{ ##inc-d f -1 }
-        T{ ##peek f V int-regs 2 D 0 }
-        T{ ##peek f V int-regs 3 D 0 }
-        T{ ##replace f V int-regs 2 D 0 }
-        T{ ##replace f V int-regs 4 D 1 }
-        T{ ##peek f V int-regs 5 D 1 }
-        T{ ##replace f V int-regs 5 D 1 }
-        T{ ##replace f V int-regs 6 D -1 }
-        T{ ##branch }
-    } test-local-dcn
-] unit-test
-
-[
-    H{
-        { V int-regs 1 V int-regs 0 }
-        { V int-regs 3 V int-regs 2 }
-        { V int-regs 5 V int-regs 4 }
-    }
-] [
-    copies get
-] unit-test
-
-[
-    H{
-        { D 0 V int-regs 0 }
-        { D 1 V int-regs 2 }
-    }
-] [ reads-locations get ] unit-test
-
-[
-    H{
-        { D 0 V int-regs 6 }
-        { D 2 V int-regs 4 }
-    }
-] [ writes-locations get ] unit-test
-
-: test-global-dcn ( -- )
-    cfg new 0 get >>entry
-    compute-predecessors
-    deconcatenatize
-    check-cfg ;
-
-V{ T{ ##epilogue } T{ ##return } } 0 test-bb
-
-[ ] [ test-global-dcn ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##inc-d f 1 }
-    T{ ##peek f V int-regs 0 D 1 }
-    T{ ##load-immediate f V int-regs 1 100 }
-    T{ ##replace f V int-regs 1 D 2 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 2 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
-
-[ t ] [ 0 get kill-block? ] unit-test
-[ t ] [ 2 get kill-block? ] unit-test
-
-[ ] [ test-global-dcn ] unit-test
-
-[ t ] [ D 0 1 get peek-in key? ] unit-test
-
-[ f ] [ D 0 0 get peek-in key? ] unit-test
-
-[ t ] [ D 0 1 get avail-out key? ] unit-test
-
-[ f ] [ D 0 0 get avail-out key? ] unit-test
-
-[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-
-[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
-
-[ { D 2 } ] [ 1 get 2 get inserting-replaces' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 1 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##inc-d f -1 }
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 3 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
-2 get 3 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ t ] [ D 1 2 get peek-in key? ] unit-test
-[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##inc-d f 1 }
-    T{ ##peek f V int-regs 0 D 1 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 3 test-bb
-
-V{
-    T{ ##peek f V int-regs 1 D 0 }
-    T{ ##peek f V int-regs 2 D 1 }
-    T{ ##inc-d f 1 }
-    T{ ##replace f V int-regs 2 D 1 }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 5 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 4 get V{ } 2sequence >>successors drop
-2 get 3 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ f ] [ D 0 1 get avail-out key? ] unit-test
-[ f ] [ D 1 1 get avail-out key? ] unit-test
-[ t ] [ D 0 4 get peek-in key? ] unit-test
-[ t ] [ D 1 4 get peek-in key? ] unit-test
-
-[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
-[ { D 1 } ] [ 1 get 4 get inserting-peeks' ] unit-test
-[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
-[ { D 1 } ] [ 4 get 5 get inserting-replaces' ] unit-test
-
-[ t ] [ D 0 1 get peek-out key? ] unit-test
-[ f ] [ D 1 1 get peek-out key? ] unit-test
-
-[ t ] [ D 1 4 get peek-in key? ] unit-test
-[ f ] [ D 1 4 get avail-in key? ] unit-test
-[ t ] [ D 1 4 get avail-out key? ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##peek f V int-regs 1 D 1 }
-    T{ ##inc-d f -1 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 2 100 }
-    T{ ##replace f V int-regs 2 D 1 }
-    T{ ##inc-d f -1 }
-    T{ ##peek f V int-regs 4 D 1 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 3 100 }
-    T{ ##replace f V int-regs 3 D 0 }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 5 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ t ] [ D 1 4 get avail-in key? ] unit-test
-[ f ] [ D 2 4 get avail-in key? ] unit-test
-[ t ] [ D 1 2 get peek-in key? ] unit-test
-[ f ] [ D 1 3 get peek-in key? ] unit-test
-
-[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
-[ { D 1 } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { D 2 } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
-[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
-[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 1 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##inc-d f -1 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##call f drop -1 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##peek f V int-regs 1 D 0 }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 5 test-bb
-
-[ t ] [ 0 get kill-block? ] unit-test
-[ t ] [ 3 get kill-block? ] unit-test
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ t ] [ D 1 2 get avail-out key? ] unit-test
-[ f ] [ D 1 3 get peek-out key? ] unit-test
-[ f ] [ D 1 3 get avail-out key? ] unit-test
-[ f ] [ D 1 4 get avail-in key? ] unit-test
-
-[ { D 1 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 3 get 4 get inserting-peeks' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 1 test-bb
-
-V{ T{ ##epilogue } T{ ##return } } 2 test-bb
-
-V{ T{ ##branch } } 3 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-3 get 1 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ t ] [ D 0 1 get avail-out key? ] unit-test
-
-[ { D 0 } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 3 get 1 get inserting-peeks' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##call f drop }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##peek f V int-regs 1 D 0 }
-    T{ ##branch }
-} 5 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 6 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-5 get 6 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ { } ] [ 0 get 1 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 2 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
-[ { } ] [ 5 get 6 get inserting-peeks' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 1 100 }
-    T{ ##replace f V int-regs 1 D 0 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##peek f V int-regs 2 D 0 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 5 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ { } ] [ 1 get 2 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { D 0 } ] [ 1 get 3 get inserting-peeks' ] unit-test
-[ { } ] [ 1 get 3 get inserting-replaces' ] unit-test
-[ { } ] [ 2 get 4 get inserting-peeks' ] unit-test
-[ { D 0 } ] [ 2 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 3 get 4 get inserting-peeks' ] unit-test
-[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
-[ { } ] [ 4 get 5 get inserting-peeks' ] unit-test
-[ { } ] [ 4 get 5 get inserting-replaces' ] unit-test
-
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 1 100 }
-    T{ ##replace f V int-regs 1 D 0 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##load-immediate f V int-regs 2 100 }
-    T{ ##replace f V int-regs 2 D 0 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##branch }
-} 4 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 5 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 3 get V{ } 2sequence >>successors drop
-2 get 4 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-4 get 5 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ { } ] [ 2 get 4 get inserting-replaces' ] unit-test
-
-[ { } ] [ 3 get 4 get inserting-replaces' ] unit-test
-
-[ { D 0 } ] [ 4 get 5 get inserting-replaces' ] unit-test
-
-! Dead replace elimination
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##peek f V int-regs 1 D 1 }
-    T{ ##replace f V int-regs 1 D 0 }
-    T{ ##replace f V int-regs 0 D 1 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##inc-d f -2 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 3 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
-2 get 3 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ { } ] [ 0 get 1 get inserting-replaces' ] unit-test
-[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-[ { } ] [ 2 get 3 get inserting-replaces' ] unit-test
-
-! More dead replace elimination tests
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{    
-    T{ ##peek { dst V int-regs 10 } { loc D 0 } }
-    T{ ##inc-d { n -1 } }
-    T{ ##inc-r { n 1 } }
-    T{ ##replace { src V int-regs 10 } { loc R 0 } }
-    T{ ##peek { dst V int-regs 12 } { loc R 0 } }
-    T{ ##inc-r { n -1 } }
-    T{ ##inc-d { n 1 } }
-    T{ ##replace { src V int-regs 12 } { loc D 0 } }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 2 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ { } ] [ 1 get 2 get inserting-replaces' ] unit-test
-
-! Check that retain stack usage works
-V{
-    T{ ##prologue }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 D 0 }
-    T{ ##inc-d f -1 }
-    T{ ##inc-r f 1 }
-    T{ ##replace f V int-regs 0 R 0 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##call f + -1 }
-    T{ ##branch }
-} 2 test-bb
-
-V{
-    T{ ##peek f V int-regs 0 R 0 }
-    T{ ##inc-r f -1 }
-    T{ ##inc-d f 1 }
-    T{ ##replace f V int-regs 0 D 0 }
-    T{ ##branch }
-} 3 test-bb
-
-V{
-    T{ ##epilogue }
-    T{ ##return }
-} 4 test-bb
-
-0 get 1 get 1vector >>successors drop
-1 get 2 get 1vector >>successors drop
-2 get 3 get 1vector >>successors drop
-3 get 4 get 1vector >>successors drop
-
-[ ] [ test-global-dcn ] unit-test
-
-[ ##replace D 0 ] [
-    3 get successors>> first instructions>> first
-    [ class ] [ loc>> ] bi
-] unit-test
-
-[ ##replace R 0 ] [
-    1 get successors>> first instructions>> first
-    [ class ] [ loc>> ] bi
-] unit-test
-
-[ ##peek R 0 ] [
-    2 get successors>> first instructions>> first
-    [ class ] [ loc>> ] bi
-] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/dcn/dcn.factor b/basis/compiler/cfg/dcn/dcn.factor
deleted file mode 100644
index e2e52b30d5..0000000000
--- a/basis/compiler/cfg/dcn/dcn.factor
+++ /dev/null
@@ -1,44 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: combinators
-compiler.cfg
-compiler.cfg.dcn.height
-compiler.cfg.dcn.local
-compiler.cfg.dcn.global
-compiler.cfg.dcn.rewrite ;
-IN: compiler.cfg.dcn
-
-! "DeConcatenatizatioN" -- dataflow analysis to recover registers
-! from stack locations.
-
-! Local sets:
-! - P(b): locations that block b peeks before replacing
-! - R(b): locations that block b replaces
-! - A(b): P(b) \/ R(b) -- locations that are available in registers at the end of b
-
-! Global sets:
-! - P_out(b) = /\ P_in(sux) for sux in successors(b)
-! - P_in(b) = (P_out(b) - R(b)) \/ P(b)
-!
-! - R_in(b) = R_out(b) \/ R(b)
-! - R_out(b) = \/ R_in(sux) for sux in successors(b)
-!
-! - A_in(b) = /\ A_out(pred) for pred in predecessors(b)
-! - A_out(b) = A_in(b) \/ P(b) \/ R(b)
-
-! On every edge [b --> sux], insert a replace for each location in
-! R_out(b) - R_in(sux)
-
-! On every edge [pred --> b], insert a peek for each location in
-! P_in(b) - (P_out(pred) \/ A_out(pred))
-
-! Locations are height-normalized.
-
-: deconcatenatize ( cfg -- cfg' )
-    {
-        [ compute-heights ]
-        [ compute-local-sets ]
-        [ compute-global-sets ]
-        [ rewrite ]
-        [ cfg-changed ]
-    } cleave ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/dcn/global/global.factor b/basis/compiler/cfg/dcn/global/global.factor
deleted file mode 100644
index d644ed8703..0000000000
--- a/basis/compiler/cfg/dcn/global/global.factor
+++ /dev/null
@@ -1,197 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists fry kernel namespaces sequences
-combinators combinators.short-circuit compiler.cfg.instructions
-compiler.cfg.dcn.local compiler.cfg.rpo compiler.cfg.utilities
-compiler.cfg ;
-IN: compiler.cfg.dcn.global
-
-<PRIVATE
-
-: assoc-refine ( seq -- assoc )
-    [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
-
-SYMBOL: work-list
-
-: add-to-work-list ( basic-blocks -- )
-    work-list get '[ _ push-front ] each ;
-
-! Peek analysis. Peek-in is the set of all locations anticipated at
-! the start of a basic block.
-SYMBOLS: peek-ins peek-outs ;
-
-PRIVATE>
-
-: peek-in ( bb -- assoc ) peek-ins get at ;
-: peek-out ( bb -- assoc ) peek-outs get at ;
-
-<PRIVATE
-
-GENERIC: compute-peek-in ( bb -- assoc )
-
-M: basic-block compute-peek-in
-    [ [ peek-out ] [ replace ] bi assoc-diff ] [ peek ] bi assoc-union ;
-
-M: kill-block compute-peek-in drop f ;
-
-: update-peek-in ( bb -- ? )
-    [ compute-peek-in ] keep peek-ins get maybe-set-at ;
-
-GENERIC: compute-peek-out ( bb -- assoc )
-
-M: basic-block compute-peek-out
-    successors>> peek-ins get '[ _ at ] map assoc-refine ;
-
-M: kill-block compute-peek-out drop f ;
-
-: update-peek-out ( bb -- ? )
-    [ compute-peek-out ] keep peek-outs get maybe-set-at ;
-
-: peek-step ( bb -- )
-    dup update-peek-out [
-        dup update-peek-in
-        [ predecessors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
-
-: compute-peek-sets ( cfg -- )
-    H{ } clone peek-ins set
-    H{ } clone peek-outs set
-    post-order add-to-work-list work-list get [ peek-step ] slurp-deque ;
-
-! Replace analysis. Replace-in is the set of all locations which
-! will be overwritten at some point after the start of a basic block.
-SYMBOLS: replace-ins replace-outs ;
-
-PRIVATE>
-
-: replace-in ( bb -- assoc ) replace-ins get at ;
-: replace-out ( bb -- assoc ) replace-outs get at ;
-
-<PRIVATE
-
-GENERIC: compute-replace-in ( bb -- assoc )
-
-M: basic-block compute-replace-in
-    predecessors>> replace-outs get '[ _ at ] map assoc-refine ;
-
-M: kill-block compute-replace-in drop f ;
-
-: update-replace-in ( bb -- ? )
-    [ compute-replace-in ] keep replace-ins get maybe-set-at ;
-
-GENERIC: compute-replace-out ( bb -- assoc )
-
-M: basic-block compute-replace-out
-    [ replace-in ] [ replace ] bi assoc-union ;
-
-M: kill-block compute-replace-out drop f ;
-
-: update-replace-out ( bb -- ? )
-    [ compute-replace-out ] keep replace-outs get maybe-set-at ;
-
-: replace-step ( bb -- )
-    dup update-replace-in [
-        dup update-replace-out
-        [ successors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
-
-: compute-replace-sets ( cfg -- )
-    H{ } clone replace-ins set
-    H{ } clone replace-outs set
-    reverse-post-order add-to-work-list work-list get [ replace-step ] slurp-deque ;
-
-! Availability analysis. Avail-out is the set of all locations
-! in registers at the end of a basic block.
-SYMBOLS: avail-ins avail-outs ;
-
-PRIVATE>
-
-: avail-in ( bb -- assoc ) avail-ins get at ;
-: avail-out ( bb -- assoc ) avail-outs get at ;
-
-<PRIVATE
-
-GENERIC: compute-avail-in ( bb -- assoc )
-
-M: basic-block compute-avail-in
-    predecessors>> avail-outs get '[ _ at ] map assoc-refine ;
-
-M: kill-block compute-avail-in drop f ;
-
-: update-avail-in ( bb -- ? )
-    [ compute-avail-in ] keep avail-ins get maybe-set-at ;
-
-GENERIC: compute-avail-out ( bb -- assoc )
-
-M: basic-block compute-avail-out
-    [ avail-in ] [ peek ] [ replace ] tri assoc-union assoc-union ;
-
-M: kill-block compute-avail-out drop f ;
-
-: update-avail-out ( bb -- ? )
-    [ compute-avail-out ] keep avail-outs get maybe-set-at ;
-
-: avail-step ( bb -- )
-    dup update-avail-in [
-        dup update-avail-out
-        [ successors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
-
-: compute-avail-sets ( cfg -- )
-    H{ } clone avail-ins set
-    H{ } clone avail-outs set
-    reverse-post-order add-to-work-list work-list get [ avail-step ] slurp-deque ;
-
-! Kill analysis. Kill-in is the set of all locations
-! which are going to be overwritten.
-SYMBOLS: kill-ins kill-outs ;
-
-PRIVATE>
-
-: kill-in ( bb -- assoc ) kill-ins get at ;
-: kill-out ( bb -- assoc ) kill-outs get at ;
-
-<PRIVATE
-
-GENERIC: compute-kill-in ( bb -- assoc )
-
-M: basic-block compute-kill-in
-    [ kill-out ] [ replace ] bi assoc-union ;
-
-M: kill-block compute-kill-in drop f ;
-
-: update-kill-in ( bb -- ? )
-    [ compute-kill-in ] keep kill-ins get maybe-set-at ;
-
-GENERIC: compute-kill-out ( bb -- assoc )
-
-M: basic-block compute-kill-out
-    successors>> kill-ins get '[ _ at ] map assoc-refine ;
-
-M: kill-block compute-kill-out drop f ;
-
-: update-kill-out ( bb -- ? )
-    [ compute-kill-out ] keep kill-outs get maybe-set-at ;
-
-: kill-step ( bb -- )
-    dup update-kill-out [
-        dup update-kill-in
-        [ predecessors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
-
-: compute-kill-sets ( cfg -- )
-    H{ } clone kill-ins set
-    H{ } clone kill-outs set
-    post-order add-to-work-list work-list get [ kill-step ] slurp-deque ;
-
-PRIVATE>
-
-! Main word
-: compute-global-sets ( cfg -- )
-    <hashed-dlist> work-list set
-    {
-        [ compute-peek-sets ]
-        [ compute-replace-sets ]
-        [ compute-avail-sets ]
-        [ compute-kill-sets ]
-    } cleave ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/dcn/height/height.factor b/basis/compiler/cfg/dcn/height/height.factor
deleted file mode 100644
index 1a59ddcb35..0000000000
--- a/basis/compiler/cfg/dcn/height/height.factor
+++ /dev/null
@@ -1,82 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs accessors sequences kernel math locals fry
-compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.registers ;
-IN: compiler.cfg.dcn.height
-
-! Compute block in-height and out-height sets. These are relative to the
-! stack height from the start of the procedure.
-
-<PRIVATE
-
-SYMBOLS: in-ds-heights out-ds-heights in-rs-heights out-rs-heights ;
-
-GENERIC: ds-height-change ( insn -- n )
-
-M: insn ds-height-change drop 0 ;
-
-M: ##inc-d ds-height-change n>> ;
-
-M: ##call ds-height-change height>> ;
-
-: alien-node-height ( node -- n )
-    params>> [ out-d>> length ] [ in-d>> length ] bi - ;
-
-M: ##alien-invoke ds-height-change alien-node-height ;
-
-M: ##alien-indirect ds-height-change alien-node-height ;
-
-GENERIC: rs-height-change ( insn -- n )
-
-M: insn rs-height-change drop 0 ;
-
-M: ##inc-r rs-height-change n>> ;
-
-:: compute-in-height ( bb in out -- )
-    bb predecessors>> [ out at ] map-find drop 0 or
-    bb in set-at ;
-
-:: compute-out-height ( bb in out quot -- )
-    bb instructions>>
-    bb in at
-    [ quot call + ] reduce
-    bb out set-at ; inline
-
-:: compute-height ( bb in out quot -- )
-    bb in get out get
-    [ compute-in-height ]
-    [ quot compute-out-height ] 3bi ; inline
-
-: compute-ds-height ( bb -- )
-    in-ds-heights out-ds-heights [ ds-height-change ] compute-height ;
-
-: compute-rs-height ( bb -- )
-    in-rs-heights out-rs-heights [ rs-height-change ] compute-height ;
-
-PRIVATE>
-
-: compute-heights ( cfg -- )
-    H{ } clone in-ds-heights set
-    H{ } clone out-ds-heights set
-    H{ } clone in-rs-heights set
-    H{ } clone out-rs-heights set
-    [
-        [ compute-rs-height ]
-        [ compute-ds-height ] bi
-    ] each-basic-block ;
-
-GENERIC# translate-loc 1 ( loc bb -- loc' )
-
-M: ds-loc translate-loc [ n>> ] [ in-ds-heights get at ] bi* - <ds-loc> ;
-M: rs-loc translate-loc [ n>> ] [ in-rs-heights get at ] bi* - <rs-loc> ;
-
-: translate-locs ( assoc bb -- assoc' )
-    '[ [ _ translate-loc ] dip ] assoc-map ;
-
-GENERIC# untranslate-loc 1 ( loc bb -- loc' )
-
-M: ds-loc untranslate-loc [ n>> ] [ in-ds-heights get at ] bi* + <ds-loc> ;
-M: rs-loc untranslate-loc [ n>> ] [ in-rs-heights get at ] bi* + <rs-loc> ;
-
-: untranslate-locs ( assoc bb -- assoc' )
-    '[ [ _ untranslate-loc ] dip ] assoc-map ;
diff --git a/basis/compiler/cfg/dcn/local/local.factor b/basis/compiler/cfg/dcn/local/local.factor
deleted file mode 100644
index 3ed543f868..0000000000
--- a/basis/compiler/cfg/dcn/local/local.factor
+++ /dev/null
@@ -1,101 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel make namespaces sequences math
-compiler.cfg.rpo compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.dcn.height ;
-IN: compiler.cfg.dcn.local
-
-<PRIVATE
-
-SYMBOL: copies
-
-: record-copy ( dst src -- ) swap copies get set-at ;
-
-: resolve-copy ( vreg -- vreg' ) copies get ?at drop ;
-
-SYMBOLS: reads-locations writes-locations ;
-
-: loc>vreg ( loc -- vreg )
-    dup writes-locations get at
-    [ ] [ reads-locations get at ] ?if ;
-
-SYMBOL: ds-height
-
-SYMBOL: rs-height
-
-GENERIC: translate-loc ( loc -- loc' )
-
-M: ds-loc translate-loc n>> ds-height get - <ds-loc> ;
-
-M: rs-loc translate-loc n>> rs-height get - <rs-loc> ;
-
-GENERIC: visit ( insn -- )
-
-M: insn visit , ;
-
-M: ##inc-d visit n>> ds-height [ + ] change ;
-
-M: ##inc-r visit n>> rs-height [ + ] change ;
-
-M: ##peek visit
-    ! If location is in a register already, copy existing
-    ! register to destination. Otherwise, associate the
-    ! location with the register.
-    [ dst>> ] [ loc>> translate-loc ] bi dup loc>vreg
-    [ [ record-copy ] [ ##copy ] 2bi ]
-    [ reads-locations get set-at ]
-    ?if ;
-
-M: ##replace visit
-    ! If location already contains the same value, do nothing.
-    ! Otherwise, associate the location with the register.
-    [ src>> resolve-copy ] [ loc>> translate-loc ] bi 2dup loc>vreg =
-    [ 2drop ] [ writes-locations get set-at ] if ;
-
-M: ##copy visit
-    ! Not needed at this point because IR doesn't have ##copy
-    ! on input to dcn pass, but in the future it might.
-    [ dst>> ] [ src>> resolve-copy ] bi record-copy ;
-
-: insert-height-changes ( -- )
-    ds-height get dup 0 = [ drop ] [ ##inc-d ] if
-    rs-height get dup 0 = [ drop ] [ ##inc-r ] if ;
-
-: init-local-analysis ( -- )
-    0 ds-height set
-    0 rs-height set
-    H{ } clone copies set
-    H{ } clone reads-locations set
-    H{ } clone writes-locations set ;
-
-: local-analysis ( bb -- )
-    ! Removes all ##peek and ##replace from the basic block.
-    ! Conceptually, moves all ##peeks to the start
-    ! (reads-locations assoc) and all ##replaces to the end
-    ! (writes-locations assoc).
-    init-local-analysis
-    [
-        [
-            unclip-last-slice [ [ visit ] each ] dip
-            insert-height-changes
-            ,
-        ] V{ } make
-    ] change-instructions drop ;
-
-SYMBOLS: peeks replaces ;
-
-: visit-block ( bb -- )
-    [ local-analysis ]
-    [ [ reads-locations get ] dip [ translate-locs ] keep peeks get set-at ]
-    [ [ writes-locations get ] dip [ translate-locs ] keep replaces get set-at ]
-    tri ;
-
-PRIVATE>
-
-: peek ( bb -- assoc ) peeks get at ;
-: replace ( bb -- assoc ) replaces get at ;
-
-: compute-local-sets ( cfg -- )
-    H{ } clone peeks set
-    H{ } clone replaces set
-    [ visit-block ] each-basic-block ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index e355ee2ac1..18f1b3be76 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -7,7 +7,7 @@ parser compiler.tree.builder compiler.tree.optimizer
 compiler.cfg.builder compiler.cfg.linearization
 compiler.cfg.registers compiler.cfg.stack-frame
 compiler.cfg.linear-scan compiler.cfg.two-operand
-compiler.cfg.liveness compiler.cfg.optimizer
+compiler.cfg.optimizer
 compiler.cfg.mr compiler.cfg ;
 IN: compiler.cfg.debugger
 
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 2aa55df911..0f488de559 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel assocs compiler.cfg.instructions ;
+USING: accessors arrays kernel assocs sequences
+sets compiler.cfg.instructions ;
 IN: compiler.cfg.def-use
 
 GENERIC: defs-vregs ( insn -- seq )
diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor
index 210d5614c2..e884e32d78 100644
--- a/basis/compiler/cfg/dominance/dominance-tests.factor
+++ b/basis/compiler/cfg/dominance/dominance-tests.factor
@@ -6,8 +6,7 @@ compiler.cfg.predecessors ;
 : test-dominance ( -- )
     cfg new 0 get >>entry
     compute-predecessors
-    compute-dominance
-    drop ;
+    compute-dominance ;
 
 ! Example with no back edges
 V{ } 0 test-bb
@@ -74,3 +73,25 @@ V{ } 5 test-bb
 [ ] [ test-dominance ] unit-test
 
 [ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+V{ } 3 test-bb
+V{ } 4 test-bb
+V{ } 5 test-bb
+V{ } 6 test-bb
+
+0 get 1 get 5 get V{ } 2sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ test-dominance ] unit-test
+
+[ t ] [
+    2 get 3 get 2array iterated-dom-frontier
+    4 get 6 get 2array set=
+] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor
index 9c8fc79619..73d9f58eec 100644
--- a/basis/compiler/cfg/dominance/dominance.factor
+++ b/basis/compiler/cfg/dominance/dominance.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs combinators sets math fry kernel math.order
-namespaces sequences sorting compiler.cfg.rpo ;
+dlists deques namespaces sequences sorting compiler.cfg.rpo ;
 IN: compiler.cfg.dominance
 
 ! Reference:
@@ -85,8 +85,31 @@ PRIVATE>
 
 PRIVATE>
 
-: compute-dominance ( cfg -- cfg' )
+: compute-dominance ( cfg -- )
     [ compute-dom-parents compute-dom-children ]
     [ compute-dom-frontiers ]
-    [ ]
-    tri ;
+    bi ;
+
+<PRIVATE
+
+SYMBOLS: work-list visited ;
+
+: add-to-work-list ( bb -- )
+    dom-frontier work-list get push-all-front ;
+
+: iterated-dom-frontier-step ( bb -- )
+    dup visited get key? [ drop ] [
+        [ visited get conjoin ]
+        [ add-to-work-list ] bi
+    ] if ;
+
+PRIVATE>
+
+: iterated-dom-frontier ( bbs -- bbs' )
+    [
+        <dlist> work-list set
+        H{ } clone visited set
+        [ add-to-work-list ] each
+        work-list get [ iterated-dom-frontier-step ] slurp-deque
+        visited get keys
+    ] with-scope ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/empty-blocks/empty-blocks.factor b/basis/compiler/cfg/empty-blocks/empty-blocks.factor
new file mode 100644
index 0000000000..2a31a20b72
--- /dev/null
+++ b/basis/compiler/cfg/empty-blocks/empty-blocks.factor
@@ -0,0 +1,38 @@
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences combinators combinators.short-circuit
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
+IN: compiler.cfg.empty-blocks
+ 
+: update-predecessor ( bb -- )
+    ! We have to replace occurrences of bb with bb's successor
+    ! in bb's predecessor's list of successors.
+    dup predecessors>> first [
+        [
+            2dup eq? [ drop successors>> first ] [ nip ] if
+        ] with map
+    ] change-successors drop ;
+ 
+: update-successor ( bb -- )
+    ! We have to replace occurrences of bb with bb's predecessor
+    ! in bb's sucessor's list of predecessors.
+    dup successors>> first [
+        [
+            2dup eq? [ drop predecessors>> first ] [ nip ] if
+        ] with map
+    ] change-predecessors drop ;
+ 
+: delete-basic-block ( bb -- )
+    [ update-predecessor ] [ update-successor ] bi ;
+ 
+: delete-basic-block? ( bb -- ? )
+    {
+        [ instructions>> length 1 = ]
+        [ predecessors>> length 1 = ]
+        [ successors>> length 1 = ]
+        [ instructions>> first ##branch? ]
+    } 1&& ;
+ 
+: delete-empty-blocks ( cfg -- cfg' )
+    dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block
+    cfg-changed ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index 287d0a6999..4c1999943f 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -18,7 +18,7 @@ IN: compiler.cfg.hats
 : ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
 
 : ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
-: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
+: ^^copy ( src -- dst ) ^^i1 ##copy ; inline
 : ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
 : ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
 : ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
@@ -74,7 +74,7 @@ IN: compiler.cfg.hats
 : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
 : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
 : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
-: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
+: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
 : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
 : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
 : ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 43d92c9ccc..07ebcc3ba9 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -52,7 +52,7 @@ INSN: ##inc-d { n integer } ;
 INSN: ##inc-r { n integer } ;
 
 ! Subroutine calls
-INSN: ##call word { height integer } ;
+INSN: ##call word ;
 INSN: ##jump word ;
 INSN: ##return ;
 
@@ -170,8 +170,6 @@ INSN: ##epilogue ;
 
 INSN: ##branch ;
 
-INSN: ##loop-entry ;
-
 INSN: ##phi < ##pure inputs ;
 
 ! Conditionals
@@ -201,6 +199,7 @@ INSN: _epilogue stack-frame ;
 INSN: _label id ;
 
 INSN: _branch label ;
+INSN: _loop-entry ;
 
 INSN: _dispatch src temp ;
 INSN: _dispatch-label label ;
diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor
index 42e23c29c9..04d841f2d1 100644
--- a/basis/compiler/cfg/intrinsics/alien/alien.factor
+++ b/basis/compiler/cfg/intrinsics/alien/alien.factor
@@ -1,10 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences alien math classes.algebra
-fry locals combinators cpu.architecture
-compiler.tree.propagation.info
+USING: accessors kernel sequences alien math classes.algebra fry
+locals combinators cpu.architecture compiler.tree.propagation.info
 compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
-compiler.cfg.utilities ;
+compiler.cfg.utilities compiler.cfg.builder.blocks ;
 IN: compiler.cfg.intrinsics.alien
 
 : (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor
index 7b407c3ee4..8afd9f80ca 100644
--- a/basis/compiler/cfg/intrinsics/allot/allot.factor
+++ b/basis/compiler/cfg/intrinsics/allot/allot.factor
@@ -1,10 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.order sequences accessors arrays
 byte-arrays layouts classes.tuple.private fry locals
 compiler.tree.propagation.info compiler.cfg.hats
 compiler.cfg.instructions compiler.cfg.stacks
-compiler.cfg.utilities ;
+compiler.cfg.utilities compiler.cfg.builder.blocks ;
 IN: compiler.cfg.intrinsics.allot
 
 : ##set-slots ( regs obj class -- )
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index cfc07624fe..d4b9db58c8 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -7,6 +7,7 @@ compiler.cfg.hats
 compiler.cfg.stacks
 compiler.cfg.instructions
 compiler.cfg.utilities
+compiler.cfg.builder.blocks
 compiler.cfg.registers
 compiler.cfg.comparisons ;
 IN: compiler.cfg.intrinsics.fixnum
@@ -31,7 +32,7 @@ IN: compiler.cfg.intrinsics.fixnum
     [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
 
 : emit-fixnum-shift-general ( -- )
-    D 0 ^^peek 0 cc> ##compare-imm-branch
+    ds-peek 0 cc> ##compare-imm-branch
     [ emit-fixnum-left-shift ] with-branch
     [ emit-fixnum-right-shift ] with-branch
     2array emit-conditional ;
@@ -62,13 +63,15 @@ IN: compiler.cfg.intrinsics.fixnum
     ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
 
 : emit-no-overflow-case ( dst -- final-bb )
-    [ -2 ##inc-d ds-push ] with-branch ;
+    [ ds-drop ds-drop ds-push ] with-branch ;
 
 : emit-overflow-case ( word -- final-bb )
-    [ -1 ##call ] with-branch ;
+    [ ##call -1 adjust-d ] with-branch ;
 
 : emit-fixnum-overflow-op ( quot word -- )
-    [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip
+    ! Inputs to the final instruction need to be copied because
+    ! of loc>vreg sync
+    [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip
     [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
     emit-conditional ; inline
 
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 2618db0904..c6642d8ad9 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics
     slots.private:set-slot
     strings.private:string-nth
     strings.private:set-string-nth-fast
-    classes.tuple.private:<tuple-boa>
-    arrays:<array>
-    byte-arrays:<byte-array>
-    byte-arrays:(byte-array)
-    kernel:<wrapper>
+    ! classes.tuple.private:<tuple-boa>
+    ! arrays:<array>
+    ! byte-arrays:<byte-array>
+    ! byte-arrays:(byte-array)
+    ! kernel:<wrapper>
     alien.accessors:alien-unsigned-1
     alien.accessors:set-alien-unsigned-1
     alien.accessors:alien-signed-1
@@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics
     alien.accessors:set-alien-unsigned-2
     alien.accessors:alien-signed-2
     alien.accessors:set-alien-signed-2
-    alien.accessors:alien-cell
+    ! alien.accessors:alien-cell
     alien.accessors:set-alien-cell
 } [ t "intrinsic" set-word-prop ] each
 
@@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics
         alien.accessors:set-alien-float
         alien.accessors:alien-double
         alien.accessors:set-alien-double
-    } [ t "intrinsic" set-word-prop ] each ;
+    } drop f [ t "intrinsic" set-word-prop ] each ;
 
 : enable-fixnum-log2 ( -- )
     \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index 0cc6e6f5d0..93139a19a3 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: layouts namespaces kernel accessors sequences
 classes.algebra compiler.tree.propagation.info
 compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.utilities ;
+compiler.cfg.utilities compiler.cfg.builder.blocks ;
 IN: compiler.cfg.intrinsics.slots
 
 : value-tag ( info -- n ) class>> class-tag ; inline
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index 98deca9472..8e21e7e3fb 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -4,6 +4,7 @@ USING: accessors kernel math assocs namespaces sequences heaps
 fry make combinators sets locals
 cpu.architecture
 compiler.cfg
+compiler.cfg.rpo
 compiler.cfg.def-use
 compiler.cfg.liveness
 compiler.cfg.registers
@@ -185,6 +186,6 @@ ERROR: bad-vreg vreg ;
         ] V{ } make
     ] change-instructions drop ;
 
-: assign-registers ( live-intervals rpo -- )
+: assign-registers ( live-intervals cfg -- )
     [ init-assignment ] dip
-    [ assign-registers-in-block ] each ;
+    [ assign-registers-in-block ] each-basic-block ;
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index df521c1988..7362d185b4 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -7,7 +7,6 @@ compiler.cfg
 compiler.cfg.optimizer
 compiler.cfg.instructions
 compiler.cfg.registers
-compiler.cfg.liveness
 compiler.cfg.predecessors
 compiler.cfg.rpo
 compiler.cfg.linearization
@@ -1507,9 +1506,7 @@ SYMBOL: linear-scan-result
     [
         cfg new 0 get >>entry
         compute-predecessors
-        compute-liveness
-        dup reverse-post-order
-        { { int-regs regs } } (linear-scan)
+        dup { { int-regs regs } } (linear-scan)
         cfg-changed
         flatten-cfg 1array mr.
     ] with-scope ;
@@ -2331,9 +2328,6 @@ test-diamond
 ! early in bootstrap on x86-32
 [ t ] [
     [
-        H{ } clone live-ins set
-        H{ } clone live-outs set
-        H{ } clone phi-live-ins set
         T{ basic-block
            { id 12345 }
            { instructions
@@ -2353,7 +2347,8 @@ test-diamond
                  T{ ##replace f V int-regs 5 D 0 }
              }
            }
-        } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
+        } cfg new over >>entry
+        { { int-regs V{ 0 1 2 3 } } } (linear-scan)
         instructions>> first
         live-values>> assoc-empty?
     ] with-scope
diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index c17aa23e83..b081f2ca6e 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -4,6 +4,7 @@ USING: kernel accessors namespaces make locals
 cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
+compiler.cfg.liveness
 compiler.cfg.instructions
 compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.live-intervals
@@ -28,17 +29,18 @@ IN: compiler.cfg.linear-scan
 ! by Omri Traub, Glenn Holloway, Michael D. Smith
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
 
-:: (linear-scan) ( rpo machine-registers -- )
-    rpo number-instructions
-    rpo compute-live-intervals machine-registers allocate-registers
-    rpo assign-registers
-    rpo resolve-data-flow
-    rpo check-numbering ;
+:: (linear-scan) ( cfg machine-registers -- )
+    cfg compute-live-sets
+    cfg number-instructions
+    cfg compute-live-intervals machine-registers allocate-registers
+    cfg assign-registers
+    cfg resolve-data-flow
+    cfg check-numbering ;
 
 : linear-scan ( cfg -- cfg' )
     [
         init-mapping
-        dup reverse-post-order machine-registers (linear-scan)
+        dup machine-registers (linear-scan)
         spill-counts get >>spill-counts
         cfg-changed
     ] with-scope ;
diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index 68a780d42a..8813a4e94e 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces kernel assocs accessors sequences math math.order fry
 combinators binary-search compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
+compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.rpo
+compiler.cfg ;
 IN: compiler.cfg.linear-scan.live-intervals
 
 TUPLE: live-range from to ;
@@ -144,10 +145,10 @@ ERROR: bad-live-interval live-interval ;
         } cleave
     ] each ;
 
-: compute-live-intervals ( rpo -- live-intervals )
+: compute-live-intervals ( cfg -- live-intervals )
     H{ } clone [
         live-intervals set
-        <reversed> [ compute-live-intervals-step ] each
+        post-order [ compute-live-intervals-step ] each
     ] keep values dup finish-live-intervals ;
 
 : relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping.factor b/basis/compiler/cfg/linear-scan/mapping/mapping.factor
index 5b47f33c64..36678a2f53 100644
--- a/basis/compiler/cfg/linear-scan/mapping/mapping.factor
+++ b/basis/compiler/cfg/linear-scan/mapping/mapping.factor
@@ -44,17 +44,11 @@ M: register->register >insn
 SYMBOL: froms
 SYMBOL: tos
 
-SINGLETONS: memory register ;
-
-: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
-
-: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
-
 : from-reg ( operation -- seq )
-    [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
+    [ from>> ] [ reg-class>> ] bi 2array ;
 
 : to-reg ( operation -- seq )
-    [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
+    [ to>> ] [ reg-class>> ] bi 2array ;
 
 : start? ( operations -- pair )
     from-reg tos get key? not ;
diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor
index ac18b0cb2e..2976680857 100644
--- a/basis/compiler/cfg/linear-scan/numbering/numbering.factor
+++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math sequences grouping namespaces ;
+USING: kernel accessors math sequences grouping namespaces
+compiler.cfg.rpo ;
 IN: compiler.cfg.linear-scan.numbering
 
 : number-instructions ( rpo -- )
@@ -8,7 +9,7 @@ IN: compiler.cfg.linear-scan.numbering
         instructions>> [
             [ (>>insn#) ] [ drop 2 + ] 2bi
         ] each
-    ] each drop ;
+    ] each-basic-block drop ;
 
 SYMBOL: check-numbering?
 
@@ -18,5 +19,5 @@ ERROR: bad-numbering bb ;
     dup instructions>> [ insn#>> ] map sift [ <= ] monotonic?
     [ drop ] [ bad-numbering ] if ;
 
-: check-numbering ( rpo -- )
-    check-numbering? get [ [ check-block-numbering ] each ] [ drop ] if ;
\ No newline at end of file
+: check-numbering ( cfg -- )
+    check-numbering? get [ [ check-block-numbering ] each-basic-block ] [ drop ] if ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index f7ed994f18..56beaa5379 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -3,10 +3,12 @@
 USING: accessors arrays assocs combinators
 combinators.short-circuit fry kernel locals
 make math sequences
+compiler.cfg.rpo
+compiler.cfg.liveness
 compiler.cfg.utilities
 compiler.cfg.instructions
 compiler.cfg.linear-scan.assignment
-compiler.cfg.linear-scan.mapping compiler.cfg.liveness ;
+compiler.cfg.linear-scan.mapping ;
 IN: compiler.cfg.linear-scan.resolve
 
 : add-mapping ( from to reg-class -- )
@@ -43,5 +45,5 @@ IN: compiler.cfg.linear-scan.resolve
 : resolve-block-data-flow ( bb -- )
     dup successors>> [ resolve-edge-data-flow ] with each ;
 
-: resolve-data-flow ( rpo -- )
-    [ resolve-block-data-flow ] each ;
+: resolve-data-flow ( cfg -- )
+    [ resolve-block-data-flow ] each-basic-block ;
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 9faa1e9e38..f9e0e54afc 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -4,10 +4,10 @@ USING: kernel math accessors sequences namespaces make
 combinators assocs arrays locals cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
-compiler.cfg.liveness
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
-compiler.cfg.instructions ;
+compiler.cfg.instructions
+compiler.cfg.utilities ;
 IN: compiler.cfg.linearization
 
 ! Convert CFG IR to machine IR.
@@ -25,7 +25,12 @@ M: insn linearize-insn , drop ;
     #! don't need to branch.
     [ number>> ] bi@ 1 - = ; inline
 
-: emit-branch ( basic-block successor -- )
+: emit-loop-entry? ( bb successor -- ? )
+    [ back-edge? not ]
+    [ nip dup predecessors>> [ swap back-edge? ] with any? ] 2bi and ;
+
+: emit-branch ( bb successor -- )
+    2dup emit-loop-entry? [ _loop-entry ] when
     2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
 
 M: ##branch linearize-insn
@@ -33,11 +38,11 @@ M: ##branch linearize-insn
 
 : successors ( bb -- first second ) successors>> first2 ; inline
 
-: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
+: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
     [ dup successors ]
     [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
 
-: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
+: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
     [ (binary-conditional) ]
     [ drop dup successors>> second useless-branch? ] 2bi
     [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
@@ -54,7 +59,7 @@ M: ##compare-imm-branch linearize-insn
 M: ##compare-float-branch linearize-insn
     [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
 
-: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 )
+: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
     [ dup successors number>> ]
     [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
 
diff --git a/basis/compiler/cfg/liveness/authors.txt b/basis/compiler/cfg/liveness/authors.txt
deleted file mode 100644
index d4f5d6b3ae..0000000000
--- a/basis/compiler/cfg/liveness/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor
index 271dc60d76..697a1f8a7b 100644
--- a/basis/compiler/cfg/liveness/liveness-tests.factor
+++ b/basis/compiler/cfg/liveness/liveness-tests.factor
@@ -1,15 +1,38 @@
-USING: compiler.cfg compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.liveness accessors tools.test cpu.architecture ;
+USING: compiler.cfg.liveness compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.predecessors
+compiler.cfg.registers compiler.cfg cpu.architecture
+accessors namespaces sequences kernel tools.test ;
 IN: compiler.cfg.liveness.tests
 
+! Sanity check...
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##replace f V int-regs 1 D 1 }
+    T{ ##peek f V int-regs 1 D 1 }
+} 1 test-bb
+
+V{
+    T{ ##replace f V int-regs 2 D 0 }
+} 2 test-bb
+
+V{
+    T{ ##replace f V int-regs 3 D 0 }
+} 3 test-bb
+
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+
+cfg new 1 get >>entry
+compute-predecessors
+compute-live-sets
+
 [
     H{
-        { "A" H{ { V int-regs 1 V int-regs 1 } { V int-regs 4 V int-regs 4 } } }
-        { "B" H{ { V int-regs 3 V int-regs 3 } { V int-regs 2 V int-regs 2 } } }
+        { V int-regs 1 V int-regs 1 }
+        { V int-regs 2 V int-regs 2 }
+        { V int-regs 3 V int-regs 3 }
     }
-] [
-    <basic-block> V{
-        T{ ##phi f V int-regs 0 { { "A" V int-regs 1 } { "B" V int-regs 2 } } }
-        T{ ##phi f V int-regs 1 { { "B" V int-regs 3 } { "A" V int-regs 4 } } }
-    } >>instructions compute-phi-live-in
-] unit-test
\ No newline at end of file
+]
+[ 1 get live-in ]
+unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor
index 9dc320660c..c1793842a2 100644
--- a/basis/compiler/cfg/liveness/liveness.factor
+++ b/basis/compiler/cfg/liveness/liveness.factor
@@ -1,79 +1,26 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces deques accessors sets sequences assocs fry
-hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
-compiler.cfg.rpo ;
+USING: kernel accessors assocs sequences sets
+compiler.cfg.def-use compiler.cfg.dataflow-analysis
+compiler.cfg.instructions ;
 IN: compiler.cfg.liveness
 
-! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
+! See http://en.wikipedia.org/wiki/Liveness_analysis
+! Do not run after SSA construction
 
-! Assoc mapping basic blocks to sets of vregs
-SYMBOL: live-ins
+BACKWARD-ANALYSIS: live
 
-: live-in ( basic-block -- set ) live-ins get at ;
+: transfer-liveness ( live-set instructions -- live-set' )
+    [ clone ] [ <reversed> ] bi* [
+        [ uses-vregs [ over conjoin ] each ]
+        [ defs-vregs [ over delete-at ] each ] bi
+    ] each ;
 
-! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
-! is in conrrespondence with a predecessor
-SYMBOL: phi-live-ins
+: local-live-in ( instructions -- live-set )
+    [ ##phi? not ] filter [ H{ } ] dip transfer-liveness keys ;
 
-: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
+M: live-analysis transfer-set
+    drop instructions>> transfer-liveness ;
 
-! Assoc mapping basic blocks to sets of vregs
-SYMBOL: live-outs
-
-: live-out ( basic-block -- set ) live-outs get at ;
-
-SYMBOL: work-list
-
-: add-to-work-list ( basic-blocks -- )
-    work-list get '[ _ push-front ] each ;
-
-: map-unique ( seq quot -- assoc )
-    map concat unique ; inline
-
-: gen-set ( instructions -- seq )
-    [ ##phi? not ] filter [ uses-vregs ] map-unique ;
-
-: kill-set ( instructions -- seq )
-    [ [ defs-vregs ] [ temp-vregs ] bi append ] map-unique ;
-
-: compute-live-in ( basic-block -- live-in )
-    dup instructions>>
-    [ [ live-out ] [ gen-set ] bi* assoc-union ]
-    [ nip kill-set ]
-    2bi assoc-diff ;
-
-: compute-phi-live-in ( basic-block -- phi-live-in )
-    instructions>> [ ##phi? ] filter [ f ] [
-        H{ } clone [
-            '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each
-        ] keep
-    ] if-empty ;
-
-: update-live-in ( basic-block -- changed? )
-    [ [ compute-live-in ] keep live-ins get maybe-set-at ]
-    [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
-    bi and ; 
-
-: compute-live-out ( basic-block -- live-out )
-    [ successors>> [ live-in ] map ]
-    [ dup successors>> [ phi-live-in ] with map ] bi
-    append assoc-combine ;
-
-: update-live-out ( basic-block -- changed? )
-    [ compute-live-out ] keep
-    live-outs get maybe-set-at ;
-
-: liveness-step ( basic-block -- )
-    dup update-live-out [
-        dup update-live-in
-        [ predecessors>> add-to-work-list ] [ drop ] if
-    ] [ drop ] if ;
-
-: compute-liveness ( cfg -- cfg' )
-    <hashed-dlist> work-list set
-    H{ } clone live-ins set
-    H{ } clone phi-live-ins set
-    H{ } clone live-outs set
-    dup post-order add-to-work-list
-    work-list get [ liveness-step ] slurp-deque ;
+M: live-analysis join-sets
+    drop assoc-combine ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/local/authors.txt b/basis/compiler/cfg/local/authors.txt
deleted file mode 100644
index d4f5d6b3ae..0000000000
--- a/basis/compiler/cfg/local/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/local/local.factor b/basis/compiler/cfg/local/local.factor
deleted file mode 100644
index 2f5f5b18e3..0000000000
--- a/basis/compiler/cfg/local/local.factor
+++ /dev/null
@@ -1,14 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: locals accessors kernel assocs namespaces
-compiler.cfg compiler.cfg.liveness compiler.cfg.rpo ;
-IN: compiler.cfg.local
-
-:: optimize-basic-block ( bb init-quot insn-quot -- )
-    bb basic-block set
-    bb live-in keys init-quot call
-    bb insn-quot change-instructions drop ; inline
-
-:: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
-    cfg [ init-quot insn-quot optimize-basic-block ] each-basic-block
-    cfg ; inline
\ No newline at end of file
diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor
index 9f6a62090c..cb198d5149 100644
--- a/basis/compiler/cfg/mr/mr.factor
+++ b/basis/compiler/cfg/mr/mr.factor
@@ -1,13 +1,12 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan
+compiler.cfg.gc-checks compiler.cfg.linear-scan
 compiler.cfg.build-stack-frame compiler.cfg.rpo ;
 IN: compiler.cfg.mr
 
 : build-mr ( cfg -- mr )
     convert-two-operand
-    compute-liveness
     insert-gc-checks
     linear-scan
     flatten-cfg
diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
index 1eb1996da4..695a586199 100755
--- a/basis/compiler/cfg/optimizer/optimizer-tests.factor
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -1,8 +1,8 @@
-USING: accessors arrays compiler.cfg.checker
-compiler.cfg.debugger compiler.cfg.def-use
-compiler.cfg.instructions fry kernel kernel.private math
-math.partial-dispatch math.private sbufs sequences sequences.private sets
-slots.private strings strings.private tools.test vectors layouts ;
+USING: accessors arrays compiler.cfg.checker compiler.cfg.debugger
+compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.optimizer
+fry kernel kernel.private math math.partial-dispatch math.private
+sbufs sequences sequences.private sets slots.private strings
+strings.private tools.test vectors layouts ;
 IN: compiler.cfg.optimizer.tests
 
 ! Miscellaneous tests
@@ -45,7 +45,7 @@ IN: compiler.cfg.optimizer.tests
         set-string-nth-fast
     ]
 } [
-    [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
+    [ [ ] ] dip '[ _ test-cfg first optimize-cfg check-cfg ] unit-test
 ] each
 
 cell 8 = [
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index faaaccff61..ede2a9382c 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -2,21 +2,19 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors combinators namespaces
 compiler.cfg.tco
-compiler.cfg.predecessors
 compiler.cfg.useless-conditionals
-compiler.cfg.stack-analysis
-compiler.cfg.dcn
-compiler.cfg.dominance
-compiler.cfg.ssa
 compiler.cfg.branch-splitting
 compiler.cfg.block-joining
+compiler.cfg.ssa
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
+compiler.cfg.copy-prop
 compiler.cfg.dce
 compiler.cfg.write-barrier
-compiler.cfg.liveness
-compiler.cfg.rpo
 compiler.cfg.phi-elimination
+compiler.cfg.empty-blocks
+compiler.cfg.predecessors
+compiler.cfg.rpo
 compiler.cfg.checker ;
 IN: compiler.cfg.optimizer
 
@@ -27,30 +25,24 @@ SYMBOL: check-optimizer?
         dup check-cfg
     ] when ;
 
-SYMBOL: new-optimizer?
-
 : optimize-cfg ( cfg -- cfg' )
     ! Note that compute-predecessors has to be called several times.
     ! The passes that need this document it.
     [
         optimize-tail-calls
-        new-optimizer? get [ delete-useless-conditionals ] unless
+        delete-useless-conditionals
         compute-predecessors
-        new-optimizer? get [ split-branches ] unless
-        new-optimizer? get [
-            deconcatenatize
-            compute-dominance
-            construct-ssa
-        ] when
+        split-branches
         join-blocks
         compute-predecessors
-        new-optimizer? get [ stack-analysis ] unless
-        compute-liveness
+        construct-ssa
         alias-analysis
         value-numbering
         compute-predecessors
+        copy-propagation
         eliminate-dead-code
         eliminate-write-barriers
         eliminate-phis
+        delete-empty-blocks
         ?check
     ] with-scope ;
diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor
index 7e73f0b854..38e82176ca 100644
--- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor
+++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor
@@ -6,6 +6,20 @@ compiler.cfg.utilities compiler.cfg.hats make
 locals ;
 IN: compiler.cfg.phi-elimination
 
+! assoc mapping predecessors to sequences
+SYMBOL: added-instructions
+
+: add-instructions ( predecessor quot -- )
+    [
+        added-instructions get
+        [ drop V{ } clone ] cache
+        building
+    ] dip with-variable ; inline
+
+: insert-basic-blocks ( bb -- )
+    [ added-instructions get ] dip
+    '[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;
+
 : insert-copy ( predecessor input output -- )
     '[ _ _ swap ##copy ] add-instructions ;
 
diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor
index 8dbcadfe8b..eb8538256a 100644
--- a/basis/compiler/cfg/renaming/renaming.factor
+++ b/basis/compiler/cfg/renaming/renaming.factor
@@ -6,7 +6,7 @@ IN: compiler.cfg.renaming
 
 SYMBOL: renamings
 
-: rename-value ( vreg -- vreg' ) renamings get at ;
+: rename-value ( vreg -- vreg' ) renamings get ?at drop ;
 
 GENERIC: rename-insn-defs ( insn -- )
 
@@ -102,6 +102,10 @@ M: ##fixnum-overflow rename-insn-uses
     [ rename-value ] change-src2
     drop ;
 
+M: ##phi rename-insn-uses
+    [ [ rename-value ] assoc-map ] change-inputs
+    drop ;
+
 M: insn rename-insn-uses drop ;
 
 : fresh-vreg ( vreg -- vreg' )
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index f6a40e17d0..1ddacdf8ab 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/basis/compiler/cfg/rpo/rpo.factor
@@ -33,3 +33,10 @@ SYMBOL: visited
 
 : each-basic-block ( cfg quot -- )
     [ reverse-post-order ] dip each ; inline
+
+: optimize-basic-block ( bb quot -- )
+    [ drop basic-block set ]
+    [ change-instructions drop ] 2bi ; inline
+
+: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' )
+    dupd '[ _ optimize-basic-block ] each-basic-block ; inline
\ No newline at end of file
diff --git a/basis/compiler/cfg/ssa/ssa-tests.factor b/basis/compiler/cfg/ssa/ssa-tests.factor
index c53d30af5d..6a3a014f78 100644
--- a/basis/compiler/cfg/ssa/ssa-tests.factor
+++ b/basis/compiler/cfg/ssa/ssa-tests.factor
@@ -5,9 +5,12 @@ compiler.cfg.registers cpu.architecture kernel namespaces sequences
 tools.test vectors ;
 IN: compiler.cfg.ssa.tests
 
-! Reset counters so that results are deterministic w.r.t. hash order
-0 vreg-counter set-global
-0 basic-block set-global
+: reset-counters ( -- )
+    ! Reset counters so that results are deterministic w.r.t. hash order
+    0 vreg-counter set-global
+    0 basic-block set-global ;
+
+reset-counters
 
 V{
     T{ ##load-immediate f V int-regs 1 100 }
@@ -38,7 +41,6 @@ V{
 : test-ssa ( -- )
     cfg new 0 get >>entry
     compute-predecessors
-    compute-dominance
     construct-ssa
     drop ;
 
@@ -67,6 +69,9 @@ V{
     }
 ] [ 2 get instructions>> ] unit-test
 
+: clean-up-phis ( insns -- insns' )
+    [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ;
+
 [
     V{
         T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } }
@@ -75,5 +80,34 @@ V{
     }
 ] [
     3 get instructions>>
-    [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map
+    clean-up-phis
+] unit-test
+
+reset-counters
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ T{ ##peek f V int-regs 0 D 0 } } 2 test-bb
+V{ T{ ##peek f V int-regs 0 D 0 } } 3 test-bb
+V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb
+V{ } 5 test-bb
+V{ } 6 test-bb
+
+0 get 1 get 5 get V{ } 2sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ test-ssa ] unit-test
+
+[
+    V{
+        T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } }
+        T{ ##replace f V int-regs 3 D 0 }
+    }
+] [
+    4 get instructions>>
+    clean-up-phis
 ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/ssa/ssa.factor b/basis/compiler/cfg/ssa/ssa.factor
index e11701965b..2e76ba35a1 100644
--- a/basis/compiler/cfg/ssa/ssa.factor
+++ b/basis/compiler/cfg/ssa/ssa.factor
@@ -1,19 +1,21 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel accessors sequences fry dlists
-deques assocs sets math combinators sorting
+USING: namespaces kernel accessors sequences fry assocs
+sets math combinators
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.def-use
 compiler.cfg.renaming
+compiler.cfg.liveness
 compiler.cfg.registers
 compiler.cfg.dominance
 compiler.cfg.instructions ;
 IN: compiler.cfg.ssa
 
-! SSA construction. Predecessors and dominance must be computed first.
+! SSA construction. Predecessors must be computed first.
 
-! This is the classical algorithm based on dominance frontiers:
+! This is the classical algorithm based on dominance frontiers, except
+! we consult liveness information to build pruned SSA:
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.25.8240
 
 ! Eventually might be worth trying something fancier:
@@ -32,45 +34,22 @@ SYMBOL: inserting-phi-nodes
     '[
         dup instructions>> [
             defs-vregs [
-                _ push-at
+                _ conjoin-at
             ] with each
         ] with each
     ] each-basic-block ;
 
-SYMBOLS: has-already ever-on-work-list work-list ;
-
-: init-insert-phi-nodes ( bbs -- )
-    H{ } clone has-already set
-    [ unique ever-on-work-list set ]
-    [ <hashed-dlist> [ push-all-front ] keep work-list set ] bi ;
-
-: add-to-work-list ( bb -- )
-    dup ever-on-work-list get key? [ drop ] [
-        [ ever-on-work-list get conjoin ]
-        [ work-list get push-front ]
-        bi
-    ] if ;
-
 : insert-phi-node-later ( vreg bb -- )
-    [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
-    inserting-phi-nodes get push-at ;
-
-: compute-phi-node-in ( vreg bb -- )
-    dup has-already get key? [ 2drop ] [
-        [ insert-phi-node-later ]
-        [ has-already get conjoin ]
-        [ add-to-work-list ]
-        tri
-    ] if ;
+    2dup live-in key? [
+        [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
+        inserting-phi-nodes get push-at
+    ] [ 2drop ] if ;
 
 : compute-phi-nodes-for ( vreg bbs -- )
-    dup length 2 >= [
-        init-insert-phi-nodes
-        work-list get [
-            dom-frontier [
-                compute-phi-node-in
-            ] with each
-        ] with slurp-deque
+    keys dup length 2 >= [
+        iterated-dom-frontier [
+            insert-phi-node-later
+        ] with each
     ] [ 2drop ] if ;
 
 : compute-phi-nodes ( -- )
@@ -143,4 +122,10 @@ M: ##phi rename-insn
 PRIVATE>
 
 : construct-ssa ( cfg -- cfg' )
-    dup [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] bi ;
\ No newline at end of file
+    {
+        [ ]
+        [ compute-live-sets ]
+        [ compute-dominance ]
+        [ compute-defs compute-phi-nodes insert-phi-nodes ]
+        [ rename ]
+    } cleave ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-analysis/authors.txt b/basis/compiler/cfg/stack-analysis/authors.txt
deleted file mode 100644
index d4f5d6b3ae..0000000000
--- a/basis/compiler/cfg/stack-analysis/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
deleted file mode 100644
index 5883777861..0000000000
--- a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
+++ /dev/null
@@ -1,104 +0,0 @@
-IN: compiler.cfg.stack-analysis.merge.tests
-USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
- compiler.cfg.instructions compiler.cfg.stack-analysis.state
-compiler.cfg.utilities compiler.cfg compiler.cfg.registers
-compiler.cfg.debugger cpu.architecture make assocs namespaces
-sequences kernel classes ;
-
-[
-    { D 0 }
-    { V int-regs 0 V int-regs 1 }
-] [
-    <state>
-
-    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
-    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
-
-    <state> H{ { D 0 V int-regs 0 } } >>locs>vregs
-    <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
-
-    H{ } clone added-instructions set
-    V{ } clone added-phis set
-    merge-locs locs>vregs>> keys added-phis get values first
-] unit-test
-
-[
-    { D 0 }
-    ##peek
-] [
-    <state>
-
-    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
-    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
-
-    <state>
-    <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
-
-    H{ } clone added-instructions set
-    V{ } clone added-phis set
-    [ merge-locs locs>vregs>> keys ] { } make drop
-    1 get added-instructions get at first class
-] unit-test
-
-[
-    0 ##inc-d
-] [
-    <state>
-
-    <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
-    <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
-
-    H{ } clone added-instructions set
-    V{ } clone added-phis set
-
-    <state> -1 >>ds-height
-    <state> 2array
-
-    [ merge-ds-heights ds-height>> ] { } make drop
-    1 get added-instructions get at first class
-] unit-test
-
-[
-    0
-    { D 0 }
-    { 1 1 }
-] [
-    <state>
-
-    <basic-block> V{ T{ ##branch } } >>instructions
-    <basic-block> V{ T{ ##branch } } >>instructions 2array
-
-    H{ } clone added-instructions set
-    V{ } clone added-phis set
-    
-    [
-        <state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
-        <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
-
-        [ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop
-    ] keep
-    [ instructions>> length ] map
-] unit-test
-
-[
-    -1
-    { D -1 }
-    { 1 1 }
-] [
-    <state>
-
-    <basic-block> V{ T{ ##branch } } >>instructions
-    <basic-block> V{ T{ ##branch } } >>instructions 2array
-
-    H{ } clone added-instructions set
-    V{ } clone added-phis set
-    
-    [
-        <state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
-        <state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
-
-        [ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop
-        [ ds-height>> ] [ locs>vregs>> keys ] bi
-    ] keep
-    [ instructions>> length ] map
-] unit-test
diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor
deleted file mode 100644
index a53fd7494e..0000000000
--- a/basis/compiler/cfg/stack-analysis/merge/merge.factor
+++ /dev/null
@@ -1,117 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs sequences accessors fry combinators grouping sets
-arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
-compiler.cfg.instructions compiler.cfg.stack-analysis.state
-compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
-IN: compiler.cfg.stack-analysis.merge
-
-: initial-state ( bb states -- state ) 2drop <state> ;
-
-: single-predecessor ( bb states -- state ) nip first clone ;
-
-: save-ds-height ( n -- )
-    dup 0 = [ drop ] [ ##inc-d ] if ;
-
-: merge-ds-heights ( state predecessors states -- state )
-    [ ds-height>> ] map dup all-equal?
-    [ nip first >>ds-height ]
-    [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
-
-: save-rs-height ( n -- )
-    dup 0 = [ drop ] [ ##inc-r ] if ;
-
-: merge-rs-heights ( state predecessors states -- state )
-    [ rs-height>> ] map dup all-equal?
-    [ nip first >>rs-height ]
-    [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
-
-: assoc-map-keys ( assoc quot -- assoc' )
-    '[ _ dip ] assoc-map ; inline
-
-: translate-locs ( assoc state -- assoc' )
-    '[ _ translate-loc ] assoc-map-keys ;
-
-: untranslate-locs ( assoc state -- assoc' )
-    '[ _ untranslate-loc ] assoc-map-keys ;
-
-: collect-locs ( loc-maps states -- assoc )
-    ! assoc maps locs to sequences
-    [ untranslate-locs ] 2map
-    [ [ keys ] map concat prune ] keep
-    '[ dup _ [ at ] with map ] H{ } map>assoc ;
-
-: insert-peek ( predecessor loc state -- vreg )
-    '[ _ _ translate-loc ^^peek ] add-instructions ;
-
-SYMBOL: added-phis
-
-: add-phi-later ( inputs -- vreg )
-    [ int-regs next-vreg dup ] dip 2array added-phis get push ;
-
-: merge-loc ( predecessors vregs loc state -- vreg )
-    ! Insert a ##phi in the current block where the input
-    ! is the vreg storing loc from each predecessor block
-    '[ [ ] [ _ _ insert-peek ] ?if ] 2map
-    dup all-equal? [ first ] [ add-phi-later ] if ;
-
-:: merge-locs ( state predecessors states -- state )
-    states [ locs>vregs>> ] map states collect-locs
-    [| key value |
-        key
-        predecessors value key state merge-loc
-    ] assoc-map
-    state translate-locs
-    state (>>locs>vregs)
-    state ;
-
-: merge-actual-loc ( vregs -- vreg/f )
-    dup all-equal? [ first ] [ drop f ] if ;
-
-:: merge-actual-locs ( state states -- state )
-    states [ actual-locs>vregs>> ] map states collect-locs
-    [ merge-actual-loc ] assoc-map [ nip ] assoc-filter
-    state translate-locs
-    state (>>actual-locs>vregs)
-    state ;
-
-: merge-changed-locs ( state states -- state )
-    [ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine
-    over translate-locs
-    >>changed-locs ;
-
-:: insert-phis ( bb -- )
-    bb predecessors>> :> predecessors
-    [
-        added-phis get [| dst inputs |
-            dst predecessors inputs zip ##phi
-        ] assoc-each
-    ] V{ } make bb instructions>> over push-all
-    bb (>>instructions) ;
-
-:: multiple-predecessors ( bb states -- state )
-    states [ not ] any? [
-        <state>
-        bb add-to-work-list
-    ] [
-        [
-            H{ } clone added-instructions set
-            V{ } clone added-phis set
-            bb predecessors>> :> predecessors
-            state new
-            predecessors states merge-ds-heights
-            predecessors states merge-rs-heights
-            predecessors states merge-locs
-            states merge-actual-locs
-            states merge-changed-locs
-            bb insert-basic-blocks
-            bb insert-phis
-        ] with-scope
-    ] if ;
-
-: merge-states ( bb states -- state )
-    dup length {
-        { 0 [ initial-state ] }
-        { 1 [ single-predecessor ] }
-        [ drop multiple-predecessors ]
-    } case ;
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
deleted file mode 100644
index 9fbf7acf78..0000000000
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ /dev/null
@@ -1,204 +0,0 @@
-USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
-compiler.cfg.predecessors compiler.cfg.stack-analysis
-compiler.cfg.instructions sequences kernel tools.test accessors
-sequences.private alien math combinators.private compiler.cfg
-compiler.cfg.checker compiler.cfg.rpo
-compiler.cfg.dce compiler.cfg.registers
-sets namespaces arrays cpu.architecture ;
-IN: compiler.cfg.stack-analysis.tests
-
-! Fundamental invariant: a basic block should not load or store a value more than once
-: test-stack-analysis ( quot -- cfg )
-    dup cfg? [ test-cfg first ] unless
-    compute-predecessors
-    stack-analysis
-    dup check-cfg ;
-
-: linearize ( cfg -- mr )
-    flatten-cfg instructions>> ;
-
-[ ] [ [ ] test-stack-analysis drop ] unit-test
-
-! Only peek once
-[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
-
-! Redundant replace is redundant
-[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-
-! Replace required here
-[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-
-! Only one replace, at the end
-[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
-
-! Do we support the full language?
-[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
-[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test
-[ ] [
-    [ "int" { "int" "int" } "cdecl" [ + ] alien-callback ]
-    test-cfg second test-stack-analysis drop
-] unit-test
-
-! Test loops
-[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test
-[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test
-
-! Make sure that peeks are inserted in the right place
-[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
-
-! This should be a total no-op
-[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-
-! Don't insert inc-d/inc-r; that's wrong!
-[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
-
-! Bug in height tracking
-[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
-[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test
-[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test
-
-! Bugs with code that throws
-[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test
-[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test
-[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test
-[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test
-
-! Make sure the replace stores a value with the right height
-[ ] [
-    [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize
-    [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi
-] unit-test
-
-! translate-loc was the wrong way round
-[ ] [
-    [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize
-    [ [ ##load-immediate? ] count 2 assert= ]
-    [ [ ##peek? ] count 1 assert= ]
-    [ [ ##replace? ] count 3 assert= ]
-    tri
-] unit-test
-
-[ ] [
-    [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize
-    [ [ ##load-immediate? ] count 2 assert= ]
-    [ [ ##peek? ] count 1 assert= ]
-    [ [ ##replace? ] count 1 assert= ]
-    tri
-] unit-test
-
-! Sync before a back-edge, not after
-! ##peeks should be inserted before a ##loop-entry
-! Don't optimize out the constants
-[ t ] [
-    [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
-    [ ##load-immediate? ] any?
-] unit-test
-
-! Correct height tracking
-[ t ] [
-    [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
-    reverse-post-order 4 swap nth
-    instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
-    2array { D 1 D 0 } set=
-] unit-test
-
-[ D 1 ] [
-    V{ T{ ##branch } } 0 test-bb
-
-    V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb
-
-    V{
-        T{ ##peek f V int-regs 1 D 2 }
-        T{ ##inc-d f -1 }
-        T{ ##branch }
-    } 2 test-bb
-
-    V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb
-
-    V{ T{ ##return } } 4 test-bb
-
-    test-diamond
-
-    cfg new 0 get >>entry
-    compute-predecessors
-    stack-analysis
-    drop
-
-    3 get successors>> first instructions>> first loc>>
-] unit-test
-
-! Do inserted ##peeks reference the correct stack location if
-! an ##inc-d/r was also inserted?
-[ D 0 ] [
-    V{ T{ ##branch } } 0 test-bb
-
-    V{ T{ ##branch } } 1 test-bb
-
-    V{
-        T{ ##peek f V int-regs 1 D 0 }
-        T{ ##branch }
-    } 2 test-bb
-
-    V{
-        T{ ##call f \ + -1 }
-        T{ ##inc-d f 1 }
-        T{ ##branch }
-    } 3 test-bb
-
-    V{ T{ ##return } } 4 test-bb
-
-    test-diamond
-
-    cfg new 0 get >>entry
-    compute-predecessors
-    stack-analysis
-    drop
-
-    3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
-] unit-test
-
-! Missing ##replace
-[ t ] [
-    [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
-    reverse-post-order last
-    instructions>> [ ##replace? ] filter [ loc>> ] map
-    { D 0 D 1 D 2 } set=
-] unit-test
-
-! Inserted ##peeks reference the wrong stack location
-[ t ] [
-    [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
-    eliminate-dead-code reverse-post-order 4 swap nth
-    instructions>> [ ##peek? ] filter [ loc>> ] map
-    { D 0 D 1 } set=
-] unit-test
-
-[ D 0 ] [
-    V{ T{ ##branch } } 0 test-bb
-
-    V{ T{ ##branch } } 1 test-bb
-
-    V{
-        T{ ##peek f V int-regs 1 D 0 }
-        T{ ##inc-d f 1 }
-        T{ ##branch }
-    } 2 test-bb
-
-    V{
-        T{ ##inc-d f 1 }
-        T{ ##branch }
-    } 3 test-bb
-
-    V{ T{ ##return } } 4 test-bb
-
-    test-diamond
-
-    cfg new 0 get >>entry
-    compute-predecessors
-    stack-analysis
-    drop
-
-    3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
-] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
deleted file mode 100644
index ec34c96a24..0000000000
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ /dev/null
@@ -1,124 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel namespaces math sequences fry grouping
-sets make combinators dlists deques
-compiler.cfg
-compiler.cfg.copy-prop
-compiler.cfg.def-use
-compiler.cfg.instructions
-compiler.cfg.registers
-compiler.cfg.rpo
-compiler.cfg.hats
-compiler.cfg.stack-analysis.state
-compiler.cfg.stack-analysis.merge
-compiler.cfg.utilities ;
-IN: compiler.cfg.stack-analysis
-
-SYMBOL: global-optimization?
-
-: redundant-replace? ( vreg loc -- ? )
-    dup state get untranslate-loc n>> 0 <
-    [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
-
-: save-changed-locs ( state -- )
-    [ changed-locs>> keys ] [ locs>vregs>> ] bi '[
-        dup _ at swap 2dup redundant-replace?
-        [ 2drop ] [ state get untranslate-loc ##replace ] if
-    ] each ;
-
-: sync-state ( -- )
-    state get {
-        [ ds-height>> save-ds-height ]
-        [ rs-height>> save-rs-height ]
-        [ save-changed-locs ]
-        [ clear-state ]
-    } cleave ;
-
-! Abstract interpretation
-GENERIC: visit ( insn -- )
-
-M: ##inc-d visit
-    n>> state get [ + ] change-ds-height drop ;
-
-M: ##inc-r visit
-    n>> state get [ + ] change-rs-height drop ;
-
-! Instructions which don't have any effect on the stack
-UNION: neutral-insn
-    ##effect
-    ##flushable
-    ##no-tco ;
-
-M: neutral-insn visit , ;
-
-UNION: sync-if-back-edge
-    ##branch
-    ##conditional-branch
-    ##compare-imm-branch
-    ##dispatch
-    ##loop-entry
-    ##fixnum-overflow ;
-
-: sync-state? ( -- ? )
-    basic-block get successors>>
-    [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
-
-M: sync-if-back-edge visit
-    global-optimization? get [ sync-state? [ sync-state ] when ] unless
-    , ;
-
-: eliminate-peek ( dst src -- )
-    ! the requested stack location is already in 'src'
-    [ ##copy ] [ swap copies get set-at ] 2bi ;
-
-M: ##peek visit
-    [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
-    [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
-
-M: ##replace visit
-    [ src>> resolve ] [ loc>> state get translate-loc ] bi
-    record-replace ;
-
-M: ##copy visit
-    [ call-next-method ] [ record-copy ] bi ;
-
-M: ##jump visit sync-state , ;
-
-M: ##return visit sync-state , ;
-
-M: ##callback-return visit sync-state , ;
-
-M: kill-vreg-insn visit sync-state , ;
-
-! Maps basic-blocks to states
-SYMBOL: state-out
-
-: block-in-state ( bb -- states )
-    dup predecessors>> state-out get '[ _ at ] map merge-states ;
-
-: set-block-out-state ( state bb -- )
-    [ clone ] dip state-out get set-at ;
-
-: visit-block ( bb -- )
-    ! block-in-state may add phi nodes at the start of the basic block
-    ! so we wrap the whole thing with a 'make'
-    [
-        dup basic-block set
-        dup block-in-state
-        state [
-            [ instructions>> [ visit ] each ]
-            [ [ state get ] dip set-block-out-state ]
-            [ ]
-            tri
-        ] with-variable
-    ] V{ } make >>instructions drop ;
-
-: stack-analysis ( cfg -- cfg' )
-    [
-        <hashed-dlist> work-list set
-        H{ } clone copies set
-        H{ } clone state-out set
-        dup [ visit-block ] each-basic-block
-        global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when
-        cfg-changed
-    ] with-scope ;
diff --git a/basis/compiler/cfg/stack-analysis/state/state.factor b/basis/compiler/cfg/stack-analysis/state/state.factor
deleted file mode 100644
index 25fa249853..0000000000
--- a/basis/compiler/cfg/stack-analysis/state/state.factor
+++ /dev/null
@@ -1,53 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets math deques
-compiler.cfg.registers ;
-IN: compiler.cfg.stack-analysis.state
-
-TUPLE: state
-locs>vregs actual-locs>vregs changed-locs
-{ ds-height integer }
-{ rs-height integer }
-poisoned? ;
-
-: <state> ( -- state )
-    state new
-        H{ } clone >>locs>vregs
-        H{ } clone >>actual-locs>vregs
-        H{ } clone >>changed-locs
-        0 >>ds-height
-        0 >>rs-height ;
-
-M: state clone
-    call-next-method
-        [ clone ] change-locs>vregs
-        [ clone ] change-actual-locs>vregs
-        [ clone ] change-changed-locs ;
-
-: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
-
-: record-peek ( dst loc -- )
-    state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
-
-: changed-loc ( loc -- )
-    state get changed-locs>> conjoin ;
-
-: record-replace ( src loc -- )
-    dup changed-loc state get locs>vregs>> set-at ;
-
-: clear-state ( state -- )
-    0 >>ds-height 0 >>rs-height
-    [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
-    [ clear-assoc ] tri@ ;
-
-GENERIC# translate-loc 1 ( loc state -- loc' )
-M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - <ds-loc> ;
-M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
-
-GENERIC# untranslate-loc 1 ( loc state -- loc' )
-M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
-M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;
-
-SYMBOL: work-list
-
-: add-to-work-list ( bb -- ) work-list get push-front ;
diff --git a/basis/compiler/cfg/dcn/rewrite/rewrite.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor
similarity index 50%
rename from basis/compiler/cfg/dcn/rewrite/rewrite.factor
rename to basis/compiler/cfg/stacks/finalize/finalize.factor
index e91aa248e6..5c8c1343d0 100644
--- a/basis/compiler/cfg/dcn/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/stacks/finalize/finalize.factor
@@ -2,29 +2,20 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs kernel fry accessors sequences make math
 combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.dcn.local
-compiler.cfg.dcn.global compiler.cfg.dcn.height ;
-IN: compiler.cfg.dcn.rewrite
+compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local
+compiler.cfg.stacks.global compiler.cfg.stacks.height ;
+IN: compiler.cfg.stacks.finalize
 
-! This pass inserts peeks, replaces, and copies. All stack locations
-! are loaded to canonical vregs, with a 1-1 mapping from location to
-! vreg. SSA is reconstructed afterwards.
+! This pass inserts peeks and replaces.
 
 : inserting-peeks ( from to -- assoc )
     peek-in swap [ peek-out ] [ avail-out ] bi
     assoc-union assoc-diff ;
 
-: remove-dead-stores ( assoc -- assoc' )
-    [ drop n>> 0 >= ] assoc-filter ;
-
 : inserting-replaces ( from to -- assoc )
     [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
     assoc-union assoc-diff ;
 
-SYMBOL: locs>vregs
-
-: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
-
 : each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
     '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
 
@@ -42,30 +33,9 @@ ERROR: bad-peek dst loc ;
     2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
     [ 2drop ] [ <simple-block> insert-basic-block ] if-empty ;
 
-: visit-edges ( bb -- )
+: visit-block ( bb -- )
     [ predecessors>> ] keep '[ _ visit-edge ] each ;
 
-: insert-in-copies ( bb -- )
-    peek [ swap loc>vreg ##copy ] assoc-each ;
-
-: insert-out-copies ( bb -- )
-    replace [ swap loc>vreg swap ##copy ] assoc-each ;
-
-: rewrite-instructions ( bb -- )
-    [
-        [
-            {
-                [ insert-in-copies ]
-                [ instructions>> but-last-slice % ]
-                [ insert-out-copies ]
-                [ instructions>> last , ]
-            } cleave
-        ] V{ } make
-    ] keep (>>instructions) ;
-
-: visit-block ( bb -- )
-    [ visit-edges ] [ rewrite-instructions ] bi ;
-
-: rewrite ( cfg -- )
-    H{ } clone locs>vregs set
-    [ visit-block ] each-basic-block ;
\ No newline at end of file
+: finalize-stack-shuffling ( cfg -- cfg' )
+    dup [ visit-block ] each-basic-block
+    cfg-changed ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/stacks/global/global.factor b/basis/compiler/cfg/stacks/global/global.factor
new file mode 100644
index 0000000000..129d7e74cd
--- /dev/null
+++ b/basis/compiler/cfg/stacks/global/global.factor
@@ -0,0 +1,39 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel combinators compiler.cfg.dataflow-analysis
+compiler.cfg.stacks.local ;
+IN: compiler.cfg.stacks.global
+
+! Peek analysis. Peek-in is the set of all locations anticipated at
+! the start of a basic block.
+BACKWARD-ANALYSIS: peek
+
+M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ;
+
+! Replace analysis. Replace-in is the set of all locations which
+! will be overwritten at some point after the start of a basic block.
+FORWARD-ANALYSIS: replace
+
+M: replace-analysis transfer-set drop replace-set assoc-union ;
+
+! Availability analysis. Avail-out is the set of all locations
+! in registers at the end of a basic block.
+FORWARD-ANALYSIS: avail
+
+M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ;
+
+! Kill analysis. Kill-in is the set of all locations
+! which are going to be overwritten.
+BACKWARD-ANALYSIS: kill
+
+M: kill-analysis transfer-set drop replace-set assoc-union ;
+
+! Main word
+: compute-global-sets ( cfg -- cfg' )
+    {
+        [ compute-peek-sets ]
+        [ compute-replace-sets ]
+        [ compute-avail-sets ]
+        [ compute-kill-sets ]
+        [ ]
+    } cleave ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/stacks/height/height.factor b/basis/compiler/cfg/stacks/height/height.factor
new file mode 100644
index 0000000000..4d91dc614a
--- /dev/null
+++ b/basis/compiler/cfg/stacks/height/height.factor
@@ -0,0 +1,27 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry kernel math
+namespaces compiler.cfg.registers ;
+IN: compiler.cfg.stacks.height
+
+! Global stack height tracking done while constructing CFG.
+SYMBOLS: ds-heights rs-heights ;
+
+: record-stack-heights ( ds-height rs-height bb -- )
+    [ ds-heights get set-at ] [ rs-heights get set-at ] bi-curry bi* ;
+
+GENERIC# translate-loc 1 ( loc bb -- loc' )
+
+M: ds-loc translate-loc [ n>> ] [ ds-heights get at ] bi* - <ds-loc> ;
+M: rs-loc translate-loc [ n>> ] [ rs-heights get at ] bi* - <rs-loc> ;
+
+: translate-locs ( assoc bb -- assoc' )
+    '[ [ _ translate-loc ] dip ] assoc-map ;
+
+GENERIC# untranslate-loc 1 ( loc bb -- loc' )
+
+M: ds-loc untranslate-loc [ n>> ] [ ds-heights get at ] bi* + <ds-loc> ;
+M: rs-loc untranslate-loc [ n>> ] [ rs-heights get at ] bi* + <rs-loc> ;
+
+: untranslate-locs ( assoc bb -- assoc' )
+    '[ [ _ untranslate-loc ] dip ] assoc-map ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor
new file mode 100644
index 0000000000..754789042a
--- /dev/null
+++ b/basis/compiler/cfg/stacks/local/local.factor
@@ -0,0 +1,91 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel math namespaces sets make sequences
+compiler.cfg
+compiler.cfg.hats
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.stacks.height
+compiler.cfg.parallel-copy ;
+IN: compiler.cfg.stacks.local
+
+! Local stack analysis. We build local peek and replace sets for every basic
+! block while constructing the CFG.
+
+SYMBOLS: peek-sets replace-sets ;
+
+SYMBOL: locs>vregs
+
+: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
+: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
+
+TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
+
+SYMBOLS: local-peek-set local-replace-set replace-mapping ;
+
+GENERIC: translate-local-loc ( loc -- loc' )
+M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
+M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
+
+: emit-stack-changes ( -- )
+    replace-mapping get dup assoc-empty? [ drop ] [
+        [ [ loc>vreg ] dip ] assoc-map parallel-copy
+    ] if ;
+
+: emit-height-changes ( -- )
+    current-height get
+    [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ]
+    [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ;
+
+: emit-changes ( -- )
+    ! Insert height and stack changes prior to the last instruction
+    building get pop
+    emit-stack-changes
+    emit-height-changes
+    , ;
+
+! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
+: inc-d ( n -- )
+    current-height get
+    [ [ + ] change-emit-d drop ]
+    [ [ + ] change-d drop ]
+    2bi ;
+
+: inc-r ( n -- )
+    current-height get
+    [ [ + ] change-emit-r drop ]
+    [ [ + ] change-r drop ]
+    2bi ;
+
+: peek-loc ( loc -- vreg )
+    translate-local-loc
+    dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
+    dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
+
+: replace-loc ( vreg loc -- )
+    translate-local-loc
+    2dup loc>vreg =
+    [ nip replace-mapping get delete-at ]
+    [
+        [ local-replace-set get conjoin ]
+        [ replace-mapping get set-at ]
+        bi
+    ] if ;
+
+: begin-local-analysis ( -- )
+    H{ } clone local-peek-set set
+    H{ } clone local-replace-set set
+    H{ } clone replace-mapping set
+    current-height get 0 >>emit-d 0 >>emit-r drop
+    current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
+
+: end-local-analysis ( -- )
+    emit-changes
+    local-peek-set get basic-block get peek-sets get set-at
+    local-replace-set get basic-block get replace-sets get set-at ;
+
+: clone-current-height ( -- )
+    current-height [ clone ] change ;
+
+: peek-set ( bb -- assoc ) peek-sets get at ;
+: replace-set ( bb -- assoc ) replace-sets get at ;
diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor
index c8fcae87c0..2683222fb8 100755
--- a/basis/compiler/cfg/stacks/stacks.factor
+++ b/basis/compiler/cfg/stacks/stacks.factor
@@ -1,45 +1,76 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math sequences kernel cpu.architecture
-compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.hats ;
+USING: math sequences kernel namespaces accessors biassocs compiler.cfg
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
+compiler.cfg.predecessors compiler.cfg.stacks.local
+compiler.cfg.stacks.height compiler.cfg.stacks.global
+compiler.cfg.stacks.finalize ;
 IN: compiler.cfg.stacks
 
-: ds-drop ( -- )
-    -1 ##inc-d ;
+: begin-stack-analysis ( -- )
+    <bihash> locs>vregs set
+    H{ } clone ds-heights set
+    H{ } clone rs-heights set
+    H{ } clone peek-sets set
+    H{ } clone replace-sets set
+    current-height new current-height set ;
 
-: ds-pop ( -- vreg )
-    D 0 ^^peek -1 ##inc-d ;
+: end-stack-analysis ( -- )
+    cfg get
+    compute-predecessors
+    compute-global-sets
+    finalize-stack-shuffling
+    drop ;
 
-: ds-push ( vreg -- )
-    1 ##inc-d D 0 ##replace ;
+: ds-drop ( -- ) -1 inc-d ;
+
+: ds-peek ( -- vreg ) D 0 peek-loc ;
+
+: ds-pop ( -- vreg ) ds-peek ds-drop ;
+
+: ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ;
 
 : ds-load ( n -- vregs )
     dup 0 =
     [ drop f ]
-    [ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ] if ;
+    [ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
 
 : ds-store ( vregs -- )
     [
         <reversed>
-        [ length ##inc-d ]
-        [ [ <ds-loc> ##replace ] each-index ] bi
+        [ length inc-d ]
+        [ [ <ds-loc> replace-loc ] each-index ] bi
     ] unless-empty ;
 
+: rs-drop ( -- ) -1 inc-r ;
+
 : rs-load ( n -- vregs )
     dup 0 =
     [ drop f ]
-    [ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ] if ;
+    [ [ <reversed> [ <rs-loc> peek-loc ] map ] [ neg inc-r ] bi ] if ;
 
 : rs-store ( vregs -- )
     [
         <reversed>
-        [ length ##inc-r ]
-        [ [ <rs-loc> ##replace ] each-index ] bi
+        [ length inc-r ]
+        [ [ <rs-loc> replace-loc ] each-index ] bi
     ] unless-empty ;
 
+: (2inputs) ( -- vreg1 vreg2 )
+    D 1 peek-loc D 0 peek-loc ;
+
 : 2inputs ( -- vreg1 vreg2 )
-    D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
+    (2inputs) -2 inc-d ;
+
+: (3inputs) ( -- vreg1 vreg2 vreg3 )
+    D 2 peek-loc D 1 peek-loc D 0 peek-loc ;
 
 : 3inputs ( -- vreg1 vreg2 vreg3 )
-    D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;
+    (3inputs) -3 inc-d ;
+
+! adjust-d/adjust-r: these are called when other instructions which
+! internally adjust the stack height are emitted, such as ##call and
+! ##alien-invoke
+: adjust-d ( n -- ) current-height get [ + ] change-d drop ;
+: adjust-r ( n -- ) current-height get [ + ] change-r drop ;
+
diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor
index 87be509c6f..0a52aa7c1a 100644
--- a/basis/compiler/cfg/two-operand/two-operand.factor
+++ b/basis/compiler/cfg/two-operand/two-operand.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel sequences make compiler.cfg.instructions
-compiler.cfg.local cpu.architecture ;
+compiler.cfg.rpo cpu.architecture ;
 IN: compiler.cfg.two-operand
 
 ! On x86, instructions take the form x = x op y
@@ -54,7 +54,6 @@ M: insn convert-two-operand* , ;
 
 : convert-two-operand ( cfg -- cfg' )
     two-operand? [
-        [ drop ]
         [ [ [ convert-two-operand* ] each ] V{ } make ]
         local-optimization
     ] when ;
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index c3d3e47485..4b0468b911 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -20,42 +20,6 @@ IN: compiler.cfg.utilities
         } cond
     ] [ drop f ] if ;
 
-: set-basic-block ( basic-block -- )
-    [ basic-block set ] [ instructions>> building set ] bi ;
-
-: begin-basic-block ( -- )
-    <basic-block> basic-block get [
-        dupd successors>> push
-    ] when*
-    set-basic-block ;
-
-: end-basic-block ( -- )
-    building off
-    basic-block off ;
-
-: emit-trivial-block ( quot -- )
-    basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless
-    call
-    ##branch begin-basic-block ; inline
-
-: call-height ( #call -- n )
-    [ out-d>> length ] [ in-d>> length ] bi - ;
-
-: emit-primitive ( node -- )
-    [ [ word>> ] [ call-height ] bi ##call ] emit-trivial-block ;
-
-: with-branch ( quot -- final-bb )
-    [
-        begin-basic-block
-        call
-        basic-block get dup [ ##branch ] when
-    ] with-scope ; inline
-
-: emit-conditional ( branches -- )
-    end-basic-block
-    begin-basic-block
-    basic-block get '[ [ _ swap successors>> push ] when* ] each ;
-
 PREDICATE: kill-block < basic-block
     instructions>> {
         [ length 2 = ]
@@ -84,16 +48,6 @@ SYMBOL: visited
 : skip-empty-blocks ( bb -- bb' )
     H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
 
-! assoc mapping predecessors to sequences
-SYMBOL: added-instructions
-
-: add-instructions ( predecessor quot -- )
-    [
-        added-instructions get
-        [ drop V{ } clone ] cache
-        building
-    ] dip with-variable ; inline
-
 :: insert-basic-block ( from to bb -- )
     bb from 1vector >>predecessors drop
     bb to 1vector >>successors drop
@@ -105,7 +59,3 @@ SYMBOL: added-instructions
     swap >vector
     \ ##branch new-insn over push
     >>instructions ;
-
-: insert-basic-blocks ( bb -- )
-    [ added-instructions get ] dip
-    '[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index 76ad3d892f..87fa959178 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -6,7 +6,6 @@ compiler.cfg.value-numbering.graph ;
 IN: compiler.cfg.value-numbering.expressions
 
 ! Referentially-transparent expressions
-TUPLE: expr op ;
 TUPLE: unary-expr < expr in ;
 TUPLE: binary-expr < expr in1 in2 ;
 TUPLE: commutative-expr < binary-expr ;
@@ -37,17 +36,6 @@ M: reference-expr equal?
         } cond
     ] [ 2drop f ] if ;
 
-! Expressions whose values are inputs to the basic block. We
-! can eliminate a second computation having the same 'n' as
-! the first one; we can also eliminate input-exprs whose
-! result is not used.
-TUPLE: input-expr < expr n ;
-
-SYMBOL: input-expr-counter
-
-: next-input-expr ( class -- expr )
-    input-expr-counter [ dup 1 + ] change input-expr boa ;
-
 : constant>vn ( constant -- vn ) <constant> expr>vn ; inline
 
 GENERIC: >expr ( insn -- expr )
@@ -97,7 +85,7 @@ M: ##compare-imm >expr compare-imm>expr ;
 
 M: ##compare-float >expr compare>expr ;
 
-M: ##flushable >expr class next-input-expr ;
+M: ##flushable >expr drop next-input-expr ;
 
 : init-expressions ( -- )
     0 input-expr-counter set ;
diff --git a/basis/compiler/cfg/value-numbering/graph/graph.factor b/basis/compiler/cfg/value-numbering/graph/graph.factor
index 41e7201953..77b75bd3ac 100644
--- a/basis/compiler/cfg/value-numbering/graph/graph.factor
+++ b/basis/compiler/cfg/value-numbering/graph/graph.factor
@@ -10,13 +10,24 @@ SYMBOL: vn-counter
 ! biassoc mapping expressions to value numbers
 SYMBOL: exprs>vns
 
+TUPLE: expr op ;
+
 : expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
 
 : vn>expr ( vn -- expr ) exprs>vns get value-at ;
 
+! Expressions whose values are inputs to the basic block.
+TUPLE: input-expr < expr n ;
+
+SYMBOL: input-expr-counter
+
+: next-input-expr ( -- expr )
+    f input-expr-counter counter input-expr boa ;
+
 SYMBOL: vregs>vns
 
-: vreg>vn ( vreg -- vn ) vregs>vns get at ;
+: vreg>vn ( vreg -- vn )
+    vregs>vns get [ drop next-input-expr expr>vn ] cache ;
 
 : vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
 
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index fcd1b1c9ac..4b8ee2a1ae 100755
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -20,13 +20,9 @@ IN: compiler.cfg.value-numbering.rewrite
 
 ! Outputs f to mean no change
 
-GENERIC: rewrite* ( insn -- insn/f )
+GENERIC: rewrite ( insn -- insn/f )
 
-: rewrite ( insn -- insn' )
-    dup [ number-values ] [ rewrite* ] bi
-    [ rewrite ] [ ] ?if ;
-
-M: insn rewrite* drop f ;
+M: insn rewrite drop f ;
 
 : ##branch-t? ( insn -- ? )
     dup ##compare-imm-branch? [
@@ -123,7 +119,7 @@ ERROR: bad-comparison ;
 : fold-compare-imm-branch ( insn -- insn/f )
     (fold-compare-imm) fold-branch ;
 
-M: ##compare-imm-branch rewrite*
+M: ##compare-imm-branch rewrite
     {
         { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
         { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
@@ -154,7 +150,7 @@ M: ##compare-imm-branch rewrite*
 : rewrite-self-compare-branch ( insn -- insn' )
     (rewrite-self-compare) fold-branch ;
 
-M: ##compare-branch rewrite*
+M: ##compare-branch rewrite
     {
         { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
         { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
@@ -185,7 +181,7 @@ M: ##compare-branch rewrite*
 : rewrite-self-compare ( insn -- insn' )
     dup (rewrite-self-compare) >boolean-insn ;
 
-M: ##compare rewrite*
+M: ##compare rewrite
     {
         { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
         { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
@@ -196,7 +192,7 @@ M: ##compare rewrite*
 : fold-compare-imm ( insn -- insn' )
     dup (fold-compare-imm) >boolean-insn ;
 
-M: ##compare-imm rewrite*
+M: ##compare-imm rewrite
     {
         { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
         { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
@@ -238,7 +234,7 @@ M: ##shl-imm constant-fold* drop shift ;
     ] dip
     over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
 
-M: ##add-imm rewrite*
+M: ##add-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         { [ dup reassociate? ] [ \ ##add-imm reassociate ] }
@@ -249,7 +245,7 @@ M: ##add-imm rewrite*
     [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
     [ \ ##add-imm new-insn ] [ 3drop f ] if ;
 
-M: ##sub-imm rewrite*
+M: ##sub-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         [ sub-imm>add-imm ]
@@ -261,7 +257,7 @@ M: ##sub-imm rewrite*
 : strength-reduce-mul? ( insn -- ? )
     src2>> power-of-2? ;
 
-M: ##mul-imm rewrite*
+M: ##mul-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
@@ -269,40 +265,40 @@ M: ##mul-imm rewrite*
         [ drop f ]
     } cond ;
 
-M: ##and-imm rewrite*
+M: ##and-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         { [ dup reassociate? ] [ \ ##and-imm reassociate ] }
         [ drop f ]
     } cond ;
 
-M: ##or-imm rewrite*
+M: ##or-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         { [ dup reassociate? ] [ \ ##or-imm reassociate ] }
         [ drop f ]
     } cond ;
 
-M: ##xor-imm rewrite*
+M: ##xor-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         { [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
         [ drop f ]
     } cond ;
 
-M: ##shl-imm rewrite*
+M: ##shl-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         [ drop f ]
     } cond ;
 
-M: ##shr-imm rewrite*
+M: ##shr-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         [ drop f ]
     } cond ;
 
-M: ##sar-imm rewrite*
+M: ##sar-imm rewrite
     {
         { [ dup constant-fold? ] [ constant-fold ] }
         [ drop f ]
@@ -327,7 +323,7 @@ M: ##sar-imm rewrite*
         [ 2drop f ]
     } cond ; inline
 
-M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
+M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ;
 
 : subtraction-identity? ( insn -- ? )
     [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq?  ;
@@ -335,22 +331,22 @@ M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
 : rewrite-subtraction-identity ( insn -- insn' )
     dst>> 0 \ ##load-immediate new-insn ;
 
-M: ##sub rewrite*
+M: ##sub rewrite
     {
         { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
         [ \ ##sub-imm rewrite-arithmetic ]
     } cond ;
 
-M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ;
+M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ;
 
-M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ;
+M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ;
 
-M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ;
+M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ;
 
-M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ;
+M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ;
 
-M: ##shl rewrite* \ ##shl-imm rewrite-arithmetic ;
+M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ;
 
-M: ##shr rewrite* \ ##shr-imm rewrite-arithmetic ;
+M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
 
-M: ##sar rewrite* \ ##sar-imm rewrite-arithmetic ;
+M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
index 5934643acc..6bd84021b3 100644
--- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor
+++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor
@@ -127,7 +127,5 @@ M: expr simplify* drop f ;
         { [ dup integer? ] [ nip ] }
     } cond ;
 
-GENERIC: number-values ( insn -- )
-
-M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ;
-M: insn number-values drop ;
+: number-values ( insn -- )
+    [ >expr simplify ] [ dst>> ] bi set-vn ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index bd2bb692b7..60d06fcde4 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -3,7 +3,7 @@ USING: compiler.cfg.value-numbering compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
 cpu.architecture tools.test kernel math combinators.short-circuit
 accessors sequences compiler.cfg.predecessors locals
-compiler.cfg.phi-elimination compiler.cfg.dce compiler.cfg.liveness
+compiler.cfg.phi-elimination compiler.cfg.dce
 compiler.cfg assocs vectors arrays layouts namespaces ;
 
 : trim-temps ( insns -- insns )
@@ -15,10 +15,6 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         } 1|| [ f >>temp ] when
     ] map ;
 
-: test-value-numbering ( insns -- insns )
-    { } init-value-numbering
-    value-numbering-step ;
-
 ! Folding constants together
 [
     {
@@ -33,15 +29,15 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-reference f V int-regs 1 -0.0 }
         T{ ##replace f V int-regs 0 D 0 }
         T{ ##replace f V int-regs 1 D 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
     {
         T{ ##load-reference f V int-regs 0 0.0 }
-        T{ ##load-reference f V int-regs 1 0.0 }
+        T{ ##copy f V int-regs 1 V int-regs 0 }
         T{ ##replace f V int-regs 0 D 0 }
-        T{ ##replace f V int-regs 0 D 1 }
+        T{ ##replace f V int-regs 1 D 1 }
     }
 ] [
     {
@@ -49,15 +45,15 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-reference f V int-regs 1 0.0 }
         T{ ##replace f V int-regs 0 D 0 }
         T{ ##replace f V int-regs 1 D 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
     {
         T{ ##load-reference f V int-regs 0 t }
-        T{ ##load-reference f V int-regs 1 t }
+        T{ ##copy f V int-regs 1 V int-regs 0 }
         T{ ##replace f V int-regs 0 D 0 }
-        T{ ##replace f V int-regs 0 D 1 }
+        T{ ##replace f V int-regs 1 D 1 }
     }
 ] [
     {
@@ -65,22 +61,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-reference f V int-regs 1 t }
         T{ ##replace f V int-regs 0 D 0 }
         T{ ##replace f V int-regs 1 D 1 }
-    } test-value-numbering
-] unit-test
-
-! Copy propagation
-[
-    {
-        T{ ##peek f V int-regs 45 D 1 }
-        T{ ##copy f V int-regs 48 V int-regs 45 }
-        T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 45 D 1 }
-        T{ ##copy f V int-regs 48 V int-regs 45 }
-        T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 ! Compare propagation
@@ -89,8 +70,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-reference f V int-regs 1 + }
         T{ ##peek f V int-regs 2 D 0 }
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
-        T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
-        T{ ##replace f V int-regs 4 D 0 }
+        T{ ##copy f V int-regs 6 V int-regs 4 }
+        T{ ##replace f V int-regs 6 D 0 }
     }
 ] [
     {
@@ -99,7 +80,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
         T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
         T{ ##replace f V int-regs 6 D 0 }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 [
@@ -117,7 +98,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
         T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
         T{ ##replace f V int-regs 6 D 0 }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 [
@@ -139,7 +120,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
         T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
         T{ ##replace f V int-regs 14 D 0 }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 [
@@ -155,7 +136,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 30 D -2 }
         T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
         T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 ! Immediate operand conversion
@@ -170,7 +151,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -184,7 +165,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -198,7 +179,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -210,7 +191,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##sub f V int-regs 1 V int-regs 0 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -224,7 +205,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -238,7 +219,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -250,7 +231,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
     {
         T{ ##peek f V int-regs 1 D 0 }
         T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -264,7 +245,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -278,7 +259,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -292,7 +273,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -306,7 +287,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -320,7 +301,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -334,7 +315,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -348,7 +329,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##compare f V int-regs 2 V int-regs 0 V int-regs 1 cc<= }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 [
@@ -362,7 +343,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##compare f V int-regs 2 V int-regs 1 V int-regs 0 cc<= }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 [
@@ -376,7 +357,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##compare-branch f V int-regs 0 V int-regs 1 cc<= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -390,7 +371,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 100 }
         T{ ##compare-branch f V int-regs 1 V int-regs 0 cc<= }
-    } test-value-numbering trim-temps
+    } value-numbering-step trim-temps
 ] unit-test
 
 ! Reassociation
@@ -409,7 +390,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##add f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -427,7 +408,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -445,7 +426,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -463,7 +444,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -481,7 +462,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##mul f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -499,7 +480,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##mul f V int-regs 4 V int-regs 3 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -517,7 +498,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##and f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -535,7 +516,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##and f V int-regs 4 V int-regs 3 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -553,7 +534,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##or f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -571,7 +552,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##or f V int-regs 4 V int-regs 3 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -589,7 +570,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##xor f V int-regs 4 V int-regs 2 V int-regs 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -607,7 +588,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
         T{ ##load-immediate f V int-regs 3 50 }
         T{ ##xor f V int-regs 4 V int-regs 3 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 ! Simplification
@@ -616,8 +597,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
         T{ ##load-immediate f V int-regs 2 0 }
-        T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
-        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##copy f V int-regs 3 V int-regs 0 }
+        T{ ##replace f V int-regs 3 D 0 }
     }
 ] [
     {
@@ -626,7 +607,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
         T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
         T{ ##replace f V int-regs 3 D 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -634,8 +615,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
         T{ ##load-immediate f V int-regs 2 0 }
-        T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
-        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##copy f V int-regs 3 V int-regs 0 }
+        T{ ##replace f V int-regs 3 D 0 }
     }
 ] [
     {
@@ -644,7 +625,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
         T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 }
         T{ ##replace f V int-regs 3 D 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -652,8 +633,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
         T{ ##load-immediate f V int-regs 2 0 }
-        T{ ##or-imm f V int-regs 3 V int-regs 0 0 }
-        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##copy f V int-regs 3 V int-regs 0 }
+        T{ ##replace f V int-regs 3 D 0 }
     }
 ] [
     {
@@ -662,7 +643,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
         T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 }
         T{ ##replace f V int-regs 3 D 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -670,8 +651,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##peek f V int-regs 1 D 1 }
         T{ ##load-immediate f V int-regs 2 0 }
-        T{ ##xor-imm f V int-regs 3 V int-regs 0 0 }
-        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##copy f V int-regs 3 V int-regs 0 }
+        T{ ##replace f V int-regs 3 D 0 }
     }
 ] [
     {
@@ -680,15 +661,15 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
         T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 }
         T{ ##replace f V int-regs 3 D 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 1 }
-        T{ ##shl-imm f V int-regs 2 V int-regs 0 0 }
-        T{ ##replace f V int-regs 0 D 0 }
+        T{ ##copy f V int-regs 2 V int-regs 0 }
+        T{ ##replace f V int-regs 2 D 0 }
     }
 ] [
     {
@@ -696,7 +677,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
         T{ ##replace f V int-regs 2 D 0 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 ! Constant folding
@@ -713,7 +694,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 3 }
         T{ ##add f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -729,7 +710,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 3 }
         T{ ##sub f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -745,7 +726,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 2 }
         T{ ##load-immediate f V int-regs 2 3 }
         T{ ##mul f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -761,7 +742,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 2 }
         T{ ##load-immediate f V int-regs 2 1 }
         T{ ##and f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -777,7 +758,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 2 }
         T{ ##load-immediate f V int-regs 2 1 }
         T{ ##or f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -793,7 +774,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##load-immediate f V int-regs 1 2 }
         T{ ##load-immediate f V int-regs 2 3 }
         T{ ##xor f V int-regs 3 V int-regs 1 V int-regs 2 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -807,7 +788,7 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##shl-imm f V int-regs 3 V int-regs 1 3 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 cell 8 = [
@@ -822,7 +803,7 @@ cell 8 = [
             T{ ##peek f V int-regs 0 D 0 }
             T{ ##load-immediate f V int-regs 1 -1 }
             T{ ##shr-imm f V int-regs 3 V int-regs 1 16 }
-        } test-value-numbering
+        } value-numbering-step
     ] unit-test
 ] when
 
@@ -837,7 +818,7 @@ cell 8 = [
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##load-immediate f V int-regs 1 -8 }
         T{ ##sar-imm f V int-regs 3 V int-regs 1 1 }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 cell 8 = [
@@ -854,7 +835,7 @@ cell 8 = [
             T{ ##load-immediate f V int-regs 1 65536 }
             T{ ##shl-imm f V int-regs 2 V int-regs 1 31 }
             T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
-        } test-value-numbering
+        } value-numbering-step
     ] unit-test
 
     [
@@ -868,7 +849,7 @@ cell 8 = [
             T{ ##peek f V int-regs 0 D 0 }
             T{ ##load-immediate f V int-regs 2 140737488355328 }
             T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
-        } test-value-numbering
+        } value-numbering-step
     ] unit-test
 
     [
@@ -884,7 +865,7 @@ cell 8 = [
             T{ ##load-immediate f V int-regs 2 2147483647 }
             T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
             T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
-        } test-value-numbering
+        } value-numbering-step
     ] unit-test
 ] when
 
@@ -900,7 +881,7 @@ cell 8 = [
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 2 }
         T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -914,7 +895,7 @@ cell 8 = [
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 2 }
         T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc/= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -928,7 +909,7 @@ cell 8 = [
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 2 }
         T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc< }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -942,7 +923,7 @@ cell 8 = [
         T{ ##load-immediate f V int-regs 1 1 }
         T{ ##load-immediate f V int-regs 2 2 }
         T{ ##compare f V int-regs 3 V int-regs 2 V int-regs 1 cc< }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -954,7 +935,7 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc< }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -966,7 +947,7 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -978,7 +959,7 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc> }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -990,7 +971,7 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc>= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -1002,7 +983,7 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc/= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 [
@@ -1014,12 +995,12 @@ cell 8 = [
     {
         T{ ##peek f V int-regs 0 D 0 }
         T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc= }
-    } test-value-numbering
+    } value-numbering-step
 ] unit-test
 
 : test-branch-folding ( insns -- insns' n )
     <basic-block>
-    [ V{ 0 1 } clone >>successors basic-block set test-value-numbering ] keep
+    [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
     successors>> first ;
 
 [
@@ -1208,7 +1189,6 @@ test-diamond
 
 [ ] [
     cfg new 0 get >>entry
-    compute-liveness
     value-numbering
     compute-predecessors
     eliminate-phis drop
@@ -1253,7 +1233,6 @@ test-diamond
 [ ] [
     cfg new 0 get >>entry
     compute-predecessors
-    compute-liveness
     value-numbering
     compute-predecessors
     eliminate-dead-code
@@ -1324,7 +1303,7 @@ V{
 
 [ ] [
     cfg new 0 get >>entry
-    compute-liveness value-numbering eliminate-dead-code drop
+    value-numbering eliminate-dead-code drop
 ] unit-test
 
 [ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index e49555e06e..a249f71c02 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -1,11 +1,10 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs biassocs classes kernel math accessors
-sorting sets sequences fry
+USING: namespaces assocs kernel accessors
+sorting sets sequences
 compiler.cfg
-compiler.cfg.local
-compiler.cfg.liveness
-compiler.cfg.renaming
+compiler.cfg.rpo
+compiler.cfg.instructions
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.simplify
@@ -13,27 +12,28 @@ compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering
 
 ! Local value numbering. Predecessors must be recomputed after this
+: >copy ( insn -- insn/##copy )
+    dup dst>> dup vreg>vn vn>vreg
+    2dup eq? [ 2drop ] [ \ ##copy new-insn nip ] if ;
 
-: number-input-values ( live-in -- )
-    [ [ f next-input-expr simplify ] dip set-vn ] each ;
+: rewrite-loop ( insn -- insn' )
+    dup rewrite [ rewrite-loop ] [ ] ?if ;
 
-: init-value-numbering ( live-in -- )
-    init-value-graph
-    init-expressions
-    number-input-values ;
+GENERIC: process-instruction ( insn -- insn' )
 
-: vreg>vreg-mapping ( -- assoc )
-    vregs>vns get [ keys ] keep
-    '[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ;
+M: ##flushable process-instruction
+    dup rewrite
+    [ process-instruction ]
+    [ dup number-values >copy ] ?if ;
 
-: rename-uses ( insns -- )
-    vreg>vreg-mapping renamings [
-        [ rename-insn-uses ] each
-    ] with-variable ;
+M: insn process-instruction
+    dup rewrite
+    [ process-instruction ] [ ] ?if ;
 
 : value-numbering-step ( insns -- insns' )
-    [ rewrite ] map dup rename-uses ;
+    init-value-graph
+    init-expressions
+    [ process-instruction ] map ;
 
 : value-numbering ( cfg -- cfg' )
-    [ init-value-numbering ] [ value-numbering-step ] local-optimization
-    cfg-changed ;
+    [ value-numbering-step ] local-optimization cfg-changed ;
diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
index c1a667c004..14197bc3f7 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
@@ -1,42 +1,43 @@
 USING: compiler.cfg.write-barrier compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-arrays tools.test vectors compiler.cfg kernel accessors ;
+arrays tools.test vectors compiler.cfg kernel accessors
+compiler.cfg.utilities ;
 IN: compiler.cfg.write-barrier.tests
 
 : test-write-barrier ( insns -- insns )
-    write-barriers-step ;
+    <simple-block> dup write-barriers-step instructions>> ;
 
 [
-    {
+    V{
         T{ ##peek f V int-regs 4 D 0 f }
-        T{ ##copy f V int-regs 6 V int-regs 4 f }
         T{ ##allot f V int-regs 7 24 array V int-regs 8 f }
         T{ ##load-immediate f V int-regs 9 8 f }
         T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f }
-        T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f }
+        T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 f }
         T{ ##replace f V int-regs 7 D 0 f }
+        T{ ##branch }
     }
 ] [
     {
         T{ ##peek f V int-regs 4 D 0 }
-        T{ ##copy f V int-regs 6 V int-regs 4 }
         T{ ##allot f V int-regs 7 24 array V int-regs 8 }
         T{ ##load-immediate f V int-regs 9 8 }
         T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 }
         T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 }
-        T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
+        T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 }
         T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
         T{ ##replace f V int-regs 7 D 0 }
     } test-write-barrier
 ] unit-test
 
 [
-    {
+    V{
         T{ ##load-immediate f V int-regs 4 24 }
         T{ ##peek f V int-regs 5 D -1 }
         T{ ##peek f V int-regs 6 D -2 }
         T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
         T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+        T{ ##branch }
     }
 ] [
     {
@@ -49,28 +50,23 @@ IN: compiler.cfg.write-barrier.tests
 ] unit-test
 
 [
-    {
+    V{
         T{ ##peek f V int-regs 19 D -3 }
         T{ ##peek f V int-regs 22 D -2 }
-        T{ ##copy f V int-regs 23 V int-regs 19 }
-        T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
-        T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
-        T{ ##copy f V int-regs 26 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
+        T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
         T{ ##peek f V int-regs 28 D -1 }
-        T{ ##copy f V int-regs 29 V int-regs 19 }
-        T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
+        T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
+        T{ ##branch }
     }
 ] [
     {
         T{ ##peek f V int-regs 19 D -3 }
         T{ ##peek f V int-regs 22 D -2 }
-        T{ ##copy f V int-regs 23 V int-regs 19 }
-        T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
-        T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
-        T{ ##copy f V int-regs 26 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
+        T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
         T{ ##peek f V int-regs 28 D -1 }
-        T{ ##copy f V int-regs 29 V int-regs 19 }
-        T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
-        T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
+        T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
+        T{ ##write-barrier f V int-regs 19 V int-regs 30 V int-regs 3 }
     } test-write-barrier
 ] unit-test
diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor
index b260b0464e..2f32a4ca81 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets sequences locals
-compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
-compiler.cfg.liveness compiler.cfg.local ;
+USING: kernel accessors namespaces assocs sets sequences
+compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
 IN: compiler.cfg.write-barrier
 
 ! Eliminate redundant write barrier hits.
@@ -14,33 +13,27 @@ SYMBOL: safe
 ! Objects which have been mutated
 SYMBOL: mutated
 
-GENERIC: eliminate-write-barrier ( insn -- insn' )
+GENERIC: eliminate-write-barrier ( insn -- ? )
 
 M: ##allot eliminate-write-barrier
-    dup dst>> safe get conjoin ;
+    dst>> safe get conjoin t ;
 
 M: ##write-barrier eliminate-write-barrier
-    dup src>> resolve dup
-    [ safe get key? not ]
-    [ mutated get key? ] bi and
-    [ safe get conjoin ] [ 2drop f ] if ;
-
-M: ##copy eliminate-write-barrier
-    dup record-copy ;
+    src>> dup [ safe get key? not ] [ mutated get key? ] bi and
+    [ safe get conjoin t ] [ drop f ] if ;
 
 M: ##set-slot eliminate-write-barrier
-    dup obj>> resolve mutated get conjoin ;
+    obj>> mutated get conjoin t ;
 
 M: ##set-slot-imm eliminate-write-barrier
-    dup obj>> resolve mutated get conjoin ;
+    obj>> mutated get conjoin t ;
 
-M: insn eliminate-write-barrier ;
+M: insn eliminate-write-barrier drop t ;
 
-: write-barriers-step ( insns -- insns' )
+: write-barriers-step ( bb -- )
     H{ } clone safe set
     H{ } clone mutated set
-    H{ } clone copies set
-    [ eliminate-write-barrier ] map sift ;
+    instructions>> [ eliminate-write-barrier ] filter-here ;
 
 : eliminate-write-barriers ( cfg -- cfg' )
-    [ drop ] [ write-barriers-step ] local-optimization ;
+    dup [ write-barriers-step ] each-basic-block ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 5df0114244..f1052da2d5 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -245,7 +245,7 @@ M: _gc generate-insn
         [ gc-root-count>> ]
     } cleave %gc ;
 
-M: ##loop-entry generate-insn drop %loop-entry ;
+M: _loop-entry generate-insn drop %loop-entry ;
 
 M: ##alien-global generate-insn
     [ dst>> register ] [ symbol>> ] [ library>> ] tri
diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor
index 9f573019c2..c93e20294e 100644
--- a/basis/compiler/tests/codegen.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -286,7 +286,7 @@ M: cucumber equal? "The cucumber has no equal" throw ;
 [ 4294967295 B{ 255 255 255 255 } -1 ]
 [
     -1 <int> -1 <int>
-    [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
+    [ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
     compile-call
 ] unit-test
 
@@ -321,4 +321,16 @@ cell 4 = [
 ] when
 
 ! Regression from Slava's value numbering changes
-[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
\ No newline at end of file
+[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
+
+! Bug with ##return node construction
+: return-recursive-bug ( nodes -- ? )
+    { fixnum } declare [
+        dup 3 bitand 1 = [ drop t ] [
+            dup 3 bitand 2 = [
+                return-recursive-bug
+            ] [ drop f ] if
+        ] if
+    ] any? ; inline recursive
+
+[ t ] [ 3 [ return-recursive-bug ] compile-call ] unit-test
\ No newline at end of file
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index 6ffc4d8112..5129515980 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -1,11 +1,11 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.mixin classes.parser
-classes.tuple classes.tuple.parser combinators effects
-effects.parser fry generic generic.parser generic.standard
-interpolate io.streams.string kernel lexer locals.parser
-locals.rewrite.closures locals.types make namespaces parser
-quotations sequences vocabs.parser words words.symbol ;
+USING: accessors arrays classes.mixin classes.parser classes.singleton
+classes.tuple classes.tuple.parser combinators effects effects.parser
+fry generic generic.parser generic.standard interpolate
+io.streams.string kernel lexer locals.parser locals.rewrite.closures
+locals.types make namespaces parser quotations sequences vocabs.parser
+words words.symbol ;
 IN: functors
 
 ! This is a hack
@@ -71,6 +71,14 @@ SYNTAX: `TUPLE:
     } case
     \ define-tuple-class parsed ;
 
+SYNTAX: `SINGLETON:
+    scan-param parsed
+    \ define-singleton-class parsed ;
+
+SYNTAX: `MIXIN:
+    scan-param parsed
+    \ define-mixin-class parsed ;
+
 SYNTAX: `M:
     scan-param parsed
     scan-param parsed
@@ -134,6 +142,8 @@ DEFER: ;FUNCTOR delimiter
 : functor-words ( -- assoc )
     H{
         { "TUPLE:" POSTPONE: `TUPLE: }
+        { "SINGLETON:" POSTPONE: `SINGLETON: }
+        { "MIXIN:" POSTPONE: `MIXIN: }
         { "M:" POSTPONE: `M: }
         { "C:" POSTPONE: `C: }
         { ":" POSTPONE: `: }
diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor
index cea944a6e8..bed065a800 100755
--- a/basis/math/bitwise/bitwise.factor
+++ b/basis/math/bitwise/bitwise.factor
@@ -1,8 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math sequences accessors
-math.bits sequences.private words namespaces macros
-hints combinators fry io.binary combinators.smart ;
+USING: arrays assocs combinators combinators.smart fry kernel
+macros math math.bits sequences sequences.private words ;
 IN: math.bitwise
 
 ! utilities
@@ -104,14 +103,6 @@ PRIVATE>
 : bit-count ( x -- n )
     dup 0 < [ bitnot ] when (bit-count) ; inline
 
-! Signed byte array to integer conversion
-: signed-le> ( bytes -- x )
-    [ le> ] [ length 8 * 1 - on-bits ] bi
-    2dup > [ bitnot bitor ] [ drop ] if ;
-
-: signed-be> ( bytes -- x )
-    <reversed> signed-le> ;
-
 : >signed ( x n -- y )
     2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 
diff --git a/basis/opengl/capabilities/capabilities-docs.factor b/basis/opengl/capabilities/capabilities-docs.factor
index f5424e19da..959b222671 100644
--- a/basis/opengl/capabilities/capabilities-docs.factor
+++ b/basis/opengl/capabilities/capabilities-docs.factor
@@ -40,7 +40,13 @@ HELP: gl-extensions
 
 HELP: has-gl-extensions?
 { $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
-{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
+{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." }
+{ $examples "Testing for framebuffer object and pixel buffer support:"
+    { $code <" {
+    { "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" }
+    "GL_ARB_pixel_buffer_object"
+} has-gl-extensions? "> }
+} ;
 
 HELP: has-gl-version-or-extensions?
 { $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } }
diff --git a/basis/opengl/capabilities/capabilities-tests.factor b/basis/opengl/capabilities/capabilities-tests.factor
new file mode 100644
index 0000000000..8bc8871482
--- /dev/null
+++ b/basis/opengl/capabilities/capabilities-tests.factor
@@ -0,0 +1,21 @@
+! (c)2009 Joe Groff bsd license
+USING: opengl.capabilities tools.test ;
+IN: opengl.capabilities.tests
+
+CONSTANT: test-extensions
+    {
+        "GL_ARB_vent_core_frogblast"
+        "GL_EXT_resonance_cascade"
+        "GL_EXT_slipgate"
+    }
+
+[ t ]
+[ "GL_ARB_vent_core_frogblast" test-extensions (has-extension?) ] unit-test
+
+[ f ]
+[ "GL_ARB_wallhack" test-extensions (has-extension?) ] unit-test
+
+[ t ] [
+    { "GL_EXT_dimensional_portal" "GL_EXT_slipgate" }
+    test-extensions (has-extension?)
+] unit-test
diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor
index ad04ce7fa5..37bfabc19b 100755
--- a/basis/opengl/capabilities/capabilities.factor
+++ b/basis/opengl/capabilities/capabilities.factor
@@ -1,16 +1,19 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces make sequences splitting opengl.gl
-continuations math.parser math arrays sets math.order fry ;
+continuations math.parser math arrays sets strings math.order fry ;
 IN: opengl.capabilities
 
 : (require-gl) ( thing require-quot make-error-quot -- )
     [ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline
 
+: (has-extension?) ( query-extension(s) available-extensions -- ? )
+    over string?  [ member? ] [ [ member? ] curry any? ] if ;
+
 : gl-extensions ( -- seq )
     GL_EXTENSIONS glGetString " " split ;
 : has-gl-extensions? ( extensions -- ? )
-    gl-extensions swap [ over member? ] all? nip ;
+    gl-extensions [ (has-extension?) ] curry all? ;
 : (make-gl-extensions-error) ( required-extensions -- )
     gl-extensions diff
     "Required OpenGL extensions not supported:\n" %
diff --git a/basis/unix/types/freebsd/freebsd.factor b/basis/unix/types/freebsd/freebsd.factor
index e012ebcbd6..215e344231 100644
--- a/basis/unix/types/freebsd/freebsd.factor
+++ b/basis/unix/types/freebsd/freebsd.factor
@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 
 IN: unix.types
 
@@ -22,3 +22,5 @@ TYPEDEF: __uint32_t     fflags_t
 TYPEDEF: long           ssize_t
 TYPEDEF: int            pid_t
 TYPEDEF: int            time_t
+
+ALIAS: <time_t> <int>
diff --git a/basis/unix/types/linux/linux.factor b/basis/unix/types/linux/linux.factor
index b0340c1778..a3dddfc93e 100644
--- a/basis/unix/types/linux/linux.factor
+++ b/basis/unix/types/linux/linux.factor
@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 IN: unix.types
 
 TYPEDEF: ulonglong __uquad_type
@@ -31,3 +31,5 @@ TYPEDEF: ulonglong __fsblkcnt64_t
 TYPEDEF: ulonglong __fsfilcnt64_t
 TYPEDEF: ulonglong ino64_t
 TYPEDEF: ulonglong off64_t
+
+ALIAS: <time_t> <long>
\ No newline at end of file
diff --git a/basis/unix/types/macosx/macosx.factor b/basis/unix/types/macosx/macosx.factor
index ac62776ed7..421efa60bc 100644
--- a/basis/unix/types/macosx/macosx.factor
+++ b/basis/unix/types/macosx/macosx.factor
@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 IN: unix.types
 
 ! Darwin 9.1.0
@@ -21,3 +21,5 @@ TYPEDEF: __int32_t  blksize_t
 TYPEDEF: long       ssize_t
 TYPEDEF: __int32_t  pid_t
 TYPEDEF: long       time_t
+
+ALIAS: <time_t> <long>
\ No newline at end of file
diff --git a/basis/unix/types/netbsd/netbsd.factor b/basis/unix/types/netbsd/netbsd.factor
index b5b0ffe661..7dacc97061 100644
--- a/basis/unix/types/netbsd/netbsd.factor
+++ b/basis/unix/types/netbsd/netbsd.factor
@@ -1,4 +1,4 @@
-USING: alien.syntax combinators layouts vocabs.loader ;
+USING: alien.syntax alien.c-types combinators layouts vocabs.loader ;
 IN: unix.types
 
 ! NetBSD 4.0
@@ -17,6 +17,8 @@ TYPEDEF: long           ssize_t
 TYPEDEF: int            pid_t
 TYPEDEF: int            time_t
 
+ALIAS: <time_t> <int>
+
 cell-bits {
     { 32 [ "unix.types.netbsd.32" require ] }
     { 64 [ "unix.types.netbsd.64" require ] }
diff --git a/basis/unix/types/openbsd/openbsd.factor b/basis/unix/types/openbsd/openbsd.factor
index 8938afa936..7c8fbd2b9d 100644
--- a/basis/unix/types/openbsd/openbsd.factor
+++ b/basis/unix/types/openbsd/openbsd.factor
@@ -1,4 +1,4 @@
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
 IN: unix.types
 
 ! OpenBSD 4.2
@@ -17,3 +17,5 @@ TYPEDEF: __uint32_t     fflags_t
 TYPEDEF: long           ssize_t
 TYPEDEF: int            pid_t
 TYPEDEF: int            time_t
+
+ALIAS: <time_t> <int>
\ No newline at end of file
diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor
index 65338dc88b..c8a4bfa0dc 100644
--- a/basis/x11/xlib/xlib.factor
+++ b/basis/x11/xlib/xlib.factor
@@ -477,7 +477,7 @@ C-STRUCT: XImage
     { "XImage-funcs" "f" } ;
 
 X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
-X-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
+X-FUNCTION: int XDestroyImage ( XImage* ximage ) ;
 
 : XImage-size ( ximage -- size )
     [ XImage-height ] [ XImage-bytes_per_line ] bi * ;
diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index 75607b0258..3c5ac31d23 100644
--- a/core/assocs/assocs-tests.factor
+++ b/core/assocs/assocs-tests.factor
@@ -134,3 +134,19 @@ unit-test
 [ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test
 [ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test
 [ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test
+
+[ H{ { 1 2 } { 2 3 } } ] [
+    {
+        H{ { 1 3 } }
+        H{ { 2 3 } }
+        H{ { 1 2 } }
+    } assoc-combine
+] unit-test
+
+[ H{ { 1 7 } } ] [
+    {
+        H{ { 1 2 } { 2 4 } { 5 6 } }
+        H{ { 1 3 } { 2 5 } }
+        H{ { 1 7 } { 5 6 } }
+    } assoc-refine
+] unit-test
\ No newline at end of file
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 62ab9f86ae..8b6809236c 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -129,6 +129,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
 : assoc-combine ( seq -- union )
     H{ } clone [ dupd update ] reduce ;
 
+: assoc-refine ( seq -- assoc )
+    [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
+
 : assoc-diff ( assoc1 assoc2 -- diff )
     [ nip key? not ] curry assoc-filter ;
 
diff --git a/core/io/binary/binary.factor b/core/io/binary/binary.factor
index d2e50c2a6a..cf2781aac0 100644
--- a/core/io/binary/binary.factor
+++ b/core/io/binary/binary.factor
@@ -24,3 +24,10 @@ IN: io.binary
 : h>b/b ( h -- b1 b2 )
     [ mask-byte ]
     [ -8 shift mask-byte ] bi ;
+
+: signed-le> ( bytes -- x )
+    [ le> ] [ length 8 * 1 - 2^ 1 - ] bi
+    2dup > [ bitnot bitor ] [ drop ] if ;
+
+: signed-be> ( bytes -- x )
+    <reversed> signed-le> ;
diff --git a/extra/alien/cxx/authors.txt b/extra/alien/cxx/authors.txt
new file mode 100644
index 0000000000..c45c6f3279
--- /dev/null
+++ b/extra/alien/cxx/authors.txt
@@ -0,0 +1 @@
+Jeremy Hughes
\ No newline at end of file
diff --git a/extra/alien/cxx/cxx.factor b/extra/alien/cxx/cxx.factor
new file mode 100644
index 0000000000..9d0ee24f50
--- /dev/null
+++ b/extra/alien/cxx/cxx.factor
@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.cxx.parser alien.marshall
+alien.inline.types classes.mixin classes.tuple kernel namespaces
+assocs sequences parser classes.parser alien.marshall.syntax
+interpolate locals effects io strings make vocabs.parser words
+generic fry quotations ;
+IN: alien.cxx
+
+<PRIVATE
+: class-mixin ( str -- word )
+    create-class-in [ define-mixin-class ] keep ;
+
+: class-tuple-word ( word -- word' )
+    "#" append create-in ;
+
+: define-class-tuple ( word mixin -- )
+    [ drop class-wrapper { } define-tuple-class ]
+    [ add-mixin-instance ] 2bi ;
+PRIVATE>
+
+: define-c++-class ( name superclass-mixin -- )
+    [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
+    add-mixin-instance define-class-tuple ;
+
+:: define-c++-method ( class-name generic name types effect virtual -- )
+    [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make           :> name'
+    effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
+    types class-name "*" append suffix                  :> types'
+    effect in>> "," join                                :> args
+    class-name virtual [ "#" append ] unless current-vocab lookup                  :> class
+    SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
+    name' types' effect' body define-c-marshalled
+    class generic create-method name' current-vocab lookup 1quotation define ;
diff --git a/extra/alien/cxx/parser/authors.txt b/extra/alien/cxx/parser/authors.txt
new file mode 100644
index 0000000000..c45c6f3279
--- /dev/null
+++ b/extra/alien/cxx/parser/authors.txt
@@ -0,0 +1 @@
+Jeremy Hughes
\ No newline at end of file
diff --git a/extra/alien/cxx/parser/parser.factor b/extra/alien/cxx/parser/parser.factor
new file mode 100644
index 0000000000..5afaab29e0
--- /dev/null
+++ b/extra/alien/cxx/parser/parser.factor
@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser lexer alien.inline ;
+IN: alien.cxx.parser
+
+: parse-c++-class-definition ( -- class superclass-mixin )
+    scan scan-word ;
+
+: parse-c++-method-definition ( -- class-name generic name types effect )
+    scan scan-word function-types-effect ;
diff --git a/extra/alien/cxx/syntax/authors.txt b/extra/alien/cxx/syntax/authors.txt
new file mode 100644
index 0000000000..c45c6f3279
--- /dev/null
+++ b/extra/alien/cxx/syntax/authors.txt
@@ -0,0 +1 @@
+Jeremy Hughes
\ No newline at end of file
diff --git a/extra/alien/cxx/syntax/syntax-tests.factor b/extra/alien/cxx/syntax/syntax-tests.factor
new file mode 100644
index 0000000000..24f685a197
--- /dev/null
+++ b/extra/alien/cxx/syntax/syntax-tests.factor
@@ -0,0 +1,113 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.cxx.syntax alien.inline.syntax
+alien.marshall.syntax alien.marshall accessors kernel ;
+IN: alien.cxx.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-TYPEDEF: std::string string
+
+C++-CLASS: std::string c++-root
+
+GENERIC: to-string ( obj -- str )
+
+C++-METHOD: std::string to-string const-char* c_str ( )
+
+CM-FUNCTION: std::string* new_string ( const-char* s )
+    return new std::string(s);
+;
+
+;C-LIBRARY
+
+ALIAS: <std::string> new_string
+
+{ 1 1 } [ new_string ] must-infer-as
+{ 1 1 } [ c_str_std__string ] must-infer-as
+[ t ] [ "abc" <std::string> std::string? ] unit-test
+[ "abc" ] [ "abc" <std::string> to-string ] unit-test
+
+
+DELETE-C-LIBRARY: inheritance
+C-LIBRARY: inheritance
+
+COMPILE-AS-C++
+
+C-INCLUDE: <cstring>
+
+RAW-C:
+class alpha {
+    public:
+    alpha(const char* s) {
+        str = s;
+    };
+    const char* render() {
+        return str;
+    };
+    virtual const char* chop() {
+        return str;
+    };
+    virtual int length() {
+        return strlen(str);
+    };
+    const char* str;
+};
+
+class beta : alpha {
+    public:
+    beta(const char* s) : alpha(s + 1) { };
+    const char* render() {
+        return str + 1;
+    };
+    virtual const char* chop() {
+        return str + 2;
+    };
+};
+;
+
+C++-CLASS: alpha c++-root
+C++-CLASS: beta alpha
+
+CM-FUNCTION: alpha* new_alpha ( const-char* s )
+    return new alpha(s);
+;
+
+CM-FUNCTION: beta* new_beta ( const-char* s )
+    return new beta(s);
+;
+
+ALIAS: <alpha> new_alpha
+ALIAS: <beta> new_beta
+
+GENERIC: render ( obj -- obj )
+GENERIC: chop ( obj -- obj )
+GENERIC: length ( obj -- n )
+
+C++-METHOD: alpha render const-char* render ( )
+C++-METHOD: beta render const-char* render ( )
+C++-VIRTUAL: alpha chop const-char* chop ( )
+C++-VIRTUAL: beta chop const-char* chop ( )
+C++-VIRTUAL: alpha length int length ( )
+
+;C-LIBRARY
+
+{ 1 1 } [ render_alpha ] must-infer-as
+{ 1 1 } [ chop_beta ] must-infer-as
+{ 1 1 } [ length_alpha ] must-infer-as
+[ t ] [ "x" <alpha> alpha#? ] unit-test
+[ t ] [ "x" <alpha> alpha? ] unit-test
+[ t ] [ "x" <beta> alpha? ] unit-test
+[ f ] [ "x" <beta> alpha#? ] unit-test
+[ 5 ] [ "hello" <alpha> length ] unit-test
+[ 4 ] [ "hello" <beta> length ] unit-test
+[ "hello" ] [ "hello" <alpha> render ] unit-test
+[ "llo" ] [ "hello" <beta> render ] unit-test
+[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
+[ "hello" ] [ "hello" <alpha> chop ] unit-test
+[ "lo" ] [ "hello" <beta> chop ] unit-test
+[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test
diff --git a/extra/alien/cxx/syntax/syntax.factor b/extra/alien/cxx/syntax/syntax.factor
new file mode 100644
index 0000000000..66c72c1c2b
--- /dev/null
+++ b/extra/alien/cxx/syntax/syntax.factor
@@ -0,0 +1,13 @@
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.cxx alien.cxx.parser ;
+IN: alien.cxx.syntax
+
+SYNTAX: C++-CLASS:
+    parse-c++-class-definition define-c++-class ;
+
+SYNTAX: C++-METHOD:
+    parse-c++-method-definition f define-c++-method ;
+
+SYNTAX: C++-VIRTUAL:
+    parse-c++-method-definition t define-c++-method ;
diff --git a/extra/alien/inline/types/types.factor b/extra/alien/inline/types/types.factor
index 94b98d1eb5..070febc324 100644
--- a/extra/alien/inline/types/types.factor
+++ b/extra/alien/inline/types/types.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types assocs combinators.short-circuit
 continuations effects fry kernel math memoize sequences
-splitting ;
+splitting strings peg.ebnf make ;
 IN: alien.inline.types
 
 : cify-type ( str -- str' )
@@ -21,6 +21,9 @@ IN: alien.inline.types
 : pointer-to-const? ( str -- ? )
     cify-type "const " head? ;
 
+: template-class? ( str -- ? )
+    [ CHAR: < = ] any? ;
+
 MEMO: resolved-primitives ( -- seq )
     primitive-types [ resolve-typedef ] map ;
 
@@ -57,3 +60,42 @@ MEMO: resolved-primitives ( -- seq )
         [ over pointer-to-primitive? [ ">" prepend ] when ]
         assoc-map unzip
     ] dip <effect> ;
+
+TUPLE: c++-type name params ptr ;
+C: <c++-type> c++-type
+
+EBNF: (parse-c++-type)
+dig  = [0-9]
+alpha = [a-zA-Z]
+alphanum = [1-9a-zA-Z]
+name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
+ptr = [*&] => [[ empty? not ]]
+
+param = "," " "* type " "* => [[ third ]]
+
+params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
+
+type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
+;EBNF
+
+: parse-c++-type ( str -- c++-type )
+    factorize-type (parse-c++-type) ;
+
+DEFER: c++-type>string
+
+: params>string ( params -- str )
+    [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
+
+: c++-type>string ( c++-type -- str )
+    [
+        [ name>> % ]
+        [ params>> [ params>string % ] when* ]
+        [ ptr>> [ "*" % ] when ]
+        tri
+    ] "" make ;
+
+GENERIC: c++-type ( obj -- c++-type/f )
+
+M: object c++-type drop f ;
+
+M: c++-type c-type ;
diff --git a/extra/alien/marshall/marshall-docs.factor b/extra/alien/marshall/marshall-docs.factor
index 6002b0c1c3..deac9fd186 100644
--- a/extra/alien/marshall/marshall-docs.factor
+++ b/extra/alien/marshall/marshall-docs.factor
@@ -327,7 +327,7 @@ HELP: out-arg-unmarshaller
     "for all types except pointers to non-const primitives."
 } ;
 
-HELP: pointer-unmarshaller
+HELP: class-unmarshaller
 { $values
     { "type" " a C type string" }
     { "quot" quotation }
diff --git a/extra/alien/marshall/marshall.factor b/extra/alien/marshall/marshall.factor
index 85b157e4a0..547e37f78a 100644
--- a/extra/alien/marshall/marshall.factor
+++ b/extra/alien/marshall/marshall.factor
@@ -11,7 +11,8 @@ specialized-arrays.long specialized-arrays.longlong
 specialized-arrays.short specialized-arrays.uchar
 specialized-arrays.uint specialized-arrays.ulong
 specialized-arrays.ulonglong specialized-arrays.ushort strings
-unix.utilities vocabs.parser words libc.private struct-arrays ;
+unix.utilities vocabs.parser words libc.private struct-arrays
+locals generalizations math ;
 IN: alien.marshall
 
 << primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
@@ -19,6 +20,9 @@ filter [ define-primitive-marshallers ] each >>
 
 TUPLE: alien-wrapper { underlying alien } ;
 TUPLE: struct-wrapper < alien-wrapper disposed ;
+TUPLE: class-wrapper < alien-wrapper disposed ;
+
+MIXIN: c++-root
 
 GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
 
@@ -27,6 +31,8 @@ M: struct-wrapper unmarshall-cast ;
 
 M: struct-wrapper dispose* underlying>> free ;
 
+M: class-wrapper c++-type class name>> parse-c++-type ;
+
 : marshall-pointer ( obj -- alien )
     {
         { [ dup alien? ] [ ] }
@@ -269,33 +275,43 @@ ALIAS: marshall-void* marshall-pointer
 : ?malloc-byte-array ( c-type -- alien )
     dup alien? [ malloc-byte-array ] unless ;
 
-: struct-unmarshaller ( type -- quot )
-    current-vocab lookup [
-        dup superclasses [ \ struct-wrapper = ] any? [
-            '[ ?malloc-byte-array _ new swap >>underlying ]
-        ] [ drop [ ] ] if
-    ] [ [ ] ] if* ;
+:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
+    type type-quot call current-vocab lookup [
+        dup superclasses superclass swap member?
+        [ def call ] [ drop clean call f ] if
+    ] [ clean call f ] if* ; inline
 
-: pointer-unmarshaller ( type -- quot )
-    type-sans-pointer current-vocab lookup [
-        dup superclasses [ \ alien-wrapper = ] any? [
-            '[ _ new swap >>underlying unmarshall-cast ]
-        ] [ drop [ ] ] if
-    ] [ [ ] ] if* ;
+: struct-unmarshaller ( type -- quot/f )
+    [ ] \ struct-wrapper
+    [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
+    [ ]
+    x-unmarshaller ;
+
+: class-unmarshaller ( type -- quot/f )
+    [ type-sans-pointer "#" append ] \ class-wrapper
+    [ '[ _ new swap >>underlying ] ]
+    [ ]
+    x-unmarshaller ;
+
+: non-primitive-unmarshaller ( type -- quot/f )
+    {
+        { [ dup pointer? ] [ class-unmarshaller ] }
+        [ struct-unmarshaller ]
+    } cond ;
 
 : unmarshaller ( type -- quot )
-    factorize-type dup primitive-unmarshaller [ nip ] [
-        dup pointer?
-        [ pointer-unmarshaller ]
-        [ struct-unmarshaller ] if
-    ] if* ;
+    factorize-type {
+        [ primitive-unmarshaller ]
+        [ non-primitive-unmarshaller ]
+        [ drop [ ] ]
+    } 1|| ;
 
 : struct-field-unmarshaller ( type -- quot )
-    factorize-type dup struct-primitive-unmarshaller [ nip ] [
-        dup pointer?
-        [ pointer-unmarshaller ]
-        [ struct-unmarshaller ] if
-    ] if* ;
+    factorize-type {
+        [ struct-primitive-unmarshaller ]
+        [ non-primitive-unmarshaller ]
+        [ drop [ ] ]
+    } 1|| ;
 
 : out-arg-unmarshaller ( type -- quot )
     dup pointer-to-non-const-primitive?
diff --git a/extra/combinators/tuple/tuple-docs.factor b/extra/combinators/tuple/tuple-docs.factor
new file mode 100644
index 0000000000..aedb013129
--- /dev/null
+++ b/extra/combinators/tuple/tuple-docs.factor
@@ -0,0 +1,43 @@
+! (c)2009 Joe Groff bsd license
+USING: assocs classes help.markup help.syntax kernel math
+quotations strings ;
+IN: combinators.tuple
+
+HELP: 2make-tuple
+{ $values
+    { "x" object } { "y" object } { "class" class } { "assoc" assoc }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } " and " { $snippet "y" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: 3make-tuple
+{ $values
+    { "x" object } { "y" object } { "z" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y z -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: make-tuple
+{ $values
+    { "x" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
+    { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: nmake-tuple
+{ $values
+    { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } { "n" integer }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on the top " { $snippet "n" } " values on the datastack below " { $snippet "class" } ", assigning the result of each call to the slot named by the corresponding key. The order in which the quotations is called is undefined." } ;
+
+{ make-tuple 2make-tuple 3make-tuple nmake-tuple } related-words
+
+ARTICLE: "combinators.tuple" "Tuple-constructing combinators"
+"The " { $vocab-link "combinators.tuple" } " vocabulary provides dataflow combinators that construct " { $link tuple } " objects."
+{ $subsection make-tuple }
+{ $subsection 2make-tuple }
+{ $subsection 3make-tuple }
+{ $subsection nmake-tuple }
+;
+
+ABOUT: "combinators.tuple"
diff --git a/extra/combinators/tuple/tuple.factor b/extra/combinators/tuple/tuple.factor
new file mode 100644
index 0000000000..c4e0ef40a1
--- /dev/null
+++ b/extra/combinators/tuple/tuple.factor
@@ -0,0 +1,29 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors assocs classes.tuple generalizations kernel
+locals quotations sequences ;
+IN: combinators.tuple
+
+<PRIVATE
+
+:: (tuple-slot-quot) ( slot assoc n -- quot )
+    slot name>> assoc at [
+        slot initial>> :> initial
+        { n ndrop initial } >quotation
+    ] unless* ;
+
+PRIVATE>
+
+MACRO:: nmake-tuple ( class assoc n -- )
+    class all-slots [ assoc n (tuple-slot-quot) ] map :> quots
+    class <wrapper> :> \class
+    { quots n ncleave \class boa } >quotation ;
+    
+: make-tuple ( x class assoc -- tuple )
+    1 nmake-tuple ; inline
+
+: 2make-tuple ( x y class assoc -- tuple )
+    2 nmake-tuple ; inline
+
+: 3make-tuple ( x y z class assoc -- tuple )
+    3 nmake-tuple ; inline
+
diff --git a/extra/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor
index 59ecb8ff77..1e098645bf 100644
--- a/extra/constructors/constructors-tests.factor
+++ b/extra/constructors/constructors-tests.factor
@@ -29,58 +29,15 @@ CONSTRUCTOR: ct1 ( a -- obj )
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct2 ( a b -- obj )
-    initialize-ct1
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct3 ( a b c -- obj )
-    initialize-ct1
     [ 1 + ] change-a ;
 
 CONSTRUCTOR: ct4 ( a b c d -- obj )
-    initialize-ct3
     [ 1 + ] change-a ;
 
 [ 1001 ] [ 1000 <ct1> a>> ] unit-test
 [ 2 ] [ 0 0 <ct2> a>> ] unit-test
-[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
-[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
-
-
-TUPLE: rofl a b c ;
-CONSTRUCTOR: rofl ( b c a  -- obj ) ;
-
-[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
-
-
-TUPLE: default { a integer initial: 0 } ;
-
-CONSTRUCTOR: default ( -- obj ) ;
-
-[ 0 ] [ <default> a>> ] unit-test
-
-
-TUPLE: inherit1 a ;
-TUPLE: inherit2 < inherit1 a ;
-
-CONSTRUCTOR: inherit2 ( a -- obj ) ;
-
-[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
-
-
-TUPLE: inherit3 hp max-hp ;
-TUPLE: inherit4 < inherit3 ;
-TUPLE: inherit5 < inherit3 ;
-
-CONSTRUCTOR: inherit3 ( -- obj )
-    dup max-hp>> >>hp ;
-
-BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
-    10 >>max-hp ;
-
-[ 10 ] [ <inherit4> hp>> ] unit-test
-
-FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
-    5 >>hp
-    10 >>max-hp ;
-
-[ 5 ] [ <inherit5> hp>> ] unit-test
+[ 3 ] [ 0 0 0 <ct3> a>> ] unit-test
+[ 4 ] [ 0 0 0 0 <ct4> a>> ] unit-test
diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor
index b8fe598f84..3cee399925 100644
--- a/extra/constructors/constructors.factor
+++ b/extra/constructors/constructors.factor
@@ -43,12 +43,7 @@ MACRO:: slots>constructor ( class slots -- quot )
     class def define-initializer
     class effect in>> '[ _ _ slots>constructor ] ;
 
-:: define-constructor ( constructor-word class effect def -- )
-    constructor-word class effect def (define-constructor)
-    class lookup-initializer
-    '[ @ _ execute( obj -- obj ) ] effect define-declared ;
-
-:: define-auto-constructor ( constructor-word class effect def reverse? -- )
+:: define-constructor ( constructor-word class effect def reverse? -- )
     constructor-word class effect def (define-constructor)
     class superclasses [ lookup-initializer ] map sift
     reverse? [ reverse ] when
@@ -60,9 +55,6 @@ MACRO:: slots>constructor ( class slots -- quot )
 : parse-constructor ( -- class word effect def )
     scan-constructor complete-effect parse-definition ;
 
-SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
-SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
-SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
-SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
+SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
 
 "initializers" create-vocab drop
diff --git a/extra/gpu/demos/bunny/bunny.factor b/extra/gpu/demos/bunny/bunny.factor
index ea15dc7884..f975b21245 100755
--- a/extra/gpu/demos/bunny/bunny.factor
+++ b/extra/gpu/demos/bunny/bunny.factor
@@ -1,3 +1,4 @@
+! (c)2009 Joe Groff bsd license
 USING: accessors alien.c-types arrays combinators combinators.short-circuit
 game-worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render
 gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images
@@ -52,22 +53,22 @@ VERTEX-FORMAT: bunny-vertex
 VERTEX-STRUCT: bunny-vertex-struct bunny-vertex
 
 UNIFORM-TUPLE: bunny-uniforms < mvp-uniforms
-    { "light_position" float-uniform 3 }
-    { "color"          float-uniform 4 }
-    { "ambient"        float-uniform 4 }
-    { "diffuse"        float-uniform 4 }
-    { "shininess"      float-uniform 1 } ;
+    { "light-position" vec3-uniform  f }
+    { "color"          vec4-uniform  f }
+    { "ambient"        vec4-uniform  f }
+    { "diffuse"        vec4-uniform  f }
+    { "shininess"      float-uniform f } ;
 
 UNIFORM-TUPLE: sobel-uniforms
-    { "texcoord_scale" float-uniform   2 }
-    { "color_texture"  texture-uniform 1 }
-    { "normal_texture" texture-uniform 1 }
-    { "depth_texture"  texture-uniform 1 }
-    { "line_color"     float-uniform   4 } ; 
+    { "texcoord-scale" vec2-uniform    f }
+    { "color-texture"  texture-uniform f }
+    { "normal-texture" texture-uniform f }
+    { "depth-texture"  texture-uniform f }
+    { "line-color"     vec4-uniform    f } ; 
 
 UNIFORM-TUPLE: loading-uniforms
-    { "texcoord_scale"  float-uniform   2 }
-    { "loading_texture" texture-uniform 1 } ;
+    { "texcoord-scale"  vec2-uniform    f }
+    { "loading-texture" texture-uniform f } ;
 
 : numbers ( str -- seq )
     " " split [ string>number ] map sift ;
@@ -229,16 +230,14 @@ BEFORE: bunny-world begin-world
             { depth-attachment 1.0 }
         } clear-framebuffer
     ] [
-        render-set new
-            triangles-mode >>primitive-mode
-            { T{ color-attachment f 0 } T{ color-attachment f 1 } } >>output-attachments
-            swap {
-                [ <bunny-uniforms> >>uniforms ]
-                [ bunny>> vertex-array>> >>vertex-array ]
-                [ bunny>> index-elements>> >>indexes ]
-                [ sobel>> framebuffer>> >>framebuffer ]
-            } cleave
-        render
+        {
+            { "primitive-mode"     [ drop triangles-mode ] }
+            { "output-attachments" [ drop { T{ color-attachment f 0 } T{ color-attachment f 1 } } ] }
+            { "uniforms"           [ <bunny-uniforms> ] }
+            { "vertex-array"       [ bunny>> vertex-array>> ] }
+            { "indexes"            [ bunny>> index-elements>> ] }
+            { "framebuffer"        [ sobel>> framebuffer>> ] }
+        } <render-set> render
     ] bi ;
 
 : <sobel-uniforms> ( sobel -- uniforms )
@@ -250,13 +249,12 @@ BEFORE: bunny-world begin-world
 : draw-sobel ( world -- )
     T{ depth-state { comparison f } } set-gpu-state*
 
-    render-set new
-        triangle-strip-mode >>primitive-mode
-        T{ index-range f 0 4 } >>indexes
-        swap sobel>>
-        [ <sobel-uniforms> >>uniforms ]
-        [ vertex-array>> >>vertex-array ] bi
-    render ;
+    sobel>> {
+        { "primitive-mode" [ drop triangle-strip-mode ] }
+        { "indexes"        [ drop T{ index-range f 0 4 } ] }
+        { "uniforms"       [ <sobel-uniforms> ] }
+        { "vertex-array"   [ vertex-array>> ] }
+    } <render-set> render ;
 
 : draw-sobeled-bunny ( world -- )
     [ draw-bunny ] [ draw-sobel ] bi ;
@@ -264,13 +262,12 @@ BEFORE: bunny-world begin-world
 : draw-loading ( world -- )
     T{ depth-state { comparison f } } set-gpu-state*
 
-    render-set new
-        triangle-strip-mode >>primitive-mode
-        T{ index-range f 0 4 } >>indexes
-        swap loading>>
-        [ { 1.0 -1.0 } swap texture>> loading-uniforms boa >>uniforms ]
-        [ vertex-array>> >>vertex-array ] bi
-    render ;
+    loading>> {
+        { "primitive-mode" [ drop triangle-strip-mode ] }
+        { "indexes"        [ drop T{ index-range f 0 4 } ] }
+        { "uniforms"       [ { 1.0 -1.0 } swap texture>> loading-uniforms boa ] }
+        { "vertex-array"   [ vertex-array>> ] }
+    } <render-set> render ;
 
 M: bunny-world draw-world*
     dup bunny>>
diff --git a/extra/gpu/demos/raytrace/raytrace.factor b/extra/gpu/demos/raytrace/raytrace.factor
index df323d3c82..339f192416 100644
--- a/extra/gpu/demos/raytrace/raytrace.factor
+++ b/extra/gpu/demos/raytrace/raytrace.factor
@@ -1,7 +1,7 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors arrays game-loop game-worlds generalizations
-gpu gpu.render gpu.shaders gpu.util gpu.util.wasd kernel
-literals math math.matrices math.order math.vectors
+USING: accessors arrays combinators.tuple game-loop game-worlds
+generalizations gpu gpu.render gpu.shaders gpu.util gpu.util.wasd
+kernel literals math math.matrices math.order math.vectors
 method-chains sequences ui ui.gadgets ui.gadgets.worlds
 ui.pixel-formats ;
 IN: gpu.demos.raytrace
@@ -11,31 +11,21 @@ GLSL-SHADER-FILE: raytrace-fragment-shader fragment-shader "raytrace.f.glsl"
 GLSL-PROGRAM: raytrace-program
     raytrace-vertex-shader raytrace-fragment-shader ;
 
+UNIFORM-TUPLE: sphere-uniforms
+    { "center" vec3-uniform  f }
+    { "radius" float-uniform f }
+    { "color"  vec4-uniform  f } ;
+
 UNIFORM-TUPLE: raytrace-uniforms
-    { "mv_inv_matrix" float-uniform { 4 4 } }
-    { "fov" float-uniform 2 }
-
-    { "spheres[0].center" float-uniform 3 }
-    { "spheres[0].radius" float-uniform 1 }
-    { "spheres[0].color"  float-uniform 4 }
-
-    { "spheres[1].center" float-uniform 3 }
-    { "spheres[1].radius" float-uniform 1 }
-    { "spheres[1].color"  float-uniform 4 }
-
-    { "spheres[2].center" float-uniform 3 }
-    { "spheres[2].radius" float-uniform 1 }
-    { "spheres[2].color"  float-uniform 4 }
-
-    { "spheres[3].center" float-uniform 3 }
-    { "spheres[3].radius" float-uniform 1 }
-    { "spheres[3].color"  float-uniform 4 }
+    { "mv-inv-matrix"    mat4-uniform f }
+    { "fov"              vec2-uniform f }
     
-    { "floor_height"   float-uniform 1 }
-    { "floor_color[0]" float-uniform 4 }
-    { "floor_color[1]" float-uniform 4 }
-    { "background_color" float-uniform 4 }
-    { "light_direction" float-uniform 3 } ;
+    { "spheres"          sphere-uniforms 4 }
+
+    { "floor-height"     float-uniform f }
+    { "floor-color"      vec4-uniform 2 }
+    { "background-color" vec4-uniform f }
+    { "light-direction"  vec3-uniform f } ;
 
 CONSTANT: reflection-color { 1.0 0.0 1.0 0.0 }
 
@@ -64,12 +54,10 @@ TUPLE: raytrace-world < wasd-world
     [ fov>> ]
     [
         spheres>>
-        [ [ sphere-center ] [ radius>> ] [ color>> ] tri 3array ] map
-        first4 [ first3 ] 4 napply
+        [ [ sphere-center ] [ radius>> ] [ color>> ] tri sphere-uniforms boa ] map
     ] tri
     -30.0 ! floor_height
-    { 1.0 0.0 0.0 1.0 } ! floor_color[0]
-    { 1.0 1.0 1.0 1.0 } ! floor_color[1]
+    { { 1.0 0.0 0.0 1.0 } { 1.0 1.0 1.0 1.0 } } ! floor_color
     { 0.15 0.15 1.0 1.0 } ! background_color
     { 0.0 -1.0 -0.1 } ! light_direction
     raytrace-uniforms boa ;
@@ -97,13 +85,12 @@ AFTER: raytrace-world tick*
     spheres>> [ tick-sphere ] each ;
 
 M: raytrace-world draw-world*
-    render-set new
-        triangle-strip-mode >>primitive-mode
-        T{ index-range f 0 4 } >>indexes
-        swap
-        [ <sphere-uniforms> >>uniforms ]
-        [ vertex-array>> >>vertex-array ] bi
-    render ;
+    {
+        { "primitive-mode" [ drop triangle-strip-mode    ] }
+        { "indexes"        [ drop T{ index-range f 0 4 } ] }
+        { "uniforms"       [ <sphere-uniforms>           ] }
+        { "vertex-array"   [ vertex-array>>              ] }
+    } <render-set> render ;
 
 M: raytrace-world pref-dim* drop { 1024 768 } ;
 M: raytrace-world tick-length drop 1000 30 /i ;
diff --git a/extra/gpu/render/render-docs.factor b/extra/gpu/render/render-docs.factor
index 68afc68f9b..f198558b06 100755
--- a/extra/gpu/render/render-docs.factor
+++ b/extra/gpu/render/render-docs.factor
@@ -47,7 +47,7 @@ HELP: UNIFORM-TUPLE:
     { "slot" uniform-type dimension }
     ...
     { "slot" uniform-type dimension } ; "> }
-{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " defines the vector or matrix dimensions; for example, a slot " { $snippet "{ \"foo\" float-uniform { 2 2 } }" } " will define a slot " { $snippet "foo" } " as a 2x2 matrix of floats."
+{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " specifies an array length if not " { $link f } "."
 $nl
 "Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:"
 { $list
@@ -55,8 +55,26 @@ $nl
 { { $link float-uniform } "s take their values from Factor " { $link float } "s." }
 { { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." }
 { { $link texture-uniform } "s take their values from " { $link texture } " objects." }
-{ "Vector uniforms are passed as Factor " { $link sequence } "s of the corresponding component type." }
-{ "Matrix uniforms are passed as row-major Factor " { $link sequence } "s of sequences of the corresponding component type." } }
+{ "Vector uniforms take their values from Factor " { $link sequence } "s of the corresponding component type."
+    { $list
+    { "Float vector types: " { $link vec2-uniform } ", " { $link vec3-uniform } ", " { $link vec4-uniform } }
+    { "Integer vector types: " { $link ivec2-uniform } ", " { $link ivec3-uniform } ", " { $link ivec4-uniform } }
+    { "Unsigned integer vector types: " { $link uvec2-uniform } ", " { $link uvec3-uniform } ", " { $link uvec4-uniform } }
+    { "Boolean vector types: " { $link bvec2-uniform } ", " { $link bvec3-uniform } ", " { $link bvec4-uniform } }
+    }
+}
+{ "Matrix uniforms take their values from row-major Factor " { $link sequence } "s of sequences of floats. Matrix types are:" 
+    { $list
+    { { $link mat2-uniform } ", " { $link mat2x3-uniform } ", " { $link mat2x4-uniform } }
+    { { $link mat3x2-uniform } ", " { $link mat3-uniform } ", " { $link mat3x4-uniform } }
+    { { $link mat4x2-uniform } ", " { $link mat4x3-uniform } ", " { $link mat4-uniform } }
+    }
+"Rectangular matrix type names are column x row."
+}
+{ "Uniform slots can also be defined as other " { $snippet "uniform-tuple" } " types to bind uniform structures. The uniform structure will take its value from the slots of a tuple of the given type." }
+{ "Array uniforms are passed as Factor sequences of the corresponding value type above." }
+}
+$nl
 "A value of a uniform tuple type is a standard Factor tuple. Uniform tuples are constructed with " { $link new } " or " { $link boa } ", and values are placed inside them using standard slot accessors."
 } ;
 
@@ -73,7 +91,7 @@ HELP: VERTEX-STRUCT:
 { $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
 
 HELP: bool-uniform
-{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "bool" } "s." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a boolean uniform parameter." } ;
 
 HELP: buffer>vertex-array
 { $values
@@ -84,6 +102,15 @@ HELP: buffer>vertex-array
 
 { vertex-array <vertex-array> buffer>vertex-array } related-words
 
+HELP: bvec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component boolean vector uniform parameter." } ;
+
+HELP: bvec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component boolean vector uniform parameter." } ;
+
+HELP: bvec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component boolean vector uniform parameter." } ;
+
 HELP: define-uniform-tuple
 { $values
     { "class" class } { "superclass" class } { "uniforms" sequence }
@@ -103,9 +130,7 @@ HELP: define-vertex-struct
 { $description "Defines a new struct C type from a " { $link vertex-format } ". The runtime equivalent of " { $link POSTPONE: VERTEX-STRUCT: } ". This word must be called inside a compilation unit." } ;
 
 HELP: float-uniform
-{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "float" } "s." } ;
-
-{ bool-uniform int-uniform float-uniform texture-uniform } related-words
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a float uniform parameter." } ;
 
 { index-elements index-range multi-index-elements multi-index-range } related-words
 
@@ -130,7 +155,7 @@ HELP: index-type
 { index-type ubyte-indexes ushort-indexes uint-indexes } related-words
 
 HELP: int-uniform
-{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "int" } "s." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a signed integer uniform parameter." } ;
 
 HELP: invalid-uniform-type
 { $values
@@ -138,6 +163,15 @@ HELP: invalid-uniform-type
 }
 { $description "Throws an error indicating that a slot of a " { $link uniform-tuple } " has been declared to have an invalid type." } ;
 
+HELP: ivec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component integer vector uniform parameter." } ;
+
+HELP: ivec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component integer vector uniform parameter." } ;
+
+HELP: ivec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component integer vector uniform parameter." } ;
+
 HELP: lines-mode
 { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a line from each pair of indexed vertex array elements." } ;
 
@@ -147,6 +181,33 @@ HELP: line-loop-mode
 HELP: line-strip-mode
 { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a connected strip of lines from each consecutive pair of indexed vertex array elements." } ;
 
+HELP: mat2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2x2 square float matrix uniform parameter." } ;
+
+HELP: mat2x3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 3-row float matrix uniform parameter." } ;
+
+HELP: mat2x4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 4-row float matrix uniform parameter." } ;
+
+HELP: mat3x2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 2-row float matrix uniform parameter." } ;
+
+HELP: mat3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3x3 square float matrix uniform parameter." } ;
+
+HELP: mat3x4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 4-row float matrix uniform parameter." } ;
+
+HELP: mat4x2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 2-row float matrix uniform parameter." } ;
+
+HELP: mat4x3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 3-row float matrix uniform parameter." } ;
+
+HELP: mat4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4x4 square float matrix uniform parameter." } ;
+
 HELP: multi-index-elements
 { $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a non-instanced " { $link render-set } " to instruct " { $link render } " to assemble primitives from the active " { $link vertex-array } " by using multiple arrays of indexes in CPU or GPU memory."
 { $list
@@ -200,7 +261,7 @@ HELP: render-set
 { render render-set } related-words
 
 HELP: texture-uniform
-{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a texture. The dimension of the corresponding " { $link uniform } " slot must be " { $snippet "1" } "." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a texture uniform parameter." } ;
 
 HELP: triangle-fan-mode
 { $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a fan of triangles using the first indexed vertex array element and every subsequent consecutive pair of elements." } ;
@@ -218,7 +279,7 @@ HELP: uint-indexes
 { $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of four-byte unsigned int indexes." } ;
 
 HELP: uint-uniform
-{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a scalar or vector of unsigned integers." } ;
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to an unsigned integer uniform parameter." } ;
 
 HELP: uniform
 { $class-description "Values of this tuple type are passed to " { $link define-uniform-tuple } " to define a new " { $link uniform-tuple } " type." } ;
@@ -229,13 +290,29 @@ HELP: uniform-tuple
 HELP: uniform-type
 { $class-description { $snippet "uniform-type" } " values are used as part of a " { $link POSTPONE: UNIFORM-TUPLE: } " definition to define the types of uniform slots." } ;
 
-{ uniform-type bool-uniform int-uniform float-uniform texture-uniform uint-uniform } related-words
-
 HELP: ushort-indexes
 { $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of two-byte unsigned short indexes." } ;
 
 { index-type ubyte-indexes ushort-indexes uint-indexes } related-words
 
+HELP: uvec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component unsigned integer vector uniform parameter." } ;
+
+HELP: uvec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component unsigned integer vector uniform parameter." } ;
+
+HELP: uvec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component unsigned integer vector uniform parameter." } ;
+
+HELP: vec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component float vector uniform parameter." } ;
+
+HELP: vec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component float vector uniform parameter." } ;
+
+HELP: vec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component float vector uniform parameter." } ;
+
 HELP: vertex-array
 { $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link <vertex-array> } " or " { $link buffer>vertex-array } " words." } ;
 
diff --git a/extra/gpu/render/render-tests.factor b/extra/gpu/render/render-tests.factor
new file mode 100644
index 0000000000..90a8dcc2cb
--- /dev/null
+++ b/extra/gpu/render/render-tests.factor
@@ -0,0 +1,117 @@
+USING: accessors combinators gpu.render gpu.render.private kernel sequences tools.test ;
+IN: gpu.render.tests
+
+UNIFORM-TUPLE: two-textures
+    { "argyle"       texture-uniform f }
+    { "thread-count" float-uniform   f }
+    { "tweed"        texture-uniform f } ;
+
+UNIFORM-TUPLE: inherited-textures < two-textures
+    { "paisley" texture-uniform f } ;
+
+UNIFORM-TUPLE: array-of-textures < two-textures
+    { "plaids" texture-uniform 4 } ;
+
+UNIFORM-TUPLE: struct-containing-texture
+    { "threads" two-textures f } ;
+
+UNIFORM-TUPLE: array-of-struct-containing-texture
+    { "threads" inherited-textures 3 } ;
+
+UNIFORM-TUPLE: array-of-struct-containing-array-of-texture
+    { "threads" array-of-textures 2 } ;
+
+[  1 ] [ texture-uniform uniform-type-texture-units ] unit-test
+[  0 ] [ float-uniform uniform-type-texture-units ] unit-test
+[  2 ] [ two-textures uniform-type-texture-units ] unit-test
+[  3 ] [ inherited-textures uniform-type-texture-units ] unit-test
+[  6 ] [ array-of-textures uniform-type-texture-units ] unit-test
+[  2 ] [ struct-containing-texture uniform-type-texture-units ] unit-test
+[  9 ] [ array-of-struct-containing-texture uniform-type-texture-units ] unit-test
+[ 12 ] [ array-of-struct-containing-array-of-texture uniform-type-texture-units ] unit-test
+
+[ { [ ] } ] [ texture-uniform f uniform-texture-accessors ] unit-test
+
+[ { } ] [ float-uniform f uniform-texture-accessors ] unit-test
+
+[ { [ argyle>> ] [ tweed>> ] } ] [ two-textures f uniform-texture-accessors ] unit-test
+
+[ { [ argyle>> ] [ tweed>> ] [ paisley>> ] } ]
+[ inherited-textures f uniform-texture-accessors ] unit-test
+
+[ {
+    [ argyle>> ]
+    [ tweed>> ]
+    [ plaids>> {
+        [ 0 swap nth ]
+        [ 1 swap nth ]
+        [ 2 swap nth ]
+        [ 3 swap nth ]
+    } ]
+} ] [ array-of-textures f uniform-texture-accessors ] unit-test
+
+[ {
+    [ threads>> {
+        [ argyle>> ]
+        [ tweed>> ]
+    } ]
+} ] [ struct-containing-texture f uniform-texture-accessors ] unit-test
+
+[ {
+    [ threads>> {
+        [ 0 swap nth {
+            [ argyle>> ]
+            [ tweed>> ]
+            [ paisley>> ]
+        } ]
+        [ 1 swap nth {
+            [ argyle>> ]
+            [ tweed>> ]
+            [ paisley>> ]
+        } ]
+        [ 2 swap nth {
+            [ argyle>> ]
+            [ tweed>> ]
+            [ paisley>> ]
+        } ]
+    } ]
+} ] [ array-of-struct-containing-texture f uniform-texture-accessors ] unit-test
+
+[ {
+    [ threads>> {
+        [ 0 swap nth {
+            [ argyle>> ]
+            [ tweed>> ]
+            [ plaids>> {
+                [ 0 swap nth ]
+                [ 1 swap nth ]
+                [ 2 swap nth ]
+                [ 3 swap nth ]
+            } ]
+        } ]
+        [ 1 swap nth {
+            [ argyle>> ]
+            [ tweed>> ]
+            [ plaids>> {
+                [ 0 swap nth ]
+                [ 1 swap nth ]
+                [ 2 swap nth ]
+                [ 3 swap nth ]
+            } ]
+        } ]
+    } ]
+} ] [ array-of-struct-containing-array-of-texture f uniform-texture-accessors ] unit-test
+
+[ [
+    nip {
+        [ argyle>> 0 (bind-texture-unit) ]
+        [ tweed>> 1 (bind-texture-unit) ]
+        [ plaids>> {
+            [ 0 swap nth 2 (bind-texture-unit) ]
+            [ 1 swap nth 3 (bind-texture-unit) ]
+            [ 2 swap nth 4 (bind-texture-unit) ]
+            [ 3 swap nth 5 (bind-texture-unit) ]
+        } cleave ]
+    } cleave
+] ] [ array-of-textures [bind-uniform-textures] ] unit-test
+
diff --git a/extra/gpu/render/render.factor b/extra/gpu/render/render.factor
index 65a99f94d7..51bd549b7a 100644
--- a/extra/gpu/render/render.factor
+++ b/extra/gpu/render/render.factor
@@ -1,19 +1,19 @@
 ! (c)2009 Joe Groff bsd license
 USING: accessors alien alien.c-types alien.structs arrays
-assocs classes.mixin classes.parser classes.singleton
-classes.tuple classes.tuple.private combinators destructors fry
+assocs classes classes.mixin classes.parser classes.singleton
+classes.tuple classes.tuple.private combinators combinators.tuple destructors fry
 generic generic.parser gpu gpu.buffers gpu.framebuffers
 gpu.framebuffers.private gpu.shaders gpu.state gpu.textures
 gpu.textures.private half-floats images kernel lexer locals
 math math.order math.parser namespaces opengl opengl.gl parser
 quotations sequences slots sorting specialized-arrays.alien
 specialized-arrays.float specialized-arrays.int
-specialized-arrays.uint strings ui.gadgets.worlds variants
+specialized-arrays.uint strings tr ui.gadgets.worlds variants
 vocabs.parser words ;
 IN: gpu.render
 
 UNION: ?string string POSTPONE: f ;
-UNION: uniform-dim integer sequence ;
+UNION: ?integer integer POSTPONE: f ;
 
 TUPLE: vertex-attribute
     { name            ?string        read-only initial: f }
@@ -23,15 +23,44 @@ TUPLE: vertex-attribute
 
 VARIANT: uniform-type
     bool-uniform
+    bvec2-uniform
+    bvec3-uniform
+    bvec4-uniform
     uint-uniform
+    uvec2-uniform
+    uvec3-uniform
+    uvec4-uniform
     int-uniform
+    ivec2-uniform
+    ivec3-uniform
+    ivec4-uniform
     float-uniform
+    vec2-uniform
+    vec3-uniform
+    vec4-uniform
+
+    mat2-uniform
+    mat2x3-uniform
+    mat2x4-uniform
+
+    mat3x2-uniform
+    mat3-uniform
+    mat3x4-uniform
+
+    mat4x2-uniform
+    mat4x3-uniform
+    mat4-uniform
+
     texture-uniform ;
 
+ALIAS: mat2x2-uniform mat2-uniform
+ALIAS: mat3x3-uniform mat3-uniform
+ALIAS: mat4x4-uniform mat4-uniform
+
 TUPLE: uniform
-    { name         string       read-only initial: "" }
-    { uniform-type uniform-type read-only initial: float-uniform }
-    { dim          uniform-dim  read-only initial: 4 } ;
+    { name         string   read-only initial: "" }
+    { uniform-type class    read-only initial: float-uniform }
+    { dim          ?integer read-only initial: f } ;
 
 VARIANT: index-type
     ubyte-indexes
@@ -50,8 +79,6 @@ TUPLE: multi-index-range
 
 C: <multi-index-range> multi-index-range
 
-UNION: ?integer integer POSTPONE: f ;
-
 TUPLE: index-elements
     { ptr gpu-data-ptr read-only }
     { count integer read-only }
@@ -180,8 +207,8 @@ M: multi-index-elements render-vertex-indexes
     bi*
     GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ;
 
-: (bind-texture-unit) ( texture-unit texture -- )
-    [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
+: (bind-texture-unit) ( texture texture-unit -- )
+    swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
 
 :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
     vertex-attribute name>>                 :> name
@@ -242,96 +269,204 @@ M: uniform-tuple bind-uniforms
     2drop ;
 
 : uniform-slot-type ( uniform -- type )
-    dup dim>> 1 = [
+    dup dim>> [ drop sequence ] [
         uniform-type>> {
             { bool-uniform    [ boolean ] }
             { uint-uniform    [ integer ] }
             { int-uniform     [ integer ] }
             { float-uniform   [ float   ] }
             { texture-uniform [ texture ] }
+            [ drop sequence ]
         } case
-    ] [ drop sequence ] if ;
+    ] if ;
 
 : uniform>slot ( uniform -- slot )
     [ name>> ] [ uniform-slot-type ] bi 2array ;
 
-:: [bind-uniform-texture] ( uniform index -- quot )
-    uniform name>> reader-word :> value>>-word
-    { index swap value>>-word (bind-texture-unit) } >quotation ;
+: uniform-type-texture-units ( uniform-type -- units )
+    dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ;
 
-:: [bind-uniform-textures] ( superclass uniforms -- quot )
-    superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
-    superclass \ bind-uniform-textures method :> next-method
-    uniforms
-        [ uniform-type>> texture-uniform = ] filter
-        [ first-texture-unit + [bind-uniform-texture] ] map-index
-        :> texture-uniforms-cleave
+: all-uniform-tuple-slots ( class -- slots )
+    dup "uniform-tuple-slots" word-prop 
+    [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ;
 
-    {
-        2dup next-method
-        nip texture-uniforms-cleave cleave
-    } >quotation ;
+DEFER: uniform-texture-accessors
 
-:: [bind-uniform] ( texture-unit uniform -- texture-unit' quot )
-    uniform name>> :> name
+: uniform-type-texture-accessors ( uniform-type -- accessors )
+    texture-uniform = [ { [ ] } ] [ { } ] if ;
+
+: uniform-slot-texture-accessor ( uniform -- accessor )
+    [ name>> reader-word ] [ [ uniform-type>> ] [ dim>> ] bi uniform-texture-accessors ] bi
+    dup length 1 = [ first swap prefix ] [ [ ] 2sequence ] if ;
+
+: uniform-tuple-texture-accessors ( uniform-type -- accessors )
+    all-uniform-tuple-slots [ uniform-type>> uniform-type-texture-units zero? not ] filter
+    [ uniform-slot-texture-accessor ] map ;
+
+: uniform-texture-accessors ( uniform-type dim -- accessors )
+    [
+        dup uniform-type?
+        [ uniform-type-texture-accessors ]
+        [ uniform-tuple-texture-accessors ] if
+    ] [
+        2dup swap empty? not and [
+            iota [
+                [ swap nth ] swap prefix
+                over length 1 = [ swap first append ] [ swap suffix ] if
+            ] with map
+        ] [ drop ] if
+    ] bi* ;
+
+: texture-accessor>cleave ( unit accessors -- unit' cleaves )
+    dup last sequence?
+    [ [ last [ texture-accessor>cleave ] map ] [ but-last ] bi swap suffix \ cleave suffix ]
+    [ over suffix \ (bind-texture-unit) suffix [ 1 + ] dip ] if ;
+
+: [bind-uniform-textures] ( class -- quot )
+    f uniform-texture-accessors
+    0 swap [ texture-accessor>cleave ] map nip
+    \ nip swap \ cleave [ ] 3sequence ;
+
+DEFER: [bind-uniform-tuple]
+
+:: [bind-uniform-array] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
     { name uniform-index } >quotation :> index-quot
-    uniform name>> reader-word 1quotation :> value>>-quot
     { index-quot value>>-quot bi* } >quotation :> pre-quot
 
-    uniform [ uniform-type>> ] [ dim>> ] bi 2array H{
-        { { bool-uniform  1 } [ >c-bool glUniform1i  ] }
-        { { int-uniform   1 } [ glUniform1i  ] }
-        { { uint-uniform  1 } [ glUniform1ui ] }
-        { { float-uniform 1 } [ glUniform1f  ] }
+    type H{
+        { bool-uniform  { dim swap [ >c-bool ] int-array{ } map-as glUniform1iv  } }
+        { int-uniform   { dim swap >int-array   glUniform1iv  } }
+        { uint-uniform  { dim swap >uint-array  glUniform1uiv } }
+        { float-uniform { dim swap >float-array glUniform1fv  } }
 
-        { { bool-uniform  2 } [ [ >c-bool ] map first2 glUniform2i  ] }
-        { { int-uniform   2 } [ first2 glUniform2i  ] }
-        { { uint-uniform  2 } [ first2 glUniform2ui ] }
-        { { float-uniform 2 } [ first2 glUniform2f  ] }
+        { bvec2-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform2iv  } }
+        { ivec2-uniform { dim swap int-array{ }   concat-as glUniform2i  } }
+        { uvec2-uniform { dim swap uint-array{ }  concat-as glUniform2ui } }
+        { vec2-uniform  { dim swap float-array{ } concat-as glUniform2f  } }
 
-        { { bool-uniform  3 } [ [ >c-bool ] map first3 glUniform3i  ] }
-        { { int-uniform   3 } [ first3 glUniform3i  ] }
-        { { uint-uniform  3 } [ first3 glUniform3ui ] }
-        { { float-uniform 3 } [ first3 glUniform3f  ] }
+        { bvec3-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform3iv  } }
+        { ivec3-uniform { dim swap int-array{ }   concat-as glUniform3i  } }
+        { uvec3-uniform { dim swap uint-array{ }  concat-as glUniform3ui } }
+        { vec3-uniform  { dim swap float-array{ } concat-as glUniform3f  } }
 
-        { { bool-uniform  4 } [ [ >c-bool ] map first4 glUniform4i  ] }
-        { { int-uniform   4 } [ first4 glUniform4i  ] }
-        { { uint-uniform  4 } [ first4 glUniform4ui ] }
-        { { float-uniform 4 } [ first4 glUniform4f  ] }
+        { bvec4-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform4iv  } }
+        { ivec4-uniform { dim swap int-array{ }   concat-as glUniform4iv  } }
+        { uvec4-uniform { dim swap uint-array{ }  concat-as glUniform4uiv } }
+        { vec4-uniform  { dim swap float-array{ } concat-as glUniform4fv  } }
 
-        { { float-uniform { 2 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2fv   ] }
-        { { float-uniform { 3 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x3fv ] }
-        { { float-uniform { 4 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x4fv ] }
+        { mat2-uniform   { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2fv   } }
+        { mat2x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x3fv } }
+        { mat2x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x4fv } }
+                                                                 
+        { mat3x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x2fv } }
+        { mat3-uniform   { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3fv   } }
+        { mat3x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x4fv } }
+                                                                  
+        { mat4x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x2fv } }
+        { mat4x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x3fv } }
+        { mat4-uniform   { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4fv   } }
 
-        { { float-uniform { 2 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x2fv ] }
-        { { float-uniform { 3 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3fv   ] }
-        { { float-uniform { 4 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x4fv ] }
-
-        { { float-uniform { 2 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x2fv ] }
-        { { float-uniform { 3 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x3fv ] }
-        { { float-uniform { 4 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4fv   ] }
-
-        { { texture-uniform 1 } { drop texture-unit glUniform1i } }
+        { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
     } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
 
-    uniform uniform-type>> texture-uniform =
-    [ texture-unit 1 + ] [ texture-unit ] if
+    type uniform-type-texture-units dim * texture-unit +
     pre-quot value-quot append ;
 
+:: [bind-uniform-value] ( value>>-quot type texture-unit name -- texture-unit' quot )
+    { name uniform-index } >quotation :> index-quot
+    { index-quot value>>-quot bi* } >quotation :> pre-quot
+
+    type H{
+        { bool-uniform  [ >c-bool glUniform1i  ] }
+        { int-uniform   [ glUniform1i  ] }
+        { uint-uniform  [ glUniform1ui ] }
+        { float-uniform [ glUniform1f  ] }
+
+        { bvec2-uniform [ [ >c-bool ] map first2 glUniform2i  ] }
+        { ivec2-uniform [ first2 glUniform2i  ] }
+        { uvec2-uniform [ first2 glUniform2ui ] }
+        { vec2-uniform  [ first2 glUniform2f  ] }
+
+        { bvec3-uniform [ [ >c-bool ] map first3 glUniform3i  ] }
+        { ivec3-uniform [ first3 glUniform3i  ] }
+        { uvec3-uniform [ first3 glUniform3ui ] }
+        { vec3-uniform  [ first3 glUniform3f  ] }
+
+        { bvec4-uniform [ [ >c-bool ] map first4 glUniform4i  ] }
+        { ivec4-uniform [ first4 glUniform4i  ] }
+        { uvec4-uniform [ first4 glUniform4ui ] }
+        { vec4-uniform  [ first4 glUniform4f  ] }
+
+        { mat2-uniform   [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2fv   ] }
+        { mat2x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x3fv ] }
+        { mat2x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x4fv ] }
+
+        { mat3x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x2fv ] }
+        { mat3-uniform   [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3fv   ] }
+        { mat3x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x4fv ] }
+
+        { mat4x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x2fv ] }
+        { mat4x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x3fv ] }
+        { mat4-uniform   [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4fv   ] }
+
+        { texture-uniform { drop texture-unit glUniform1i } }
+    } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
+
+    type uniform-type-texture-units texture-unit +
+    pre-quot value-quot append ;
+
+:: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
+    dim
+    [
+        iota
+        [ [ [ swap nth ] swap prefix ] map ]
+        [ [ number>string name "[" append "]." surround ] map ] bi
+    ] [
+        { [ ] }
+        name "." append 1array
+    ] if* :> name-prefixes :> quot-prefixes
+    type all-uniform-tuple-slots :> uniforms
+
+    texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
+        uniforms name-prefix [bind-uniform-tuple]
+        quot-prefix prepend
+    ] 2map :> value-cleave :> texture-unit'
+
+    texture-unit' 
+    value>>-quot { value-cleave 2cleave } append ;
+
+TR: hyphens>underscores "-" "_" ;
+
+:: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot )
+    prefix uniform name>> append hyphens>underscores :> name
+    uniform uniform-type>> :> type
+    uniform dim>> :> dim
+    uniform name>> reader-word 1quotation :> value>>-quot
+
+    value>>-quot type texture-unit name {
+        { [ type uniform-type? dim     and ] [ dim [bind-uniform-array] ] }
+        { [ type uniform-type? dim not and ] [ [bind-uniform-value] ] }
+        [ dim [bind-uniform-struct] ]
+    } cond ;
+
+:: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot )
+    texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit'
+
+    texture-unit'
+    { uniforms-cleave 2cleave } >quotation ;
+
 :: [bind-uniforms] ( superclass uniforms -- quot )
     superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
     superclass \ bind-uniforms method :> next-method
-    first-texture-unit uniforms [ [bind-uniform] ] map nip :> uniforms-cleave
-    
-    {
-        2dup next-method
-        uniforms-cleave 2cleave
-    } >quotation ;
+    first-texture-unit uniforms "" [bind-uniform-tuple] nip :> bind-quot
+
+    { 2dup next-method } bind-quot [ ] append-as ;
 
 : define-uniform-tuple-methods ( class superclass uniforms -- )
     [
-        [ \ bind-uniform-textures create-method-in ] 2dip
-        [bind-uniform-textures] define
+        2drop
+        [ \ bind-uniform-textures create-method-in ]
+        [ [bind-uniform-textures] ] bi define
     ] [
         [ \ bind-uniforms create-method-in ] 2dip
         [bind-uniforms] define
@@ -384,22 +519,21 @@ padding-no [ 0 ] initialize
 : (define-uniform-tuple) ( class superclass uniforms -- )
     {
         [ [ uniform>slot ] map define-tuple-class ]
-        [ define-uniform-tuple-methods ]
         [
-            [ "uniform-tuple-texture-units" word-prop 0 or ]
-            [ [ uniform-type>> texture-uniform = ] filter length ] bi* +
+            [ uniform-type-texture-units ]
+            [
+                [ [ uniform-type>> uniform-type-texture-units ] [ dim>> 1 or ] bi * ]
+                [ + ] map-reduce
+            ] bi* +
             "uniform-tuple-texture-units" set-word-prop
         ]
         [ nip "uniform-tuple-slots" set-word-prop ]
+        [ define-uniform-tuple-methods ]
     } 3cleave ;
 
 : true-subclasses ( class -- seq )
     [ subclasses ] keep [ = not ] curry filter ;
 
-: redefine-uniform-tuple-subclass-methods ( class -- )
-    [ true-subclasses ] keep
-    [ over "uniform-tuple-slots" word-prop (define-uniform-tuple) ] curry each ;
-
 PRIVATE>
 
 : define-vertex-format ( class vertex-attributes -- )
@@ -426,8 +560,7 @@ SYNTAX: VERTEX-STRUCT:
     scan scan-word define-vertex-struct ;
 
 : define-uniform-tuple ( class superclass uniforms -- )
-    [ (define-uniform-tuple) ]
-    [ 2drop redefine-uniform-tuple-subclass-methods ] 3bi ;
+    (define-uniform-tuple) ; inline
 
 SYNTAX: UNIFORM-TUPLE:
     parse-uniform-tuple-definition define-uniform-tuple ;
@@ -474,13 +607,22 @@ M: vertex-array dispose
 PRIVATE>
 
 TUPLE: render-set
-    { primitive-mode primitive-mode }
-    { vertex-array vertex-array }
-    { uniforms uniform-tuple }
-    { indexes vertex-indexes initial: T{ index-range } } 
-    { instances ?integer initial: f }
-    { framebuffer any-framebuffer initial: system-framebuffer }
-    { output-attachments sequence initial: { default-attachment } } ;
+    { primitive-mode primitive-mode read-only }
+    { vertex-array vertex-array read-only }
+    { uniforms uniform-tuple read-only }
+    { indexes vertex-indexes initial: T{ index-range } read-only } 
+    { instances ?integer initial: f read-only }
+    { framebuffer any-framebuffer initial: system-framebuffer read-only }
+    { output-attachments sequence initial: { default-attachment } read-only } ;
+
+: <render-set> ( x quot-assoc -- render-set )
+    render-set swap make-tuple ; inline
+
+: 2<render-set> ( x y quot-assoc -- render-set )
+    render-set swap 2make-tuple ; inline
+
+: 3<render-set> ( x y z quot-assoc -- render-set )
+    render-set swap 3make-tuple ; inline
 
 : render ( render-set -- )
     {
diff --git a/extra/gpu/util/wasd/wasd.factor b/extra/gpu/util/wasd/wasd.factor
index 34051730fb..b0a3d8179a 100644
--- a/extra/gpu/util/wasd/wasd.factor
+++ b/extra/gpu/util/wasd/wasd.factor
@@ -8,8 +8,8 @@ specialized-arrays.float ui ui.gadgets.worlds ;
 IN: gpu.util.wasd
 
 UNIFORM-TUPLE: mvp-uniforms
-    { "mv_matrix"  float-uniform   { 4 4 } }
-    { "p_matrix"   float-uniform   { 4 4 } } ;
+    { "mv_matrix"  mat4-uniform f }
+    { "p_matrix"   mat4-uniform f } ;
 
 CONSTANT: -pi/2 $[ pi -2.0 / ]
 CONSTANT:  pi/2 $[ pi  2.0 / ]