diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor
index cb6a753735..2aa0059542 100644
--- a/basis/bitstreams/bitstreams.factor
+++ b/basis/bitstreams/bitstreams.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.accessors assocs byte-arrays combinators
-constructors destructors fry io io.binary io.encodings.binary
-io.streams.byte-array kernel locals macros math math.ranges
-multiline sequences sequences.private vectors byte-vectors
-combinators.short-circuit math.bitwise ;
+destructors fry io io.binary io.encodings.binary io.streams.byte-array
+kernel locals macros math math.ranges multiline sequences
+sequences.private vectors byte-vectors combinators.short-circuit
+math.bitwise ;
 IN: bitstreams
 
 TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
@@ -36,8 +36,12 @@ TUPLE: bit-writer
 
 TUPLE: msb0-bit-reader < bit-reader ;
 TUPLE: lsb0-bit-reader < bit-reader ;
-CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
-CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
+
+: <msb0-bit-reader> ( bytes -- bs )
+    msb0-bit-reader new swap >>bytes ; inline
+
+: <lsb0-bit-reader> ( bytes -- bs )
+    lsb0-bit-reader new swap >>bytes ; inline
 
 TUPLE: msb0-bit-writer < bit-writer ;
 TUPLE: lsb0-bit-writer < bit-writer ;
@@ -56,13 +60,20 @@ TUPLE: lsb0-bit-writer < bit-writer ;
 GENERIC: peek ( n bitstream -- value )
 GENERIC: poke ( value n bitstream -- )
 
+: get-abp ( bitstream -- abp ) 
+    [ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline
+    
+: set-abp ( abp bitstream -- ) 
+    [ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline
+
 : seek ( n bitstream -- )
-    {
-        [ byte-pos>> 8 * ]
-        [ bit-pos>> + + 8 /mod ]
-        [ (>>bit-pos) ]
-        [ (>>byte-pos) ]
-    } cleave ; inline
+    [ get-abp + ] [ set-abp ] bi ; inline
+    
+: (align) ( n m -- n' )
+    [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
+    
+: align ( n bitstream -- )
+    [ get-abp swap (align) ] [ set-abp ] bi ; inline
 
 : read ( n bitstream -- value )
     [ peek ] [ seek ] 2bi ; inline
@@ -158,3 +169,9 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
         writer bytes>> swap push
     ] unless
     writer bytes>> ;
+
+:: byte-array-n>seq ( byte-array n -- seq )
+    byte-array length 8 * n / iota
+    byte-array <msb0-bit-reader> '[
+        drop n _ read
+    ] { } map-as ;
diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor
index 3a94e14640..b4a9d547f2 100644
--- a/basis/circular/circular-tests.factor
+++ b/basis/circular/circular-tests.factor
@@ -13,6 +13,7 @@ circular strings ;
  
 [ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
 [ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
+[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ rotate-circular ] keep [ ] like ] unit-test
 [ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
 [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
 [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor
index ae79e70d73..d47b954ecf 100644
--- a/basis/circular/circular.factor
+++ b/basis/circular/circular.factor
@@ -28,10 +28,10 @@ M: circular virtual-seq seq>> ;
     circular-wrap (>>start) ;
 
 : rotate-circular ( circular -- )
-    [ start>> 1 + ] keep circular-wrap (>>start) ;
+    [ 1 ] dip change-circular-start ;
 
 : push-circular ( elt circular -- )
-    [ set-first ] [ 1 swap change-circular-start ] bi ;
+    [ set-first ] [ rotate-circular ] bi ;
 
 : <circular-string> ( n -- circular )
     0 <string> <circular> ;
diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
index 81359690db..79165f2c96 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
@@ -1,56 +1 @@
-USING: compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.alias-analysis compiler.cfg.debugger
-cpu.architecture tools.test kernel ;
 IN: compiler.cfg.alias-analysis.tests
-
-[ ] [
-    {
-        T{ ##peek f V int-regs 2 D 1 f }
-        T{ ##box-alien f V int-regs 1 V int-regs 2 }
-        T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
-    } alias-analysis drop
-] unit-test
-
-[ ] [
-    {
-        T{ ##load-reference f V int-regs 1 "hello" }
-        T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
-    } alias-analysis drop
-] unit-test
-
-[
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 2 f }
-        T{ ##replace f V int-regs 1 D 0 f }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 2 f }
-        T{ ##replace f V int-regs 2 D 0 f }
-        T{ ##replace f V int-regs 1 D 0 f }
-    } alias-analysis
-] unit-test
-
-[
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 0 f }
-        T{ ##copy f V int-regs 3 V int-regs 2 f }
-        T{ ##copy f V int-regs 4 V int-regs 1 f }
-        T{ ##replace f V int-regs 3 D 0 f }
-        T{ ##replace f V int-regs 4 D 1 f }
-    }
-] [
-    {
-        T{ ##peek f V int-regs 1 D 1 f }
-        T{ ##peek f V int-regs 2 D 0 f }
-        T{ ##replace f V int-regs 1 D 0 f }
-        T{ ##replace f V int-regs 2 D 1 f }
-        T{ ##peek f V int-regs 3 D 1 f }
-        T{ ##peek f V int-regs 4 D 0 f }
-        T{ ##replace f V int-regs 3 D 0 f }
-        T{ ##replace f V int-regs 4 D 1 f }
-    } alias-analysis
-] unit-test
diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 2a9d2579e3..d0bb792f72 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -1,15 +1,13 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 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.copy-prop compiler.cfg.rpo
+compiler.cfg.liveness compiler.cfg.local ;
 IN: compiler.cfg.alias-analysis
 
-! Alias analysis -- assumes compiler.cfg.height has already run.
-!
-! We try to eliminate redundant slot and stack
-! traffic using some simple heuristics.
+! We try to eliminate redundant slot operations using some simple heuristics.
 ! 
 ! All heap-allocated objects which are loaded from the stack, or
 ! other object slots are pessimistically assumed to belong to
@@ -17,9 +15,6 @@ IN: compiler.cfg.alias-analysis
 !
 ! Freshly-allocated objects get their own alias class.
 !
-! The data and retain stack pointer registers are treated
-! uniformly, and each one gets its own alias class.
-! 
 ! Simple pseudo-C example showing load elimination:
 ! 
 ! int *x, *y, z: inputs
@@ -68,15 +63,14 @@ IN: compiler.cfg.alias-analysis
 ! Map vregs -> alias classes
 SYMBOL: vregs>acs
 
-: check ( obj -- obj )
-    [ "BUG: static type error detected" throw ] unless* ; inline
- 
+ERROR: vreg-ac-not-set vreg ;
+
 : vreg>ac ( vreg -- ac )
     #! Only vregs produced by ##allot, ##peek and ##slot can
     #! ever be used as valid inputs to ##slot and ##set-slot,
     #! so we assert this fact by not giving alias classes to
     #! other vregs.
-    vregs>acs get at check ;
+    vregs>acs get ?at [ vreg-ac-not-set ] unless ;
 
 ! Map alias classes -> sequence of vregs
 SYMBOL: acs>vregs
@@ -122,8 +116,10 @@ SYMBOL: histories
     #! value.
     over [ live-slots get at at ] [ 2drop f ] if ;
 
+ERROR: vreg-has-no-slots vreg ;
+
 : load-constant-slot ( value slot# vreg -- )
-    live-slots get at check set-at ;
+    live-slots get ?at [ vreg-has-no-slots ] unless set-at ;
 
 : load-slot ( value slot#/f vreg -- )
     over [ load-constant-slot ] [ 3drop ] if ;
@@ -189,67 +185,49 @@ SYMBOL: constants
 GENERIC: insn-slot# ( insn -- slot#/f )
 GENERIC: insn-object ( insn -- vreg )
 
-M: ##peek insn-slot# loc>> n>> ;
-M: ##replace insn-slot# loc>> n>> ;
 M: ##slot insn-slot# slot>> constant ;
 M: ##slot-imm insn-slot# slot>> ;
 M: ##set-slot insn-slot# slot>> constant ;
 M: ##set-slot-imm insn-slot# slot>> ;
 M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
 
-M: ##peek insn-object loc>> class ;
-M: ##replace insn-object loc>> class ;
 M: ##slot insn-object obj>> resolve ;
 M: ##slot-imm insn-object obj>> resolve ;
 M: ##set-slot insn-object obj>> resolve ;
 M: ##set-slot-imm insn-object obj>> resolve ;
 M: ##alien-global insn-object drop \ ##alien-global ;
 
-: init-alias-analysis ( -- )
+: init-alias-analysis ( live-in -- )
     H{ } clone histories set
     H{ } clone vregs>acs set
     H{ } clone acs>vregs set
     H{ } clone live-slots set
     H{ } clone constants set
     H{ } clone copies set
-
+    
     0 ac-counter set
     next-ac heap-ac set
 
-    ds-loc next-ac set-ac
-    rs-loc next-ac set-ac ;
+    [ set-heap-ac ] each ;
 
 GENERIC: analyze-aliases* ( insn -- insn' )
 
 M: ##load-immediate analyze-aliases*
     dup [ val>> ] [ dst>> ] bi constants get set-at ;
 
-M: ##load-reference analyze-aliases*
+M: ##flushable analyze-aliases*
     dup dst>> set-heap-ac ;
 
-M: ##alien-global analyze-aliases*
-    dup dst>> set-heap-ac ;
-
-M: ##allot analyze-aliases*
-    #! A freshly allocated object is distinct from any other
-    #! object.
-    dup dst>> set-new-ac ;
-
-M: ##box-float analyze-aliases*
-    #! A freshly allocated object is distinct from any other
-    #! object.
-    dup dst>> set-new-ac ;
-
-M: ##box-alien analyze-aliases*
+M: ##allocation analyze-aliases*
     #! A freshly allocated object is distinct from any other
     #! object.
     dup dst>> set-new-ac ;
 
 M: ##read analyze-aliases*
-    dup dst>> set-heap-ac
+    call-next-method
     dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
     2dup live-slot dup [
-        2nip f \ ##copy boa analyze-aliases* nip
+        2nip \ ##copy new-insn analyze-aliases* nip
     ] [
         drop remember-slot
     ] if ;
@@ -292,15 +270,6 @@ GENERIC: eliminate-dead-stores* ( insn -- insn' )
         ] unless
     ] when ;
 
-M: ##replace eliminate-dead-stores*
-    #! Writes to above the top of the stack can be pruned also.
-    #! This is sound since any such writes are not observable
-    #! after the basic block, and any reads of those locations
-    #! will have been converted to copies by analyze-slot,
-    #! and the final stack height of the basic block is set at
-    #! the beginning by compiler.cfg.stack.
-    dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ;
-
 M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
 
 M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
@@ -310,8 +279,10 @@ M: insn eliminate-dead-stores* ;
 : eliminate-dead-stores ( insns -- insns' )
     [ insn# set eliminate-dead-stores* ] map-index sift ;
 
-: alias-analysis ( insns -- insns' )
-    init-alias-analysis
+: alias-analysis-step ( insns -- insns' )
     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
diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
new file mode 100644
index 0000000000..e5be2d9eb9
--- /dev/null
+++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
@@ -0,0 +1,74 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces accessors math.order assocs kernel sequences
+combinators make classes words cpu.architecture
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.stack-frame ;
+IN: compiler.cfg.build-stack-frame
+
+SYMBOL: frame-required?
+
+SYMBOL: spill-counts
+
+GENERIC: compute-stack-frame* ( insn -- )
+
+: request-stack-frame ( stack-frame -- )
+    stack-frame [ max-stack-frame ] change ;
+
+M: ##stack-frame compute-stack-frame*
+    frame-required? on
+    stack-frame>> request-stack-frame ;
+
+M: ##call compute-stack-frame*
+    word>> sub-primitive>> [ frame-required? on ] unless ;
+
+M: _gc compute-stack-frame*
+    frame-required? on
+    stack-frame new swap gc-root-size>> >>gc-root-size
+    request-stack-frame ;
+
+M: _spill-counts compute-stack-frame*
+    counts>> stack-frame get (>>spill-counts) ;
+
+M: insn compute-stack-frame*
+    class frame-required? word-prop [
+        frame-required? on
+    ] when ;
+
+\ _spill t frame-required? set-word-prop
+\ ##fixnum-add t frame-required? set-word-prop
+\ ##fixnum-sub t frame-required? set-word-prop
+\ ##fixnum-mul t frame-required? set-word-prop
+\ ##fixnum-add-tail f frame-required? set-word-prop
+\ ##fixnum-sub-tail f frame-required? set-word-prop
+\ ##fixnum-mul-tail f frame-required? set-word-prop
+
+: compute-stack-frame ( insns -- )
+    frame-required? off
+    T{ stack-frame } clone stack-frame set
+    [ compute-stack-frame* ] each
+    stack-frame get dup stack-frame-size >>total-size drop ;
+
+GENERIC: insert-pro/epilogues* ( insn -- )
+
+M: ##stack-frame insert-pro/epilogues* drop ;
+
+M: ##prologue insert-pro/epilogues*
+    drop frame-required? get [ stack-frame get _prologue ] when ;
+
+M: ##epilogue insert-pro/epilogues*
+    drop frame-required? get [ stack-frame get _epilogue ] when ;
+
+M: insn insert-pro/epilogues* , ;
+
+: insert-pro/epilogues ( insns -- insns )
+    [ [ insert-pro/epilogues* ] each ] { } make ;
+
+: build-stack-frame ( mr -- mr )
+    [
+        [
+            [ compute-stack-frame ]
+            [ insert-pro/epilogues ]
+            bi
+        ] change-instructions
+    ] with-scope ;
diff --git a/basis/compiler/cfg/stack-frame/summary.txt b/basis/compiler/cfg/build-stack-frame/summary.txt
similarity index 100%
rename from basis/compiler/cfg/stack-frame/summary.txt
rename to basis/compiler/cfg/build-stack-frame/summary.txt
diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 4b521725fe..d323263fc7 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -15,6 +15,7 @@ compiler.cfg.iterator
 compiler.cfg.utilities
 compiler.cfg.registers
 compiler.cfg.intrinsics
+compiler.cfg.stack-frame
 compiler.cfg.instructions
 compiler.alien ;
 IN: compiler.cfg.builder
@@ -81,30 +82,35 @@ GENERIC: emit-node ( node -- next )
     basic-block get successors>> push
     stop-iterating ;
 
-: emit-call ( word -- next )
+: emit-call ( word height -- next )
     {
-        { [ dup loops get key? ] [ loops get at local-recursive-call ] }
+        { [ over loops get key? ] [ drop loops get at local-recursive-call ] }
+        { [ terminate-call? ] [ ##call stop-iterating ] }
         { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
-        { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
-        [ ##epilogue ##jump stop-iterating ]
+        { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
+        [ drop ##epilogue ##jump stop-iterating ]
     } cond ;
 
 ! #recursive
-: compile-recursive ( node -- next )
-    [ label>> id>> emit-call ]
+: recursive-height ( #recursive -- n )
+    [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
+
+: emit-recursive ( #recursive -- next )
+    [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
 
 : remember-loop ( label -- )
     basic-block get swap loops get set-at ;
 
-: compile-loop ( node -- next )
+: emit-loop ( node -- next )
     ##loop-entry
+    ##branch
     begin-basic-block
     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
     iterate-next ;
 
 M: #recursive emit-node
-    dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
+    dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
 
 ! #if
 : emit-branch ( obj -- final-bb )
@@ -154,65 +160,16 @@ M: #if emit-node
     } cond iterate-next ;
 
 ! #dispatch
-: trivial-dispatch-branch? ( nodes -- ? )
-    dup length 1 = [
-        first dup #call? [
-            word>> "intrinsic" word-prop not
-        ] [ drop f ] if
-    ] [ drop f ] if ;
-
-: dispatch-branch ( nodes word -- label )
-    over trivial-dispatch-branch? [
-        drop first word>>
-    ] [
-        gensym [
-            [
-                V{ } clone node-stack set
-                ##prologue
-                begin-basic-block
-                emit-nodes
-                basic-block get [
-                    ##epilogue
-                    ##return
-                    end-basic-block
-                ] when
-            ] with-cfg-builder
-        ] keep
-    ] if ;
-
-: dispatch-branches ( node -- )
-    children>> [
-        current-word get dispatch-branch
-        ##dispatch-label
-    ] each ;
-
-: emit-dispatch ( node -- )
-    ##epilogue
-    ds-pop ^^offset>slot i 0 ##dispatch
-    dispatch-branches ;
-
-: <dispatch-block> ( -- word )
-    gensym dup t "inlined-block" set-word-prop ;
-
 M: #dispatch emit-node
-    tail-call? [
-        emit-dispatch stop-iterating
-    ] [
-        current-word get <dispatch-block> [
-            [
-                begin-word
-                emit-dispatch
-            ] with-cfg-builder
-        ] keep emit-call
-    ] if ;
+    ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
 
 ! #call
 M: #call emit-node
     dup word>> dup "intrinsic" word-prop
-    [ emit-intrinsic ] [ nip emit-call ] if ;
+    [ emit-intrinsic ] [ swap call-height emit-call ] if ;
 
 ! #call-recursive
-M: #call-recursive emit-node label>> id>> emit-call ;
+M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
 
 ! #push
 M: #push emit-node
diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor
index 054b4f7ed0..dabc7338d2 100644
--- a/basis/compiler/cfg/cfg.factor
+++ b/basis/compiler/cfg/cfg.factor
@@ -1,27 +1,37 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays vectors accessors namespaces ;
+USING: kernel arrays vectors accessors
+namespaces math make fry sequences ;
 IN: compiler.cfg
 
 TUPLE: basic-block < identity-tuple
-id
+{ id integer }
 number
 { instructions vector }
 { successors vector }
 { predecessors vector } ;
 
-: <basic-block> ( -- basic-block )
+M: basic-block hashcode* nip id>> ;
+
+: <basic-block> ( -- bb )
     basic-block new
         V{ } clone >>instructions
         V{ } clone >>successors
         V{ } clone >>predecessors
         \ basic-block counter >>id ;
 
-TUPLE: cfg { entry basic-block } word label ;
+: add-instructions ( bb quot -- )
+    [ instructions>> building ] dip '[
+        building get pop
+        _ dip
+        building get push
+    ] with-variable ; inline
 
-C: <cfg> cfg
+TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
 
-TUPLE: mr { instructions array } word label spill-counts ;
+: <cfg> ( entry word label -- cfg ) f f cfg boa ;
+
+TUPLE: mr { instructions array } word label ;
 
 : <mr> ( instructions word label -- mr )
     mr new
diff --git a/basis/constructors/authors.txt b/basis/compiler/cfg/checker/authors.txt
similarity index 100%
rename from basis/constructors/authors.txt
rename to basis/compiler/cfg/checker/authors.txt
diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor
new file mode 100644
index 0000000000..4f215f1dc8
--- /dev/null
+++ b/basis/compiler/cfg/checker/checker.factor
@@ -0,0 +1,61 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness
+combinators.short-circuit accessors math sequences sets assocs ;
+IN: compiler.cfg.checker
+
+ERROR: last-insn-not-a-jump insn ;
+
+: check-last-instruction ( bb -- )
+    last dup {
+        [ ##branch? ]
+        [ ##dispatch? ]
+        [ ##conditional-branch? ]
+        [ ##compare-imm-branch? ]
+        [ ##return? ]
+        [ ##callback-return? ]
+        [ ##jump? ]
+        [ ##fixnum-add-tail? ]
+        [ ##fixnum-sub-tail? ]
+        [ ##fixnum-mul-tail? ]
+        [ ##call? ]
+    } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
+
+ERROR: bad-loop-entry ;
+
+: check-loop-entry ( bb -- )
+    dup length 2 >= [
+        2 head* [ ##loop-entry? ] any?
+        [ bad-loop-entry ] when
+    ] [ drop ] if ;
+
+ERROR: bad-successors ;
+
+: check-successors ( bb -- )
+    dup successors>> [ predecessors>> memq? ] with all?
+    [ bad-successors ] unless ;
+
+: check-basic-block ( bb -- )
+    [ instructions>> check-last-instruction ]
+    [ instructions>> check-loop-entry ]
+    [ check-successors ]
+    tri ;
+
+ERROR: bad-live-in ;
+
+ERROR: undefined-values uses defs ;
+
+: check-mr ( mr -- )
+    ! Check that every used register has a definition
+    instructions>>
+    [ [ uses-vregs ] map concat ]
+    [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
+    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 ;
diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor
index 52cc75f047..d526ea9c1d 100644
--- a/basis/compiler/cfg/copy-prop/copy-prop.factor
+++ b/basis/compiler/cfg/copy-prop/copy-prop.factor
@@ -6,7 +6,7 @@ IN: compiler.cfg.copy-prop
 SYMBOL: copies
 
 : resolve ( vreg -- vreg )
-    dup copies get at swap or ;
+    [ copies get at ] keep or ;
 
 : record-copy ( insn -- )
     [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
diff --git a/basis/compiler/cfg/dce/authors.txt b/basis/compiler/cfg/dce/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/dce/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor
new file mode 100644
index 0000000000..68c89be455
--- /dev/null
+++ b/basis/compiler/cfg/dce/dce.factor
@@ -0,0 +1,45 @@
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sets kernel namespaces sequences
+compiler.cfg.instructions compiler.cfg.def-use
+compiler.cfg.rpo ;
+IN: compiler.cfg.dce
+
+! Maps vregs to sequences of vregs
+SYMBOL: liveness-graph
+
+! vregs which participate in side effects and thus are always live
+SYMBOL: live-vregs
+
+: init-dead-code ( -- )
+    H{ } clone liveness-graph set
+    H{ } clone live-vregs set ;
+
+GENERIC: update-liveness-graph ( insn -- )
+
+M: ##flushable update-liveness-graph
+    [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
+
+: record-live ( vregs -- )
+    [
+        dup live-vregs get key? [ drop ] [
+            [ live-vregs get conjoin ]
+            [ liveness-graph get at record-live ]
+            bi
+        ] if
+    ] each ;
+
+M: insn update-liveness-graph uses-vregs record-live ;
+
+GENERIC: live-insn? ( insn -- ? )
+
+M: ##flushable live-insn? dst>> live-vregs get key? ;
+
+M: insn live-insn? drop t ;
+
+: eliminate-dead-code ( cfg -- cfg' )
+    init-dead-code
+    [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
+    [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
+    [ ]
+    tri ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/dead-code/dead-code-tests.factor b/basis/compiler/cfg/dead-code/dead-code-tests.factor
deleted file mode 100644
index ee7d8d2a43..0000000000
--- a/basis/compiler/cfg/dead-code/dead-code-tests.factor
+++ /dev/null
@@ -1,9 +0,0 @@
-USING: compiler.cfg.dead-code compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.debugger
-cpu.architecture tools.test ;
-IN: compiler.cfg.dead-code.tests
-
-[ { } ] [
-    { T{ ##load-immediate f V int-regs 134 16 } }
-    eliminate-dead-code
-] unit-test
diff --git a/basis/compiler/cfg/dead-code/dead-code.factor b/basis/compiler/cfg/dead-code/dead-code.factor
deleted file mode 100644
index 73aa7b4a5a..0000000000
--- a/basis/compiler/cfg/dead-code/dead-code.factor
+++ /dev/null
@@ -1,61 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs sets kernel namespaces sequences
-compiler.cfg.instructions compiler.cfg.def-use ;
-IN: compiler.cfg.dead-code
-
-! Dead code elimination -- assumes compiler.cfg.alias-analysis
-! has already run.
-
-! Maps vregs to sequences of vregs
-SYMBOL: liveness-graph
-
-! vregs which participate in side effects and thus are always live
-SYMBOL: live-vregs
-
-! mapping vregs to stack locations
-SYMBOL: vregs>locs
-
-: init-dead-code ( -- )
-    H{ } clone liveness-graph set
-    H{ } clone live-vregs set
-    H{ } clone vregs>locs set ;
-
-GENERIC: compute-liveness ( insn -- )
-
-M: ##flushable compute-liveness
-    [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
-
-M: ##peek compute-liveness
-    [ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ]
-    [ call-next-method ]
-    bi ;
-
-: live-replace? ( ##replace -- ? )
-    [ src>> vregs>locs get at ] [ loc>> ] bi = not ;
-
-M: ##replace compute-liveness
-    dup live-replace? [ call-next-method ] [ drop ] if ;
-
-: record-live ( vregs -- )
-    [
-        dup live-vregs get key? [ drop ] [
-            [ live-vregs get conjoin ]
-            [ liveness-graph get at record-live ]
-            bi
-        ] if
-    ] each ;
-
-M: insn compute-liveness uses-vregs record-live ;
-
-GENERIC: live-insn? ( insn -- ? )
-
-M: ##flushable live-insn? dst>> live-vregs get key? ;
-
-M: ##replace live-insn? live-replace? ;
-
-M: insn live-insn? drop t ;
-
-: eliminate-dead-code ( insns -- insns' )
-    init-dead-code
-    [ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ;
diff --git a/basis/compiler/cfg/dead-code/summary.txt b/basis/compiler/cfg/dead-code/summary.txt
deleted file mode 100644
index c66cd99606..0000000000
--- a/basis/compiler/cfg/dead-code/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Dead-code elimination
diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 6b0aba6813..cb56937758 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -7,7 +7,8 @@ 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.optimizer ;
+compiler.cfg.liveness compiler.cfg.optimizer
+compiler.cfg.mr ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -18,20 +19,14 @@ M: callable test-cfg
 M: word test-cfg
     [ build-tree optimize-tree ] keep build-cfg ;
 
-SYMBOL: allocate-registers?
-
 : test-mr ( quot -- mrs )
     test-cfg [
         optimize-cfg
         build-mr
-        convert-two-operand
-        allocate-registers? get
-        [ linear-scan build-stack-frame ] when
     ] map ;
 
 : insn. ( insn -- )
-    tuple>array allocate-registers? get [ but-last ] unless
-    [ pprint bl ] each nl ;
+    tuple>array [ pprint bl ] each nl ;
 
 : mr. ( mrs -- )
     [
diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor
index 068a6a6377..4ff9814e6d 100644
--- a/basis/compiler/cfg/def-use/def-use.factor
+++ b/basis/compiler/cfg/def-use/def-use.factor
@@ -1,28 +1,32 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel compiler.cfg.instructions ;
 IN: compiler.cfg.def-use
 
 GENERIC: defs-vregs ( insn -- seq )
+GENERIC: temp-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
-: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
 M: ##flushable defs-vregs dst>> 1array ;
-M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
-M: ##unary/temp defs-vregs dst/tmp-vregs ;
-M: ##allot defs-vregs dst/tmp-vregs ;
-M: ##dispatch defs-vregs temp>> 1array ;
-M: ##slot defs-vregs dst/tmp-vregs ;
-M: ##set-slot defs-vregs temp>> 1array ;
-M: ##string-nth defs-vregs dst/tmp-vregs ;
-M: ##set-string-nth-fast defs-vregs temp>> 1array ;
-M: ##compare defs-vregs dst/tmp-vregs ;
-M: ##compare-imm defs-vregs dst/tmp-vregs ;
-M: ##compare-float defs-vregs dst/tmp-vregs ;
-M: ##fixnum-mul defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: ##fixnum-mul-tail defs-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
 M: insn defs-vregs drop f ;
 
+M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
+M: ##unary/temp temp-vregs temp>> 1array ;
+M: ##allot temp-vregs temp>> 1array ;
+M: ##dispatch temp-vregs temp>> 1array ;
+M: ##slot temp-vregs temp>> 1array ;
+M: ##set-slot temp-vregs temp>> 1array ;
+M: ##string-nth temp-vregs temp>> 1array ;
+M: ##set-string-nth-fast temp-vregs temp>> 1array ;
+M: ##compare temp-vregs temp>> 1array ;
+M: ##compare-imm temp-vregs temp>> 1array ;
+M: ##compare-float temp-vregs temp>> 1array ;
+M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
+M: _dispatch temp-vregs temp>> 1array ;
+M: insn temp-vregs drop f ;
+
 M: ##unary uses-vregs src>> 1array ;
 M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: ##binary-imm uses-vregs src1>> 1array ;
@@ -39,10 +43,13 @@ M: ##dispatch uses-vregs src>> 1array ;
 M: ##alien-getter uses-vregs src>> 1array ;
 M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
 M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: ##phi uses-vregs inputs>> ;
 M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
+M: _dispatch uses-vregs src>> 1array ;
 M: insn uses-vregs drop f ;
 
+! Instructions that use vregs
 UNION: vreg-insn
 ##flushable
 ##write-barrier
@@ -51,5 +58,8 @@ UNION: vreg-insn
 ##fixnum-overflow
 ##conditional-branch
 ##compare-imm-branch
+##phi
+##gc
 _conditional-branch
-_compare-imm-branch ;
+_compare-imm-branch
+_dispatch ;
diff --git a/basis/compiler/cfg/dominance/authors.txt b/basis/compiler/cfg/dominance/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/dominance/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor
new file mode 100644
index 0000000000..750a46ee6c
--- /dev/null
+++ b/basis/compiler/cfg/dominance/dominance.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators compiler.cfg.rpo
+compiler.cfg.stack-analysis fry kernel math.order namespaces
+sequences ;
+IN: compiler.cfg.dominance
+
+! Reference:
+
+! A Simple, Fast Dominance Algorithm
+! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
+! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
+
+SYMBOL: idoms
+
+: idom ( bb -- bb' ) idoms get at ;
+
+<PRIVATE
+
+: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
+
+: intersect ( finger1 finger2 -- bb )
+    2dup [ number>> ] compare {
+        { +lt+ [ [ idom ] dip intersect ] }
+        { +gt+ [ idom intersect ] }
+        [ 2drop ]
+    } case ;
+
+: compute-idom ( bb -- idom )
+    predecessors>> [ idom ] map sift
+    [ ] [ intersect ] map-reduce ;
+
+: iterate ( rpo -- changed? )
+    [ [ compute-idom ] keep set-idom ] map [ ] any? ;
+
+PRIVATE>
+
+: compute-dominance ( cfg -- cfg )
+    H{ } clone idoms set
+    dup reverse-post-order
+    unclip dup set-idom drop '[ _ iterate ] loop ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/gc-checks/authors.txt b/basis/compiler/cfg/gc-checks/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/gc-checks/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/gc-checks/gc-checks.factor b/basis/compiler/cfg/gc-checks/gc-checks.factor
new file mode 100644
index 0000000000..4176914126
--- /dev/null
+++ b/basis/compiler/cfg/gc-checks/gc-checks.factor
@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences assocs
+cpu.architecture compiler.cfg.rpo
+compiler.cfg.liveness compiler.cfg.instructions
+compiler.cfg.hats ;
+IN: compiler.cfg.gc-checks
+
+: gc? ( bb -- ? )
+    instructions>> [ ##allocation? ] any? ;
+
+: object-pointer-regs ( basic-block -- vregs )
+    live-in keys [ reg-class>> int-regs eq? ] filter ;
+
+: insert-gc-check ( basic-block -- )
+    dup gc? [
+        [ i i f f \ ##gc new-insn prefix ] change-instructions drop
+    ] [ drop ] if ;
+
+: insert-gc-checks ( cfg -- cfg' )
+    dup [ insert-gc-check ] each-basic-block ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index 817c0f4680..b61f091fad 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -73,3 +73,5 @@ IN: compiler.cfg.hats
 : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
 : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
 : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
+
+: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
\ No newline at end of file
diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
index 9312f6f133..14a0a54715 100644
--- a/basis/compiler/cfg/height/height.factor
+++ b/basis/compiler/cfg/height/height.factor
@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math namespaces sequences kernel fry
-compiler.cfg compiler.cfg.registers compiler.cfg.instructions ;
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.liveness compiler.cfg.local ;
 IN: compiler.cfg.height
 
 ! Combine multiple stack height changes into one at the
@@ -42,10 +43,13 @@ M: ##replace normalize-height* normalize-peek/replace ;
 
 M: insn normalize-height* ;
 
-: normalize-height ( insns -- insns' )
+: height-step ( insns -- insns' )
     0 ds-height set
     0 rs-height set
     [ [ compute-heights ] each ]
     [ [ [ normalize-height* ] map sift ] with-scope ] bi
-    ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if
-    rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ;
+    ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
+    rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
+
+: normalize-height ( cfg -- cfg' )
+    [ drop ] [ height-step ] local-optimization ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index d152a8cc33..1bf94985a6 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors arrays kernel sequences namespaces words
 math math.order layouts classes.algebra alien byte-arrays
@@ -6,6 +6,8 @@ compiler.constants combinators compiler.cfg.registers
 compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.instructions
 
+: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline
+
 ! Virtual CPU instructions, used by CFG and machine IRs
 TUPLE: insn ;
 
@@ -44,26 +46,19 @@ M: fixnum ##load-literal tag-fixnum ##load-immediate ;
 M: f ##load-literal drop \ f tag-number ##load-immediate ;
 M: object ##load-literal ##load-reference ;
 
-INSN: ##peek < ##read { loc loc } ;
-INSN: ##replace < ##write { loc loc } ;
+INSN: ##peek < ##flushable { loc loc } ;
+INSN: ##replace < ##effect { loc loc } ;
 INSN: ##inc-d { n integer } ;
 INSN: ##inc-r { n integer } ;
 
 ! Subroutine calls
-TUPLE: stack-frame
-{ params integer }
-{ return integer }
-{ total-size integer }
-spill-counts ;
-
 INSN: ##stack-frame stack-frame ;
-INSN: ##call word ;
+INSN: ##call word { height integer } ;
 INSN: ##jump word ;
 INSN: ##return ;
 
 ! Jump tables
-INSN: ##dispatch src temp offset ;
-INSN: ##dispatch-label label ;
+INSN: ##dispatch src temp ;
 
 ! Slot access
 INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
@@ -160,9 +155,12 @@ INSN: ##set-alien-double < ##alien-setter ;
 
 ! Memory allocation
 INSN: ##allot < ##flushable size class { temp vreg } ;
+
+UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
+
 INSN: ##write-barrier < ##effect card# table ;
 
-INSN: ##alien-global < ##read symbol library ;
+INSN: ##alien-global < ##flushable symbol library ;
 
 ! FFI
 INSN: ##alien-invoke params ;
@@ -178,6 +176,8 @@ INSN: ##branch ;
 
 INSN: ##loop-entry ;
 
+INSN: ##phi < ##pure inputs ;
+
 ! Condition codes
 SYMBOL: cc<
 SYMBOL: cc<=
@@ -217,16 +217,19 @@ INSN: ##compare-imm < ##binary-imm cc temp ;
 INSN: ##compare-float-branch < ##conditional-branch ;
 INSN: ##compare-float < ##binary cc temp ;
 
+INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
+
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;
 INSN: _epilogue stack-frame ;
 
 INSN: _label id ;
 
-INSN: _gc ;
-
 INSN: _branch label ;
 
+INSN: _dispatch src temp ;
+INSN: _dispatch-label label ;
+
 TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
 
 INSN: _compare-branch < _conditional-branch ;
@@ -234,8 +237,13 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
 
 INSN: _compare-float-branch < _conditional-branch ;
 
+TUPLE: spill-slot n ; C: <spill-slot> spill-slot
+
+INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
+
 ! These instructions operate on machine registers and not
 ! virtual registers
 INSN: _spill src class n ;
 INSN: _reload dst class n ;
+INSN: _copy dst src class ;
 INSN: _spill-counts counts ;
diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor
index 876ac5596c..e8f8641e7d 100644
--- a/basis/compiler/cfg/instructions/syntax/syntax.factor
+++ b/basis/compiler/cfg/instructions/syntax/syntax.factor
@@ -11,12 +11,12 @@ IN: compiler.cfg.instructions.syntax
     "insn" "compiler.cfg.instructions" lookup ;
 
 : insn-effect ( word -- effect )
-    boa-effect in>> but-last f <effect> ;
+    boa-effect in>> 2 head* f <effect> ;
 
 SYNTAX: INSN:
-    parse-tuple-definition "regs" suffix
+    parse-tuple-definition { "regs" "insn#" } append
     [ dup tuple eq? [ drop insn-word ] when ] dip
     [ define-tuple-class ]
     [ 2drop save-location ]
-    [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
+    [ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ]
     3tri ;
diff --git a/basis/compiler/cfg/iterator/iterator.factor b/basis/compiler/cfg/iterator/iterator.factor
index a8958733a7..eb7f71ad60 100644
--- a/basis/compiler/cfg/iterator/iterator.factor
+++ b/basis/compiler/cfg/iterator/iterator.factor
@@ -37,9 +37,9 @@ DEFER: (tail-call?)
 : tail-call? ( -- ? )
     node-stack get [
         rest-slice
-        [ t ] [
-            [ (tail-call?) ]
-            [ first #terminate? not ]
-            bi and
-        ] if-empty
+        [ t ] [ (tail-call?) ] if-empty
     ] all? ;
+
+: terminate-call? ( -- ? )
+    node-stack get last
+    rest-slice [ f ] [ first #terminate? ] if-empty ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 908bf2475b..a99fea1d24 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -1,177 +1,41 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences math math.order kernel assocs
-accessors vectors fry heaps cpu.architecture combinators
-compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals ;
+USING: accessors assocs heaps kernel namespaces sequences
+compiler.cfg.linear-scan.allocation.coalescing
+compiler.cfg.linear-scan.allocation.spilling
+compiler.cfg.linear-scan.allocation.splitting
+compiler.cfg.linear-scan.allocation.state ;
 IN: compiler.cfg.linear-scan.allocation
 
-! Mapping from register classes to sequences of machine registers
-SYMBOL: free-registers
-
-: free-registers-for ( vreg -- seq )
-    reg-class>> free-registers get at ;
-
-: deallocate-register ( live-interval -- )
-    [ reg>> ] [ vreg>> ] bi free-registers-for push ;
-
-! Vector of active live intervals
-SYMBOL: active-intervals
-
-: active-intervals-for ( vreg -- seq )
-    reg-class>> active-intervals get at ;
-
-: add-active ( live-interval -- )
-    dup vreg>> active-intervals-for push ;
-
-: delete-active ( live-interval -- )
-    dup vreg>> active-intervals-for delq ;
-
-: expire-old-intervals ( n -- )
-    active-intervals swap '[
-        [
-            [ end>> _ < ] partition
-            [ [ deallocate-register ] each ] dip
-        ] assoc-map
-    ] change ;
-
-! Minheap of live intervals which still need a register allocation
-SYMBOL: unhandled-intervals
-
-! Start index of current live interval. We ensure that all
-! live intervals added to the unhandled set have a start index
-! strictly greater than ths one. This ensures that we can catch
-! infinite loop situations.
-SYMBOL: progress
-
-: check-progress ( live-interval -- )
-    start>> progress get <= [ "No progress" throw ] when ; inline
-
-: add-unhandled ( live-interval -- )
-    [ check-progress ]
-    [ dup start>> unhandled-intervals get heap-push ]
-    bi ;
-
-: init-unhandled ( live-intervals -- )
-    [ [ start>> ] keep ] { } map>assoc
-    unhandled-intervals get heap-push-all ;
-
-! Coalescing
-: active-interval ( vreg -- live-interval )
-    dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
-
-: coalesce? ( live-interval -- ? )
-    [ start>> ] [ copy-from>> active-interval ] bi
-    dup [ end>> = ] [ 2drop f ] if ;
-
-: coalesce ( live-interval -- )
-    dup copy-from>> active-interval
-    [ [ add-active ] [ delete-active ] bi* ]
-    [ reg>> >>reg drop ]
-    2bi ;
-
-! Splitting
-: find-use ( live-interval n quot -- i elt )
-    [ uses>> ] 2dip curry find ; inline
-
-: split-before ( live-interval i -- before )
-    [ clone dup uses>> ] dip
-    [ head >>uses ] [ 1- swap nth >>end ] 2bi ;
-
-: split-after ( live-interval i -- after )
-    [ clone dup uses>> ] dip
-    [ tail >>uses ] [ swap nth >>start ] 2bi
-    f >>reg f >>copy-from ;
-
-: split-interval ( live-interval n -- before after )
-    [ drop ] [ [ > ] find-use drop ] 2bi
-    [ split-before ] [ split-after ] 2bi ;
-
-: record-split ( live-interval before after -- )
-    [ >>split-before ] [ >>split-after ] bi* drop ;
-
-! Spilling
-SYMBOL: spill-counts
-
-: next-spill-location ( reg-class -- n )
-    spill-counts get [ dup 1+ ] change-at ;
-
-: interval-to-spill ( active-intervals current -- live-interval )
-    #! We spill the interval with the most distant use location.
-    start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
-    [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
-
-: assign-spill ( before after -- before after )
-    #! If it has been spilled already, reuse spill location.
-    over reload-from>>
-    [ over vreg>> reg-class>> next-spill-location ] unless*
-    [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
-
-: split-and-spill ( new existing -- before after )
-    dup rot start>> split-interval
-    [ record-split ] [ assign-spill ] 2bi ;
-
-: reuse-register ( new existing -- )
-    reg>> >>reg add-active ;
-
-: spill-existing ( new existing -- )
-    #! Our new interval will be used before the active interval
-    #! with the most distant use location. Spill the existing
-    #! interval, then process the new interval and the tail end
-    #! of the existing interval again.
-    [ reuse-register ]
-    [ nip delete-active ]
-    [ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
-
-: spill-new ( new existing -- )
-    #! Our new interval will be used after the active interval
-    #! with the most distant use location. Split the new
-    #! interval, then process both parts of the new interval
-    #! again.
-    [ dup split-and-spill add-unhandled ] dip spill-existing ;
-
-: spill-existing? ( new existing -- ? )
-    #! Test if 'new' will be used before 'existing'.
-    over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
-
-: assign-blocked-register ( new -- )
-    [ dup vreg>> active-intervals-for ] keep interval-to-spill
-    2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
-
-: assign-free-register ( new registers -- )
-    pop >>reg add-active ;
-
 : assign-register ( new -- )
-    dup coalesce? [
-        coalesce
-    ] [
-        dup vreg>> free-registers-for
-        [ assign-blocked-register ]
-        [ assign-free-register ]
+    dup coalesce? [ coalesce ] [
+        dup vreg>> free-registers-for [
+            dup intersecting-inactive
+            [ assign-blocked-register ]
+            [ assign-inactive-register ]
+            if-empty
+        ] [ assign-free-register ]
         if-empty
     ] if ;
 
-! Main loop
-: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
-
-: init-allocator ( registers -- )
-    <min-heap> unhandled-intervals set
-    [ reverse >vector ] assoc-map free-registers set
-    reg-classes [ 0 ] { } map>assoc spill-counts set
-    reg-classes [ V{ } clone ] { } map>assoc active-intervals set
-    -1 progress set ;
-
 : handle-interval ( live-interval -- )
-    [ start>> progress set ]
-    [ start>> expire-old-intervals ]
-    [ assign-register ]
-    tri ;
+    [
+        start>>
+        [ progress set ]
+        [ deactivate-intervals ]
+        [ activate-intervals ] tri
+    ] [ assign-register ] bi ;
 
 : (allocate-registers) ( -- )
     unhandled-intervals get [ handle-interval ] slurp-heap ;
 
+: finish-allocation ( -- )
+    active-intervals inactive-intervals
+    [ get values [ handled-intervals get push-all ] each ] bi@ ;
+
 : allocate-registers ( live-intervals machine-registers -- live-intervals )
-    #! This modifies the input live-intervals.
     init-allocator
-    dup init-unhandled
-    (allocate-registers) ;
+    init-unhandled
+    (allocate-registers)
+    finish-allocation
+    handled-intervals get ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
new file mode 100644
index 0000000000..99ed75dcbc
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences
+compiler.cfg.linear-scan.allocation.state ;
+IN: compiler.cfg.linear-scan.allocation.coalescing
+
+: active-interval ( vreg -- live-interval )
+    dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
+
+: coalesce? ( live-interval -- ? )
+    [ start>> ] [ copy-from>> active-interval ] bi
+    dup [ end>> = ] [ 2drop f ] if ;
+
+: coalesce ( live-interval -- )
+    dup copy-from>> active-interval
+    [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
+    [ reg>> >>reg drop ]
+    2bi ;
diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
new file mode 100644
index 0000000000..4981a223a4
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor
@@ -0,0 +1,60 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators fry hints kernel locals
+math sequences sets sorting splitting
+compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.allocation.splitting
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.allocation.spilling
+
+: split-for-spill ( live-interval n -- before after )
+    split-interval
+    [
+        [ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
+        [ [ ranges>> first ] [ uses>> first ] bi >>from drop ] bi*
+    ]
+    [ [ compute-start/end ] bi@ ]
+    [ ]
+    2tri ;
+
+: find-use ( live-interval n quot -- i elt )
+    [ uses>> ] 2dip curry find ; inline
+
+: interval-to-spill ( active-intervals current -- live-interval )
+    #! We spill the interval with the most distant use location.
+    start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
+    [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
+
+: assign-spill ( before after -- before after )
+    #! If it has been spilled already, reuse spill location.
+    over reload-from>>
+    [ over vreg>> reg-class>> next-spill-location ] unless*
+    [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
+
+: split-and-spill ( new existing -- before after )
+    swap start>> split-for-spill assign-spill ;
+
+: spill-existing ( new existing -- )
+    #! Our new interval will be used before the active interval
+    #! with the most distant use location. Spill the existing
+    #! interval, then process the new interval and the tail end
+    #! of the existing interval again.
+    [ reuse-register ]
+    [ nip delete-active ]
+    [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
+
+: spill-new ( new existing -- )
+    #! Our new interval will be used after the active interval
+    #! with the most distant use location. Split the new
+    #! interval, then process both parts of the new interval
+    #! again.
+    [ dup split-and-spill add-unhandled ] dip spill-existing ;
+
+: spill-existing? ( new existing -- ? )
+    #! Test if 'new' will be used before 'existing'.
+    over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
+
+: assign-blocked-register ( new -- )
+    [ dup vreg>> active-intervals-for ] keep interval-to-spill
+    2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
+
diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
new file mode 100644
index 0000000000..40ee4083e4
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor
@@ -0,0 +1,120 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators fry hints kernel locals
+math sequences sets sorting splitting
+compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.allocation.splitting
+
+: split-range ( live-range n -- before after )
+    [ [ from>> ] dip <live-range> ]
+    [ 1 + swap to>> <live-range> ]
+    2bi ;
+
+: split-last-range? ( last n -- ? )
+    swap to>> <= ;
+
+: split-last-range ( before after last n -- before' after' )
+    split-range [ [ but-last ] dip suffix ] [ prefix ] bi-curry* bi* ;
+
+: split-ranges ( live-ranges n -- before after )
+    [ '[ from>> _ <= ] partition ]
+    [
+        [ over last ] dip 2dup split-last-range?
+        [ split-last-range ] [ 2drop ] if
+    ] bi ;
+
+: split-uses ( uses n -- before after )
+    '[ _ <= ] partition ;
+
+: record-split ( live-interval before after -- )
+    [ >>split-next drop ]
+    [ [ >>split-before ] [ >>split-after ] bi* drop ]
+    2bi ; inline
+
+ERROR: splitting-too-early ;
+
+ERROR: splitting-atomic-interval ;
+
+: check-split ( live-interval n -- )
+    [ [ start>> ] dip > [ splitting-too-early ] when ]
+    [ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ]
+    2bi ; inline
+
+: split-before ( before -- before' )
+    f >>spill-to ; inline
+
+: split-after ( after -- after' )
+    f >>copy-from f >>reg f >>reload-from ; inline
+
+:: split-interval ( live-interval n -- before after )
+    live-interval n check-split
+    live-interval clone :> before
+    live-interval clone :> after
+    live-interval uses>> n split-uses before after [ (>>uses) ] bi-curry@ bi*
+    live-interval ranges>> n split-ranges before after [ (>>ranges) ] bi-curry@ bi*
+    live-interval before after record-split
+    before split-before
+    after split-after ;
+
+HINTS: split-interval live-interval object ;
+
+: reuse-register ( new existing -- )
+    reg>> >>reg add-active ;
+
+: relevant-ranges ( new inactive -- new' inactive' )
+    ! Slice off all ranges of 'inactive' that precede the start of 'new'
+    [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
+
+: intersect-live-range ( range1 range2 -- n/f )
+    2dup [ from>> ] bi@ > [ swap ] when
+    2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
+
+: intersect-live-ranges ( ranges1 ranges2 -- n )
+    {
+        { [ over empty? ] [ 2drop 1/0. ] }
+        { [ dup empty? ] [ 2drop 1/0. ] }
+        [
+            2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
+                drop
+                2dup [ first from>> ] bi@ <
+                [ [ rest-slice ] dip ] [ rest-slice ] if
+                intersect-live-ranges
+            ] if
+        ]
+    } cond ;
+
+: intersect-inactive ( new inactive active-regs -- n/f )
+    ! If the interval's register is currently in use, we cannot
+    ! re-use it.
+    2dup [ reg>> ] dip key?
+    [ 3drop f ] [ drop relevant-ranges intersect-live-ranges ] if ;
+
+: intersecting-inactive ( new -- live-intervals )
+    dup vreg>>
+    [ inactive-intervals-for ]
+    [ active-intervals-for [ reg>> ] map unique ] bi
+    '[ tuck _ intersect-inactive ] with { } map>assoc
+    [ nip ] assoc-filter ;
+
+: insert-use-for-copy ( seq n -- seq' )
+    [ 1array split1 ] keep [ 1 - ] keep 2array glue ;
+
+: split-before-use ( new n -- before after )
+    ! Find optimal split position
+    ! Insert move instruction
+    [ '[ _ insert-use-for-copy ] change-uses ] keep
+    1 - split-interval
+    2dup [ compute-start/end ] bi@ ;
+
+: assign-inactive-register ( new live-intervals -- )
+    ! If there is an interval which is inactive for the entire lifetime
+    ! if the new interval, reuse its vreg. Otherwise, split new so that
+    ! the first half fits.
+    sort-values last
+    2dup [ end>> ] [ second ] bi* < [
+        first reuse-register
+    ] [
+        [ second split-before-use ] keep
+        '[ _ first reuse-register ] [ add-unhandled ] bi*
+    ] if ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
new file mode 100644
index 0000000000..2a1e87dcdd
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor
@@ -0,0 +1,134 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators cpu.architecture fry heaps
+kernel math namespaces sequences vectors
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.allocation.state
+
+! Mapping from register classes to sequences of machine registers
+SYMBOL: free-registers
+
+: free-registers-for ( vreg -- seq )
+    reg-class>> free-registers get at ;
+
+: deallocate-register ( live-interval -- )
+    [ reg>> ] [ vreg>> ] bi free-registers-for push ;
+
+! Vector of active live intervals
+SYMBOL: active-intervals
+
+: active-intervals-for ( vreg -- seq )
+    reg-class>> active-intervals get at ;
+
+: add-active ( live-interval -- )
+    dup vreg>> active-intervals-for push ;
+
+: delete-active ( live-interval -- )
+    dup vreg>> active-intervals-for delq ;
+
+: assign-free-register ( new registers -- )
+    pop >>reg add-active ;
+
+! Vector of inactive live intervals
+SYMBOL: inactive-intervals
+
+: inactive-intervals-for ( vreg -- seq )
+    reg-class>> inactive-intervals get at ;
+
+: add-inactive ( live-interval -- )
+    dup vreg>> inactive-intervals-for push ;
+
+! Vector of handled live intervals
+SYMBOL: handled-intervals
+
+: add-handled ( live-interval -- )
+    handled-intervals get push ;
+
+: finished? ( n live-interval -- ? ) end>> swap < ;
+
+: finish ( n live-interval -- keep? )
+    nip [ deallocate-register ] [ add-handled ] bi f ;
+
+SYMBOL: check-allocation?
+
+ERROR: register-already-used live-interval ;
+
+: check-activate ( live-interval -- )
+    check-allocation? get [
+        dup [ reg>> ] [ vreg>> active-intervals-for [ reg>> ] map ] bi member?
+        [ register-already-used ] [ drop ] if
+    ] [ drop ] if ;
+
+: activate ( n live-interval -- keep? )
+    dup check-activate
+    nip add-active f ;
+
+: deactivate ( n live-interval -- keep? )
+    nip add-inactive f ;
+
+: don't-change ( n live-interval -- keep? ) 2drop t ;
+
+! Moving intervals between active and inactive sets
+: process-intervals ( n symbol quots -- )
+    ! symbol stores an alist mapping register classes to vectors
+    [ get values ] dip '[ [ _ cond ] with filter-here ] with each ; inline
+
+: deactivate-intervals ( n -- )
+    ! Any active intervals which have ended are moved to handled
+    ! Any active intervals which cover the current position
+    ! are moved to inactive
+    active-intervals {
+        { [ 2dup finished? ] [ finish ] }
+        { [ 2dup covers? not ] [ deactivate ] }
+        [ don't-change ]
+    } process-intervals ;
+
+: activate-intervals ( n -- )
+    ! Any inactive intervals which have ended are moved to handled
+    ! Any inactive intervals which do not cover the current position
+    ! are moved to active
+    inactive-intervals {
+        { [ 2dup finished? ] [ finish ] }
+        { [ 2dup covers? ] [ activate ] }
+        [ don't-change ]
+    } process-intervals ;
+
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
+
+! Start index of current live interval. We ensure that all
+! live intervals added to the unhandled set have a start index
+! strictly greater than ths one. This ensures that we can catch
+! infinite loop situations.
+SYMBOL: progress
+
+: check-progress ( live-interval -- )
+    start>> progress get <= [ "No progress" throw ] when ; inline
+
+: add-unhandled ( live-interval -- )
+    [ check-progress ]
+    [ dup start>> unhandled-intervals get heap-push ]
+    bi ;
+
+CONSTANT: reg-classes { int-regs double-float-regs }
+
+: reg-class-assoc ( quot -- assoc )
+    [ reg-classes ] dip { } map>assoc ; inline
+
+SYMBOL: spill-counts
+
+: next-spill-location ( reg-class -- n )
+    spill-counts get [ dup 1 + ] change-at ;
+
+: init-allocator ( registers -- )
+    [ reverse >vector ] assoc-map free-registers set
+    [ 0 ] reg-class-assoc spill-counts set
+    <min-heap> unhandled-intervals set
+    [ V{ } clone ] reg-class-assoc active-intervals set
+    [ V{ } clone ] reg-class-assoc inactive-intervals set
+    V{ } clone handled-intervals set
+    -1 progress set ;
+
+: init-unhandled ( live-intervals -- )
+    [ [ start>> ] keep ] { } map>assoc
+    unhandled-intervals get heap-push-all ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
deleted file mode 100644
index 13c1783711..0000000000
--- a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
+++ /dev/null
@@ -1,4 +0,0 @@
-USING: compiler.cfg.linear-scan.assignment tools.test ;
-IN: compiler.cfg.linear-scan.assignment.tests
-
-
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
index da45b45aaa..ea918a7424 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor
@@ -1,87 +1,144 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators
+fry make combinators sets
 cpu.architecture
 compiler.cfg.def-use
 compiler.cfg.registers
 compiler.cfg.instructions
+compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.live-intervals ;
 IN: compiler.cfg.linear-scan.assignment
 
-! A vector of live intervals. There is linear searching involved
-! but since we never have too many machine registers (around 30
-! at most) and we probably won't have that many live at any one
-! time anyway, it is not a problem to check each element.
-SYMBOL: active-intervals
+! This contains both active and inactive intervals; any interval
+! such that start <= insn# <= end is in this set.
+SYMBOL: pending-intervals
 
 : add-active ( live-interval -- )
-    active-intervals get push ;
-
-: lookup-register ( vreg -- reg )
-    active-intervals get [ vreg>> = ] with find nip reg>> ;
+    pending-intervals get push ;
 
 ! Minheap of live intervals which still need a register allocation
 SYMBOL: unhandled-intervals
 
 : add-unhandled ( live-interval -- )
-    dup split-before>> [
-        [ split-before>> ] [ split-after>> ] bi
-        [ add-unhandled ] bi@
-    ] [
-        dup start>> unhandled-intervals get heap-push
-    ] if ;
+    dup start>> unhandled-intervals get heap-push ;
 
 : init-unhandled ( live-intervals -- )
     [ add-unhandled ] each ;
 
+! Mapping spill slots to vregs
+SYMBOL: spill-slots
+
+: spill-slots-for ( vreg -- assoc )
+    reg-class>> spill-slots get at ;
+
+ERROR: already-spilled ;
+
+: record-spill ( live-interval -- )
+    [ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
+    2dup key? [ already-spilled ] [ set-at ] if ;
+
 : insert-spill ( live-interval -- )
-    [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri
-    dup [ _spill ] [ 3drop ] if ;
+    [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
+
+: handle-spill ( live-interval -- )
+    dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
+
+: insert-copy ( live-interval -- )
+    [ split-next>> reg>> ]
+    [ reg>> ]
+    [ vreg>> reg-class>> ]
+    tri _copy ;
+
+: handle-copy ( live-interval -- )
+    dup [ spill-to>> not ] [ split-next>> ] bi and
+    [ insert-copy ] [ drop ] if ;
 
 : expire-old-intervals ( n -- )
-    active-intervals get
-    swap '[ end>> _ = ] partition
-    active-intervals set
-    [ insert-spill ] each ;
+    [ pending-intervals get ] dip '[
+        dup end>> _ <
+        [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
+    ] filter-here ;
+
+ERROR: already-reloaded ;
+
+: record-reload ( live-interval -- )
+    [ reload-from>> ] [ vreg>> spill-slots-for ] bi
+    2dup key? [ delete-at ] [ already-reloaded ] if ;
 
 : insert-reload ( live-interval -- )
-    [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri
-    dup [ _reload ] [ 3drop ] if ;
+    [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
+
+: handle-reload ( live-interval -- )
+    dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ;
 
 : activate-new-intervals ( n -- )
     #! Any live intervals which start on the current instruction
     #! are added to the active set.
     unhandled-intervals get dup heap-empty? [ 2drop ] [
         2dup heap-peek drop start>> = [
-            heap-pop drop [ add-active ] [ insert-reload ] bi
+            heap-pop drop
+            [ add-active ] [ handle-reload ] bi
             activate-new-intervals
         ] [ 2drop ] if
     ] if ;
 
-GENERIC: (assign-registers) ( insn -- )
+GENERIC: assign-registers-in-insn ( insn -- )
 
-M: vreg-insn (assign-registers)
-    dup
-    [ defs-vregs ] [ uses-vregs ] bi append
-    active-intervals get swap '[ vreg>> _ member? ] filter
-    [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
+: register-mapping ( live-intervals -- alist )
+    [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
+
+: all-vregs ( insn -- vregs )
+    [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
+
+: active-intervals ( insn -- intervals )
+    insn#>> pending-intervals get [ covers? ] with filter ;
+
+M: vreg-insn assign-registers-in-insn
+    dup [ active-intervals ] [ all-vregs ] bi
+    '[ vreg>> _ member? ] filter
+    register-mapping
     >>regs drop ;
 
-M: insn (assign-registers) drop ;
+: compute-live-registers ( insn -- regs )
+    active-intervals register-mapping ;
+
+: compute-live-spill-slots ( -- spill-slots )
+    spill-slots get values [ values ] map concat
+    [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
+
+M: ##gc assign-registers-in-insn
+    dup call-next-method
+    dup compute-live-registers >>live-registers
+    compute-live-spill-slots >>live-spill-slots
+    drop ;
+
+M: insn assign-registers-in-insn drop ;
 
 : init-assignment ( live-intervals -- )
-    V{ } clone active-intervals set
+    V{ } clone pending-intervals set
     <min-heap> unhandled-intervals set
+    [ H{ } clone ] reg-class-assoc spill-slots set 
     init-unhandled ;
 
-: assign-registers ( insns live-intervals -- insns' )
+: assign-registers-in-block ( bb -- )
     [
-        init-assignment
         [
-            [ activate-new-intervals ]
-            [ drop [ (assign-registers) ] [ , ] bi ]
-            [ expire-old-intervals ]
-            tri
-        ] each-index
-    ] { } make ;
+            [
+                [
+                    insn#>>
+                    [ expire-old-intervals ]
+                    [ activate-new-intervals ]
+                    bi
+                ]
+                [ assign-registers-in-insn ]
+                [ , ]
+                tri
+            ] each
+        ] V{ } make
+    ] change-instructions drop ;
+
+: assign-registers ( rpo live-intervals -- )
+    init-assignment
+    [ assign-registers-in-block ] each ;
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 65b932c4a2..243e83445d 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -1,15 +1,77 @@
 IN: compiler.cfg.linear-scan.tests
 USING: tools.test random sorting sequences sets hashtables assocs
-kernel fry arrays splitting namespaces math accessors vectors
+kernel fry arrays splitting namespaces math accessors vectors locals
 math.order grouping
 cpu.architecture
+compiler.cfg
+compiler.cfg.optimizer
 compiler.cfg.instructions
 compiler.cfg.registers
+compiler.cfg.liveness
+compiler.cfg.predecessors
+compiler.cfg.rpo
 compiler.cfg.linear-scan
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.allocation.splitting
+compiler.cfg.linear-scan.allocation.spilling
+compiler.cfg.linear-scan.assignment
 compiler.cfg.linear-scan.debugger ;
 
+check-allocation? on
+
+[
+    { T{ live-range f 1 10 } T{ live-range f 15 15 } }
+    { T{ live-range f 16 20 } }
+] [
+    {
+        T{ live-range f 1 10 }
+        T{ live-range f 15 20 }
+    } 15 split-ranges
+] unit-test
+
+[
+    { T{ live-range f 1 10 } T{ live-range f 15 16 } }
+    { T{ live-range f 17 20 } }
+] [
+    {
+        T{ live-range f 1 10 }
+        T{ live-range f 15 20 }
+    } 16 split-ranges
+] unit-test
+
+[
+    { T{ live-range f 1 10 } }
+    { T{ live-range f 15 20 } }
+] [
+    {
+        T{ live-range f 1 10 }
+        T{ live-range f 15 20 }
+    } 12 split-ranges
+] unit-test
+
+[
+    { T{ live-range f 1 10 } T{ live-range f 15 17 } }
+    { T{ live-range f 18 20 } }
+] [
+    {
+        T{ live-range f 1 10 }
+        T{ live-range f 15 20 }
+    } 17 split-ranges
+] unit-test
+
+[
+    { T{ live-range f 1 10 } } 0 split-ranges
+] must-fail
+
+[
+    { T{ live-range f 0 0 } }
+    { T{ live-range f 1 5 } }
+] [
+    { T{ live-range f 0 5 } } 0 split-ranges
+] unit-test
+
 [ 7 ] [
     T{ live-interval
         { vreg T{ vreg { reg-class int-regs } { n 2 } } }
@@ -42,46 +104,77 @@ compiler.cfg.linear-scan.debugger ;
 
 [
     T{ live-interval
-        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
-        { start 0 }
-        { end 1 }
-        { uses V{ 0 1 } }
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+       { start 0 }
+       { end 1 }
+       { uses V{ 0 1 } }
+       { ranges V{ T{ live-range f 0 1 } } }
     }
     T{ live-interval
-        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
-        { start 5 }
-        { end 5 }
-        { uses V{ 5 } }
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+       { start 5 }
+       { end 5 }
+       { uses V{ 5 } }
+       { ranges V{ T{ live-range f 5 5 } } }
     }
 ] [
     T{ live-interval
-        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
-        { start 0 }
-        { end 5 }
-        { uses V{ 0 1 5 } }
-    } 2 split-interval
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+       { start 0 }
+       { end 5 }
+       { uses V{ 0 1 5 } }
+       { ranges V{ T{ live-range f 0 5 } } }
+    } 2 split-for-spill [ f >>split-next ] bi@
+] unit-test
+
+[
+    T{ live-interval
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+       { start 0 }
+       { end 0 }
+       { uses V{ 0 } }
+       { ranges V{ T{ live-range f 0 0 } } }
+    }
+    T{ live-interval
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+       { start 1 }
+       { end 5 }
+       { uses V{ 1 5 } }
+       { ranges V{ T{ live-range f 1 5 } } }
+    }
+] [
+    T{ live-interval
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+       { start 0 }
+       { end 5 }
+       { uses V{ 0 1 5 } }
+       { ranges V{ T{ live-range f 0 5 } } }
+    } 0 split-for-spill [ f >>split-next ] bi@
 ] unit-test
 
 [
     T{ live-interval
         { vreg T{ vreg { reg-class int-regs } { n 1 } } }
         { start 0 }
-        { end 0 }
-        { uses V{ 0 } }
+        { end 4 }
+        { uses V{ 0 1 4 } }
+        { ranges V{ T{ live-range f 0 4 } } }
     }
     T{ live-interval
         { vreg T{ vreg { reg-class int-regs } { n 1 } } }
-        { start 1 }
+        { start 5 }
         { end 5 }
-        { uses V{ 1 5 } }
+        { uses V{ 5 } }
+        { ranges V{ T{ live-range f 5 5 } } }
     }
 ] [
     T{ live-interval
-        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
-        { start 0 }
-        { end 5 }
-        { uses V{ 0 1 5 } }
-    } 0 split-interval
+       { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+       { start 0 }
+       { end 5 }
+       { uses V{ 0 1 5 } }
+       { ranges V{ T{ live-range f 0 5 } } }
+    } 5 split-before-use [ f >>split-next ] bi@
 ] unit-test
 
 [
@@ -171,7 +264,13 @@ compiler.cfg.linear-scan.debugger ;
 
 [ ] [
     {
-        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+        T{ live-interval
+           { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+           { start 0 }
+           { end 100 }
+           { uses V{ 0 100 } }
+           { ranges V{ T{ live-range f 0 100 } } }
+        }
     }
     H{ { int-regs { "A" } } }
     check-linear-scan
@@ -179,8 +278,20 @@ compiler.cfg.linear-scan.debugger ;
 
 [ ] [
     {
-        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } }
-        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
+        T{ live-interval
+           { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+           { start 0 }
+           { end 10 }
+           { uses V{ 0 10 } }
+           { ranges V{ T{ live-range f 0 10 } } }
+        }
+        T{ live-interval
+           { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+           { start 11 }
+           { end 20 }
+           { uses V{ 11 20 } }
+           { ranges V{ T{ live-range f 11 20 } } }
+        }
     }
     H{ { int-regs { "A" } } }
     check-linear-scan
@@ -188,8 +299,20 @@ compiler.cfg.linear-scan.debugger ;
 
 [ ] [
     {
-        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
-        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
+        T{ live-interval
+           { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+           { start 0 }
+           { end 100 }
+           { uses V{ 0 100 } }
+           { ranges V{ T{ live-range f 0 100 } } }
+        }
+        T{ live-interval
+           { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+           { start 30 }
+           { end 60 }
+           { uses V{ 30 60 } }
+           { ranges V{ T{ live-range f 30 60 } } }
+        }
     }
     H{ { int-regs { "A" } } }
     check-linear-scan
@@ -197,8 +320,20 @@ compiler.cfg.linear-scan.debugger ;
 
 [ ] [
     {
-        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
-        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
+        T{ live-interval
+           { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+           { start 0 }
+           { end 100 }
+           { uses V{ 0 100 } }
+           { ranges V{ T{ live-range f 0 100 } } }
+        }
+        T{ live-interval
+           { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+           { start 30 }
+           { end 200 }
+           { uses V{ 30 200 } }
+           { ranges V{ T{ live-range f 30 200 } } }
+        }
     }
     H{ { int-regs { "A" } } }
     check-linear-scan
@@ -206,8 +341,20 @@ compiler.cfg.linear-scan.debugger ;
 
 [
     {
-        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
-        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } }
+        T{ live-interval
+           { vreg T{ vreg { n 1 } { reg-class int-regs } } }
+           { start 0 }
+           { end 100 }
+           { uses V{ 0 100 } }
+           { ranges V{ T{ live-range f 0 100 } } }
+        }
+        T{ live-interval
+           { vreg T{ vreg { n 2 } { reg-class int-regs } } }
+           { start 30 }
+           { end 100 }
+           { uses V{ 30 100 } }
+           { ranges V{ T{ live-range f 30 100 } } }
+        }
     }
     H{ { int-regs { "A" } } }
     check-linear-scan
@@ -240,11 +387,12 @@ SYMBOL: max-uses
         max-insns get [ 0 ] replicate taken set
         max-insns get [ dup ] H{ } map>assoc available set
         [
-            live-interval new
+            \ live-interval new
                 swap int-regs swap vreg boa >>vreg
                 max-uses get random 2 max [ not-taken ] replicate natural-sort
                 [ >>uses ] [ first >>start ] bi
                 dup uses>> last >>end
+                dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
         ] map
     ] with-scope ;
 
@@ -264,45 +412,15 @@ SYMBOL: max-uses
 
 USING: math.private compiler.cfg.debugger ;
 
-[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
-
-[ f ] [
-    T{ ##allot
-        f
-        T{ vreg f int-regs 1 }
-        40
-        array
-        T{ vreg f int-regs 2 }
-        f
-    } clone
-    1array (linear-scan) first regs>> values all-equal?
+[ ] [
+    [ float+ float>fixnum 3 fixnum*fast ]
+    test-cfg first optimize-cfg linear-scan drop
 ] unit-test
 
-[ 0 1 ] [
-    {
-        T{ live-interval
-            { vreg T{ vreg { reg-class int-regs } { n 1 } } }
-            { start 0 }
-            { end 5 }
-            { uses V{ 0 1 5 } }
-        }
-        T{ live-interval
-            { vreg T{ vreg { reg-class int-regs } { n 2 } } }
-            { start 3 }
-            { end 4 }
-            { uses V{ 3 4 } }
-        }
-        T{ live-interval
-            { vreg T{ vreg { reg-class int-regs } { n 3 } } }
-            { start 2 }
-            { end 6 }
-            { uses V{ 2 4 6 } }
-        }
-    } [ clone ] map
-    H{ { int-regs { "A" "B" } } }
-    allocate-registers
-    first split-before>> [ start>> ] [ end>> ] bi
-] unit-test
+: fake-live-ranges ( seq -- seq' )
+    [
+        clone dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
+    ] map ;
 
 ! Coalescing interacted badly with splitting
 [ ] [
@@ -351,7 +469,7 @@ USING: math.private compiler.cfg.debugger ;
             { end 10 }
             { uses V{ 9 10 } }
         }
-    }
+    } fake-live-ranges
     { { int-regs { 0 1 2 3 } } }
     allocate-registers drop
 ] unit-test
@@ -1106,7 +1224,7 @@ USING: math.private compiler.cfg.debugger ;
             { end 109 }
             { uses V{ 103 109 } }
         }
-    }
+    } fake-live-ranges
     { { int-regs { 0 1 2 3 4 } } }
     allocate-registers drop
 ] unit-test
@@ -1199,7 +1317,487 @@ USING: math.private compiler.cfg.debugger ;
             { end 92 }
             { uses V{ 42 45 78 80 92 } }
         }
-    }
+    } fake-live-ranges
     { { int-regs { 0 1 2 3 } } }
     allocate-registers drop
 ] unit-test
+
+! Spill slot liveness was computed incorrectly, leading to a FEP
+! 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
+             V{
+                 T{ ##gc f V int-regs 6 V int-regs 7 }
+                 T{ ##peek f V int-regs 0 D 0 }
+                 T{ ##peek f V int-regs 1 D 1 }
+                 T{ ##peek f V int-regs 2 D 2 }
+                 T{ ##peek f V int-regs 3 D 3 }
+                 T{ ##peek f V int-regs 4 D 4 }
+                 T{ ##peek f V int-regs 5 D 5 }
+                 T{ ##replace f V int-regs 0 D 1 }
+                 T{ ##replace f V int-regs 1 D 2 }
+                 T{ ##replace f V int-regs 2 D 3 }
+                 T{ ##replace f V int-regs 3 D 4 }
+                 T{ ##replace f V int-regs 4 D 5 }
+                 T{ ##replace f V int-regs 5 D 0 }
+             }
+           }
+        } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
+        instructions>> first live-spill-slots>> empty?
+    ] with-scope
+] unit-test
+
+[ f ] [
+    T{ live-range f 0 10 }
+    T{ live-range f 20 30 }
+    intersect-live-range
+] unit-test
+
+[ 10 ] [
+    T{ live-range f 0 10 }
+    T{ live-range f 10 30 }
+    intersect-live-range
+] unit-test
+
+[ 5 ] [
+    T{ live-range f 0 10 }
+    T{ live-range f 5 30 }
+    intersect-live-range
+] unit-test
+
+[ 5 ] [
+    T{ live-range f 5 30 }
+    T{ live-range f 0 10 }
+    intersect-live-range
+] unit-test
+
+[ 5 ] [
+    T{ live-range f 5 10 }
+    T{ live-range f 0 15 }
+    intersect-live-range
+] unit-test
+
+[ 50 ] [
+    {
+        T{ live-range f 0 10 }
+        T{ live-range f 20 30 }
+        T{ live-range f 40 50 }
+    }
+    {
+        T{ live-range f 11 15 }
+        T{ live-range f 31 35 }
+        T{ live-range f 50 55 }
+    }
+    intersect-live-ranges
+] unit-test
+
+[ 5 ] [
+    T{ live-interval
+       { start 0 }
+       { end 10 }
+       { uses { 0 10 } }
+       { ranges V{ T{ live-range f 0 10 } } }
+    }
+    T{ live-interval
+       { start 5 }
+       { end 10 }
+       { uses { 5 10 } }
+       { ranges V{ T{ live-range f 5 10 } } }
+    }
+    H{ }
+    intersect-inactive
+] unit-test
+
+! Bug in live spill slots calculation
+
+T{ basic-block
+   { id 205651 }
+   { number 0 }
+   { instructions V{ T{ ##prologue } T{ ##branch } } }
+} 0 set
+
+T{ basic-block
+   { id 205652 }
+   { number 1 }
+   { instructions
+     V{
+         T{ ##peek
+            { dst V int-regs 703128 }
+            { loc D 1 }
+         }
+         T{ ##peek
+            { dst V int-regs 703129 }
+            { loc D 0 }
+         }
+         T{ ##copy
+            { dst V int-regs 703134 }
+            { src V int-regs 703128 }
+         }
+         T{ ##copy
+            { dst V int-regs 703135 }
+            { src V int-regs 703129 }
+         }
+         T{ ##compare-imm-branch
+            { src1 V int-regs 703128 }
+            { src2 5 }
+            { cc cc/= }
+         }
+     }
+   }
+} 1 set
+
+T{ basic-block
+   { id 205653 }
+   { number 2 }
+   { instructions
+     V{
+         T{ ##copy
+            { dst V int-regs 703134 }
+            { src V int-regs 703129 }
+         }
+         T{ ##copy
+            { dst V int-regs 703135 }
+            { src V int-regs 703128 }
+         }
+         T{ ##branch }
+     }
+   }
+} 2 set
+
+T{ basic-block
+   { id 205655 }
+   { number 3 }
+   { instructions
+     V{
+         T{ ##replace
+            { src V int-regs 703134 }
+            { loc D 0 }
+         }
+         T{ ##replace
+            { src V int-regs 703135 }
+            { loc D 1 }
+         }
+         T{ ##epilogue }
+         T{ ##return }
+     }
+   }
+} 3 set
+
+1 get 1vector 0 get (>>successors)
+2 get 3 get V{ } 2sequence 1 get (>>successors)
+3 get 1vector 2 get (>>successors)
+
+:: test-linear-scan-on-cfg ( regs -- )
+    [ ] [
+        cfg new 0 get >>entry
+        compute-predecessors
+        compute-liveness
+        reverse-post-order
+        { { int-regs regs } } (linear-scan)
+    ] unit-test ;
+
+{ 1 2 } test-linear-scan-on-cfg
+
+! Bug in inactive interval handling
+! [ rot dup [ -rot ] when ]
+T{ basic-block
+   { id 201486 }
+   { number 0 }
+   { instructions V{ T{ ##prologue } T{ ##branch } } }
+} 0 set
+    
+T{ basic-block
+   { id 201487 }
+   { number 1 }
+   { instructions
+     V{
+         T{ ##peek
+            { dst V int-regs 689473 }
+            { loc D 2 }
+         }
+         T{ ##peek
+            { dst V int-regs 689474 }
+            { loc D 1 }
+         }
+         T{ ##peek
+            { dst V int-regs 689475 }
+            { loc D 0 }
+         }
+         T{ ##compare-imm-branch
+            { src1 V int-regs 689473 }
+            { src2 5 }
+            { cc cc/= }
+         }
+     }
+   }
+} 1 set
+
+T{ basic-block
+   { id 201488 }
+   { number 2 }
+   { instructions
+     V{
+         T{ ##copy
+            { dst V int-regs 689481 }
+            { src V int-regs 689475 }
+         }
+         T{ ##copy
+            { dst V int-regs 689482 }
+            { src V int-regs 689474 }
+         }
+         T{ ##copy
+            { dst V int-regs 689483 }
+            { src V int-regs 689473 }
+         }
+         T{ ##branch }
+     }
+   }
+} 2 set
+
+T{ basic-block
+   { id 201489 }
+   { number 3 }
+   { instructions
+     V{
+         T{ ##copy
+            { dst V int-regs 689481 }
+            { src V int-regs 689473 }
+         }
+         T{ ##copy
+            { dst V int-regs 689482 }
+            { src V int-regs 689475 }
+         }
+         T{ ##copy
+            { dst V int-regs 689483 }
+            { src V int-regs 689474 }
+         }
+         T{ ##branch }
+     }
+   }
+} 3 set
+
+T{ basic-block
+   { id 201490 }
+   { number 4 }
+   { instructions
+     V{
+         T{ ##replace
+            { src V int-regs 689481 }
+            { loc D 0 }
+         }
+         T{ ##replace
+            { src V int-regs 689482 }
+            { loc D 1 }
+         }
+         T{ ##replace
+            { src V int-regs 689483 }
+            { loc D 2 }
+         }
+         T{ ##epilogue }
+         T{ ##return }
+     }
+   }
+} 4 set
+
+: test-diamond ( -- )
+    1 get 1vector 0 get (>>successors)
+    2 get 3 get V{ } 2sequence 1 get (>>successors)
+    4 get 1vector 2 get (>>successors)
+    4 get 1vector 3 get (>>successors) ;
+
+test-diamond
+
+{ 1 2 3 4 } test-linear-scan-on-cfg
+
+! Similar to the above
+! [ swap dup [ rot ] when ]
+
+T{ basic-block
+   { id 201537 }
+   { number 0 }
+   { instructions V{ T{ ##prologue } T{ ##branch } } }
+} 0 set
+    
+T{ basic-block
+   { id 201538 }
+   { number 1 }
+   { instructions
+     V{
+         T{ ##peek
+            { dst V int-regs 689600 }
+            { loc D 1 }
+         }
+         T{ ##peek
+            { dst V int-regs 689601 }
+            { loc D 0 }
+         }
+         T{ ##compare-imm-branch
+            { src1 V int-regs 689600 }
+            { src2 5 }
+            { cc cc/= }
+         }
+     }
+   }
+} 1 set
+    
+T{ basic-block
+   { id 201539 }
+   { number 2 }
+   { instructions
+     V{
+         T{ ##peek
+            { dst V int-regs 689604 }
+            { loc D 2 }
+         }
+         T{ ##copy
+            { dst V int-regs 689607 }
+            { src V int-regs 689604 }
+         }
+         T{ ##copy
+            { dst V int-regs 689608 }
+            { src V int-regs 689600 }
+         }
+         T{ ##copy
+            { dst V int-regs 689610 }
+            { src V int-regs 689601 }
+         }
+         T{ ##branch }
+     }
+   }
+} 2 set
+    
+T{ basic-block
+   { id 201540 }
+   { number 3 }
+   { instructions
+     V{
+         T{ ##peek
+            { dst V int-regs 689609 }
+            { loc D 2 }
+         }
+         T{ ##copy
+            { dst V int-regs 689607 }
+            { src V int-regs 689600 }
+         }
+         T{ ##copy
+            { dst V int-regs 689608 }
+            { src V int-regs 689601 }
+         }
+         T{ ##copy
+            { dst V int-regs 689610 }
+            { src V int-regs 689609 }
+         }
+         T{ ##branch }
+     }
+   }
+} 3 set
+    
+T{ basic-block
+   { id 201541 }
+   { number 4 }
+   { instructions
+     V{
+         T{ ##replace
+            { src V int-regs 689607 }
+            { loc D 0 }
+         }
+         T{ ##replace
+            { src V int-regs 689608 }
+            { loc D 1 }
+         }
+         T{ ##replace
+            { src V int-regs 689610 }
+            { loc D 2 }
+         }
+         T{ ##epilogue }
+         T{ ##return }
+     }
+   }
+} 4 set
+
+test-diamond
+
+{ 1 2 3 4 } test-linear-scan-on-cfg
+
+! compute-live-registers was inaccurate since it didn't take
+! lifetime holes into account
+
+T{ basic-block
+   { id 0 }
+   { number 0 }
+   { instructions V{ T{ ##prologue } T{ ##branch } } }
+} 0 set
+
+T{ basic-block
+   { id 1 }
+   { instructions
+     V{
+         T{ ##peek
+            { dst V int-regs 0 }
+            { loc D 0 }
+         }
+         T{ ##compare-imm-branch
+            { src1 V int-regs 0 }
+            { src2 5 }
+            { cc cc/= }
+         }
+     }
+   }
+} 1 set
+
+T{ basic-block
+   { id 2 }
+   { instructions
+     V{
+         T{ ##peek
+            { dst V int-regs 1 }
+            { loc D 1 }
+         }
+         T{ ##copy
+            { dst V int-regs 2 }
+            { src V int-regs 1 }
+         }
+         T{ ##branch }
+     }
+   }
+} 2 set
+
+T{ basic-block
+   { id 3 }
+   { instructions
+     V{
+         T{ ##peek
+            { dst V int-regs 3 }
+            { loc D 2 }
+         }
+         T{ ##copy
+            { dst V int-regs 2 }
+            { src V int-regs 3 }
+         }
+         T{ ##branch }
+     }
+   }
+} 3 set
+
+T{ basic-block
+   { id 4 }
+   { instructions
+     V{
+         T{ ##replace
+            { src V int-regs 2 }
+            { loc D 0 }
+         }
+         T{ ##return }
+     }
+   }
+} 4 set
+
+test-diamond
+
+{ 1 2 3 4 } test-linear-scan-on-cfg
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor
index 855f2a6648..3a0a7f8770 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan.factor
@@ -1,11 +1,14 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces make
 cpu.architecture
 compiler.cfg
+compiler.cfg.rpo
 compiler.cfg.instructions
+compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.allocation.state
 compiler.cfg.linear-scan.assignment ;
 IN: compiler.cfg.linear-scan
 
@@ -23,16 +26,15 @@ IN: compiler.cfg.linear-scan
 ! by Omri Traub, Glenn Holloway, Michael D. Smith
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
 
-: (linear-scan) ( insns -- insns' )
-    dup compute-live-intervals
-    machine-registers allocate-registers assign-registers ;
-
-: linear-scan ( mr -- mr' )
+: (linear-scan) ( rpo machine-registers -- )
     [
-        [
-            [
-                (linear-scan) %
-                spill-counts get _spill-counts
-            ] { } make
-        ] change-instructions
+        dup number-instructions
+        dup compute-live-intervals
+    ] dip
+    allocate-registers assign-registers ;
+
+: linear-scan ( cfg -- cfg' )
+    [
+        dup reverse-post-order machine-registers (linear-scan)
+        spill-counts get >>spill-counts
     ] 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 1055a3524a..c88f7fd21b 100644
--- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -1,26 +1,65 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces kernel assocs accessors sequences math fry
-compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.def-use ;
+USING: namespaces kernel assocs accessors sequences math math.order fry
+binary-search combinators compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
 IN: compiler.cfg.linear-scan.live-intervals
 
+TUPLE: live-range from to ;
+
+C: <live-range> live-range
+
 TUPLE: live-interval
 vreg
-reg spill-to reload-from split-before split-after
-start end uses
+reg spill-to reload-from
+split-before split-after split-next
+start end ranges uses
 copy-from ;
 
-: add-use ( n live-interval -- )
-    dup live-interval? [ "No def" throw ] unless
-    [ (>>end) ] [ uses>> push ] 2bi ;
+: covers? ( insn# live-interval -- ? )
+    ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
 
-: <live-interval> ( start vreg -- live-interval )
-    live-interval new
+: child-interval-at ( insn# interval -- interval' )
+    dup split-after>> [
+        2dup split-after>> start>> <
+        [ split-before>> ] [ split-after>> ] if
+        child-interval-at
+    ] [ nip ] if ;
+
+ERROR: dead-value-error vreg ;
+
+: shorten-range ( n live-interval -- )
+    dup ranges>> empty?
+    [ vreg>> dead-value-error ] [ ranges>> last (>>from) ] if ;
+
+: extend-range ( from to live-range -- )
+    ranges>> last
+    [ max ] change-to
+    [ min ] change-from
+    drop ;
+
+: add-new-range ( from to live-interval -- )
+    [ <live-range> ] dip ranges>> push ;
+
+: extend-range? ( to live-interval -- ? )
+    ranges>> [ drop f ] [ last from>> >= ] if-empty ;
+
+: add-range ( from to live-interval -- )
+    2dup extend-range?
+    [ extend-range ] [ add-new-range ] if ;
+
+: add-use ( n live-interval -- )
+    uses>> push ;
+
+: <live-interval> ( vreg -- live-interval )
+    \ live-interval new
         V{ } clone >>uses
-        swap >>vreg
-        over >>start
-        [ add-use ] keep ;
+        V{ } clone >>ranges
+        swap >>vreg ;
+
+: block-from ( bb -- n ) instructions>> first insn#>> ;
+
+: block-to ( bb -- n ) instructions>> last insn#>> ;
 
 M: live-interval hashcode*
     nip [ start>> ] [ end>> 1000 * ] bi + ;
@@ -31,34 +70,77 @@ M: live-interval clone
 ! Mapping from vreg to live-interval
 SYMBOL: live-intervals
 
-: new-live-interval ( n vreg live-intervals -- )
-    2dup key? [
-        at add-use
-    ] [
-        [ [ <live-interval> ] keep ] dip set-at
-    ] if ;
+: live-interval ( vreg live-intervals -- live-interval )
+    [ <live-interval> ] cache ;
 
-GENERIC# compute-live-intervals* 1 ( insn n -- )
+GENERIC: compute-live-intervals* ( insn -- )
 
-M: insn compute-live-intervals* 2drop ;
+M: insn compute-live-intervals* drop ;
+
+: handle-output ( n vreg live-intervals -- )
+    live-interval
+    [ add-use ] [ shorten-range ] 2bi ;
+
+: handle-input ( n vreg live-intervals -- )
+    live-interval
+    [ [ basic-block get block-from ] 2dip add-range ] [ add-use ] 2bi ;
+
+: handle-temp ( n vreg live-intervals -- )
+    live-interval
+    [ dupd add-range ] [ add-use ] 2bi ;
 
 M: vreg-insn compute-live-intervals*
+    dup insn#>>
     live-intervals get
-    [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
-    [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
-    3bi ;
+    [ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ]
+    [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
+    [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
+    3tri ;
 
 : record-copy ( insn -- )
     [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
 
 M: ##copy compute-live-intervals*
-    [ call-next-method ] [ drop record-copy ] 2bi ;
+    [ call-next-method ] [ record-copy ] bi ;
 
 M: ##copy-float compute-live-intervals*
-    [ call-next-method ] [ drop record-copy ] 2bi ;
+    [ call-next-method ] [ record-copy ] bi ;
 
-: compute-live-intervals ( instructions -- live-intervals )
+: handle-live-out ( bb -- )
+    live-out keys
+    basic-block get [ block-from ] [ block-to ] bi
+    live-intervals get '[
+        [ _ _ ] dip _ live-interval add-range
+    ] each ;
+
+: compute-live-intervals-step ( bb -- )
+    [ basic-block set ]
+    [ handle-live-out ]
+    [ instructions>> <reversed> [ compute-live-intervals* ] each ] tri ;
+
+: compute-start/end ( live-interval -- )
+    dup ranges>> [ first from>> ] [ last to>> ] bi
+    [ >>start ] [ >>end ] bi* drop ;
+
+: check-start/end ( live-interval -- )
+    [ [ start>> ] [ uses>> first ] bi assert= ]
+    [ [ end>> ] [ uses>> last ] bi assert= ]
+    bi ;
+
+: finish-live-intervals ( live-intervals -- )
+    ! Since live intervals are computed in a backward order, we have
+    ! to reverse some sequences, and compute the start and end.
+    [
+        {
+            [ ranges>> reverse-here ]
+            [ uses>> reverse-here ]
+            [ compute-start/end ]
+            [ check-start/end ]
+        } cleave
+    ] each ;
+
+: compute-live-intervals ( rpo -- live-intervals )
     H{ } clone [
         live-intervals set
-        [ compute-live-intervals* ] each-index
-    ] keep values ;
+        <reversed> [ compute-live-intervals-step ] each
+    ] keep values dup finish-live-intervals ;
diff --git a/basis/compiler/cfg/linear-scan/numbering/authors.txt b/basis/compiler/cfg/linear-scan/numbering/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/numbering/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/numbering/numbering.factor b/basis/compiler/cfg/linear-scan/numbering/numbering.factor
new file mode 100644
index 0000000000..6734f6a359
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/numbering/numbering.factor
@@ -0,0 +1,11 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors math sequences ;
+IN: compiler.cfg.linear-scan.numbering
+
+: number-instructions ( rpo -- )
+    [ 0 ] dip [
+        instructions>> [
+            [ (>>insn#) ] [ drop 2 + ] 2bi
+        ] each
+    ] each drop ;
\ 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
new file mode 100644
index 0000000000..8996327beb
--- /dev/null
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel math namespaces sequences
+compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness ;
+IN: compiler.cfg.linear-scan.resolve
+
+: add-mapping ( from to -- )
+    2drop
+    ;
+
+: resolve-value-data-flow ( bb to vreg -- )
+    live-intervals get at
+    [ [ block-to ] dip child-interval-at ]
+    [ [ block-from ] dip child-interval-at ]
+    bi-curry bi* 2dup = [ 2drop ] [
+        add-mapping
+    ] if ;
+
+: resolve-mappings ( bb to -- )
+    2drop
+    ;
+
+: resolve-edge-data-flow ( bb to -- )
+    [ 2dup live-in [ resolve-value-data-flow ] with with each ]
+    [ resolve-mappings ]
+    2bi ; 
+
+: resolve-block-data-flow ( bb -- )
+    dup successors>> [
+        resolve-edge-data-flow
+    ] with each ;
+
+: resolve-data-flow ( rpo -- )
+    [ resolve-block-data-flow ] each ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 8ef3abda39..9e222f1832 100755
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -1,24 +1,28 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math accessors sequences namespaces make
-combinators classes
+combinators assocs arrays locals cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
+compiler.cfg.liveness
+compiler.cfg.stack-frame
 compiler.cfg.instructions ;
 IN: compiler.cfg.linearization
 
 ! Convert CFG IR to machine IR.
 GENERIC: linearize-insn ( basic-block insn -- )
 
-: linearize-insns ( basic-block -- )
-    dup instructions>> [ linearize-insn ] with each ; inline
+: linearize-basic-block ( bb -- )
+    [ number>> _label ]
+    [ dup instructions>> [ linearize-insn ] with each ]
+    bi ;
 
 M: insn linearize-insn , drop ;
 
 : useless-branch? ( basic-block successor -- ? )
     #! If our successor immediately follows us in RPO, then we
     #! don't need to branch.
-    [ number>> ] bi@ 1- = ; inline
+    [ number>> ] bi@ 1 - = ; inline
 
 : branch-to-branch? ( successor -- ? )
     #! A branch to a block containing just a jump return is cloned.
@@ -30,7 +34,7 @@ M: insn linearize-insn , drop ;
 : emit-branch ( basic-block successor -- )
     {
         { [ 2dup useless-branch? ] [ 2drop ] }
-        { [ dup branch-to-branch? ] [ nip linearize-insns ] }
+        { [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
         [ nip number>> _branch ]
     } cond ;
 
@@ -46,35 +50,82 @@ M: ##branch linearize-insn
     [ drop dup successors>> second useless-branch? ] 2bi
     [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
 
+: with-regs ( insn quot -- )
+    over regs>> [ call ] dip building get last (>>regs) ; inline
+
 M: ##compare-branch linearize-insn
-    binary-conditional _compare-branch emit-branch ;
+    [ binary-conditional _compare-branch ] with-regs emit-branch ;
 
 M: ##compare-imm-branch linearize-insn
-    binary-conditional _compare-imm-branch emit-branch ;
+    [ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
 
 M: ##compare-float-branch linearize-insn
-    binary-conditional _compare-float-branch emit-branch ;
+    [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
 
-: gc? ( bb -- ? )
-    instructions>> [
-        class {
-            ##allot
-            ##integer>bignum
-            ##box-float
-            ##box-alien
-        } memq?
-    ] any? ;
+M: ##dispatch linearize-insn
+    swap
+    [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
+    [ successors>> [ number>> _dispatch-label ] each ]
+    bi* ;
 
-: linearize-basic-block ( bb -- )
-    [ number>> _label ]
-    [ gc? [ _gc ] when ]
-    [ linearize-insns ]
-    tri ;
+: gc-root-registers ( n live-registers -- n )
+    [
+        [ second 2array , ]
+        [ first reg-class>> reg-size + ]
+        2bi
+    ] each ;
 
-: linearize-basic-blocks ( rpo -- insns )
-    [ [ linearize-basic-block ] each ] { } make ;
+: gc-root-spill-slots ( n live-spill-slots -- n )
+    [
+        dup first reg-class>> int-regs eq? [
+            [ second <spill-slot> 2array , ]
+            [ first reg-class>> reg-size + ]
+            2bi
+        ] [ drop ] if
+    ] each ;
 
-: build-mr ( cfg -- mr )
-    [ entry>> reverse-post-order linearize-basic-blocks ]
-    [ word>> ] [ label>> ]
-    tri <mr> ;
+: oop-registers ( regs -- regs' )
+    [ first reg-class>> int-regs eq? ] filter ;
+
+: data-registers ( regs -- regs' )
+    [ first reg-class>> double-float-regs eq? ] filter ;
+
+:: compute-gc-roots ( live-registers live-spill-slots -- alist )
+    [
+        0
+        ! we put float registers last; the GC doesn't actually scan them
+        live-registers oop-registers gc-root-registers
+        live-spill-slots gc-root-spill-slots
+        live-registers data-registers gc-root-registers
+        drop
+    ] { } make ;
+
+: count-gc-roots ( live-registers live-spill-slots -- n )
+    ! Size of GC root area, minus the float registers
+    [ oop-registers length ] bi@ + ;
+
+M: ##gc linearize-insn
+    nip
+    [
+        [ temp1>> ]
+        [ temp2>> ]
+        [
+            [ live-registers>> ] [ live-spill-slots>> ] bi
+            [ compute-gc-roots ]
+            [ count-gc-roots ]
+            [ gc-roots-size ]
+            2tri
+        ] tri
+        _gc
+    ] with-regs ;
+
+: linearize-basic-blocks ( cfg -- insns )
+    [
+        [ [ linearize-basic-block ] each-basic-block ]
+        [ spill-counts>> _spill-counts ]
+        bi
+    ] { } make ;
+
+: flatten-cfg ( cfg -- mr )
+    [ linearize-basic-blocks ] [ word>> ] [ label>> ] tri
+    <mr> ;
diff --git a/basis/compiler/cfg/liveness/authors.txt b/basis/compiler/cfg/liveness/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/liveness/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor
new file mode 100644
index 0000000000..6c40bb3782
--- /dev/null
+++ b/basis/compiler/cfg/liveness/liveness.factor
@@ -0,0 +1,78 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces deques accessors sets sequences assocs fry
+dlists compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.rpo ;
+IN: compiler.cfg.liveness
+
+! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
+
+! Assoc mapping basic blocks to sets of vregs
+SYMBOL: live-ins
+
+: live-in ( basic-block -- set ) live-ins get at ;
+
+! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
+! is in conrrespondence with a predecessor
+SYMBOL: phi-live-ins
+
+: phi-live-in ( predecessor basic-block -- set )
+    [ predecessors>> index ] keep phi-live-ins get at
+    dup [ nth ] [ 2drop f ] if ;
+
+! 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 ] [ [ inputs>> ] map flip [ unique ] map ] 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 ;
diff --git a/basis/compiler/cfg/local/authors.txt b/basis/compiler/cfg/local/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/local/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/local/local.factor b/basis/compiler/cfg/local/local.factor
new file mode 100644
index 0000000000..5d78397998
--- /dev/null
+++ b/basis/compiler/cfg/local/local.factor
@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ;
+IN: compiler.cfg.local
+
+: optimize-basic-block ( bb init-quot insn-quot -- )
+    [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
+
+: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
+    [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline
\ No newline at end of file
diff --git a/basis/compiler/cfg/mr/authors.txt b/basis/compiler/cfg/mr/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/mr/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/mr/mr.factor b/basis/compiler/cfg/mr/mr.factor
new file mode 100644
index 0000000000..9f6a62090c
--- /dev/null
+++ b/basis/compiler/cfg/mr/mr.factor
@@ -0,0 +1,14 @@
+! 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.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
+    build-stack-frame ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor
new file mode 100644
index 0000000000..b95a8c79ea
--- /dev/null
+++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor
@@ -0,0 +1,34 @@
+USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
+compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
+sequences.private math sbufs math.private slots.private strings ;
+IN: compiler.cfg.optimizer.tests
+
+! Miscellaneous tests
+
+: more? ( x -- ? ) ;
+
+: test-case-1 ( -- ? ) f ;
+
+: test-case-2 ( -- )
+    test-case-1 [ test-case-2 ] [ ] if ; inline recursive
+
+{
+    [ 1array ]
+    [ 1 2 ? ]
+    [ { array } declare [ ] map ]
+    [ { array } declare dup 1 slot [ 1 slot ] when ]
+    [ [ dup more? ] [ dup ] produce ]
+    [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
+    [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
+    [
+        { fixnum sbuf } declare 2dup 3 slot fixnum> [
+            over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
+        ] [ ] if
+    ]
+    [ [ 2 fixnum* ] when 3 ]
+    [ [ 2 fixnum+ ] when 3 ]
+    [ [ 2 fixnum- ] when 3 ]
+    [ 10000 [ ] times ]
+} [
+    [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
+] each
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 7887faeb61..9d481ef1d2 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -1,29 +1,39 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences compiler.cfg.rpo
-compiler.cfg.instructions
+USING: kernel sequences accessors combinators namespaces
 compiler.cfg.predecessors
 compiler.cfg.useless-blocks
 compiler.cfg.height
+compiler.cfg.stack-analysis
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
-compiler.cfg.dead-code
-compiler.cfg.write-barrier ;
+compiler.cfg.dce
+compiler.cfg.write-barrier
+compiler.cfg.liveness
+compiler.cfg.rpo
+compiler.cfg.phi-elimination
+compiler.cfg.checker ;
 IN: compiler.cfg.optimizer
 
-: trivial? ( insns -- ? )
-    dup length 2 = [ first ##call? ] [ drop f ] if ;
+SYMBOL: check-optimizer?
+
+: ?check ( cfg -- cfg' )
+    check-optimizer? get [
+        dup check-cfg
+    ] when ;
 
 : optimize-cfg ( cfg -- cfg' )
-    compute-predecessors
-    delete-useless-blocks
-    delete-useless-conditionals
     [
-        dup trivial? [
-            normalize-height
-            alias-analysis
-            value-numbering
-            eliminate-dead-code
-            eliminate-write-barriers
-        ] unless
-    ] change-basic-blocks ;
+        compute-predecessors
+        delete-useless-blocks
+        delete-useless-conditionals
+        normalize-height
+        stack-analysis
+        compute-liveness
+        alias-analysis
+        value-numbering
+        eliminate-dead-code
+        eliminate-write-barriers
+        eliminate-phis
+        ?check
+    ] with-scope ;
diff --git a/basis/compiler/cfg/phi-elimination/authors.txt b/basis/compiler/cfg/phi-elimination/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/phi-elimination/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor
new file mode 100644
index 0000000000..3ebf553a45
--- /dev/null
+++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor
@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors compiler.cfg compiler.cfg.instructions
+compiler.cfg.rpo fry kernel sequences ;
+IN: compiler.cfg.phi-elimination
+
+: insert-copy ( predecessor input output -- )
+    '[ _ _ swap ##copy ] add-instructions ;
+
+: eliminate-phi ( bb ##phi -- )
+    [ predecessors>> ] [ [ inputs>> ] [ dst>> ] bi ] bi*
+    '[ _ insert-copy ] 2each ;
+
+: eliminate-phi-step ( bb -- )
+    dup [
+        [ ##phi? ] partition
+        [ [ eliminate-phi ] with each ] dip
+    ] change-instructions drop ;
+
+: eliminate-phis ( cfg -- cfg' )
+    dup [ eliminate-phi-step ] each-basic-block ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/predecessors/predecessors.factor b/basis/compiler/cfg/predecessors/predecessors.factor
index 01a2a771bc..54efc53bc4 100644
--- a/basis/compiler/cfg/predecessors/predecessors.factor
+++ b/basis/compiler/cfg/predecessors/predecessors.factor
@@ -1,10 +1,13 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences compiler.cfg.rpo ;
 IN: compiler.cfg.predecessors
 
-: (compute-predecessors) ( bb -- )
+: predecessors-step ( bb -- )
     dup successors>> [ predecessors>> push ] with each ;
 
 : compute-predecessors ( cfg -- cfg' )
-    dup [ (compute-predecessors) ] each-basic-block ;
+    [ [ V{ } clone >>predecessors drop ] each-basic-block ]
+    [ [ predecessors-step ] each-basic-block ]
+    [ ]
+    tri ;
diff --git a/basis/compiler/cfg/rpo/rpo.factor b/basis/compiler/cfg/rpo/rpo.factor
index bb4153da78..f6a40e17d0 100644
--- a/basis/compiler/cfg/rpo/rpo.factor
+++ b/basis/compiler/cfg/rpo/rpo.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors namespaces make math sequences sets
 assocs fry compiler.cfg compiler.cfg.instructions ;
@@ -7,29 +7,29 @@ IN: compiler.cfg.rpo
 SYMBOL: visited
 
 : post-order-traversal ( bb -- )
-    dup id>> visited get key? [ drop ] [
-        dup id>> visited get conjoin
+    dup visited get key? [ drop ] [
+        dup visited get conjoin
         [
             successors>> <reversed>
             [ post-order-traversal ] each
         ] [ , ] bi
     ] if ;
 
-: post-order ( bb -- blocks )
-    [ post-order-traversal ] { } make ;
-
 : number-blocks ( blocks -- )
-    [ >>number drop ] each-index ;
+    dup length iota <reversed>
+    [ >>number drop ] 2each ;
 
-: reverse-post-order ( bb -- blocks )
-    H{ } clone visited [
-        post-order <reversed> dup number-blocks
-    ] with-variable ; inline
+: post-order ( cfg -- blocks )
+    dup post-order>> [ ] [
+        [
+            H{ } clone visited set
+            dup entry>> post-order-traversal
+        ] { } make dup number-blocks
+        >>post-order post-order>>
+    ] ?if ;
+
+: reverse-post-order ( cfg -- blocks )
+    post-order <reversed> ; inline
 
 : each-basic-block ( cfg quot -- )
-    [ entry>> reverse-post-order ] dip each ; inline
-
-: change-basic-blocks ( cfg quot -- cfg' )
-    [ '[ _ change-instructions drop ] each-basic-block ]
-    [ drop ]
-    2bi ; inline
+    [ reverse-post-order ] dip each ; inline
diff --git a/basis/compiler/cfg/stack-analysis/authors.txt b/basis/compiler/cfg/stack-analysis/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/stack-analysis/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
new file mode 100644
index 0000000000..3501825704
--- /dev/null
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -0,0 +1,115 @@
+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.height compiler.cfg.rpo
+compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
+sets namespaces ;
+IN: compiler.cfg.stack-analysis.tests
+
+! Fundamental invariant: a basic block should not load or store a value more than once
+: check-for-redundant-ops ( cfg -- )
+    [
+        instructions>>
+        [
+            [ ##peek? ] filter [ loc>> ] map duplicates empty?
+            [ "Redundant peeks" throw ] unless
+        ] [
+            [ ##replace? ] filter [ loc>> ] map duplicates empty?
+            [ "Redundant replaces" throw ] unless
+        ] bi
+    ] each-basic-block ;
+
+: test-stack-analysis ( quot -- cfg )
+    dup cfg? [ test-cfg first ] unless
+    compute-predecessors
+    delete-useless-blocks
+    delete-useless-conditionals
+    normalize-height
+    stack-analysis
+    dup check-cfg
+    dup check-for-redundant-ops ;
+
+: linearize ( cfg -- mr )
+    flatten-cfg instructions>> ;
+
+local-only? off
+
+[ ] [ [ ] 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
+[ 1 t ] [
+    [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
+    [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
+] unit-test
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
new file mode 100644
index 0000000000..4ebdf7012f
--- /dev/null
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -0,0 +1,295 @@
+! 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 compiler.cfg.copy-prop compiler.cfg.def-use
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
+compiler.cfg.hats compiler.cfg ;
+IN: compiler.cfg.stack-analysis
+
+! Convert stack operations to register operations
+
+! If 'poisoned' is set, disregard height information. This is set if we don't have
+! height change information for an instruction.
+TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height 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 ;
+
+GENERIC: height-for ( loc -- n )
+
+M: ds-loc height-for drop state get ds-height>> ;
+M: rs-loc height-for drop state get rs-height>> ;
+
+: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
+
+GENERIC: translate-loc ( loc -- loc' )
+
+M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
+M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
+
+GENERIC: untranslate-loc ( loc -- loc' )
+
+M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
+M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
+
+: redundant-replace? ( vreg loc -- ? )
+    dup untranslate-loc n>> 0 <
+    [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
+
+: save-changed-locs ( state -- )
+    [ changed-locs>> ] [ locs>vregs>> ] bi '[
+        _ at swap 2dup redundant-replace?
+        [ 2drop ] [ untranslate-loc ##replace ] if
+    ] assoc-each ;
+
+: clear-state ( state -- )
+    [ locs>vregs>> clear-assoc ]
+    [ actual-locs>vregs>> clear-assoc ]
+    [ changed-locs>> clear-assoc ]
+    tri ;
+
+ERROR: poisoned-state state ;
+
+: sync-state ( -- )
+    state get {
+        [ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
+        [ save-changed-locs ]
+        [ clear-state ]
+    } cleave ;
+
+: poison-state ( -- ) state get t >>poisoned? drop ;
+
+! Abstract interpretation
+GENERIC: visit ( insn -- )
+
+! Instructions which don't have any effect on the stack
+UNION: neutral-insn
+    ##flushable
+    ##effect ;
+
+M: neutral-insn visit , ;
+
+UNION: sync-if-back-edge
+    ##branch
+    ##conditional-branch
+    ##compare-imm-branch
+    ##dispatch
+    ##loop-entry ;
+
+SYMBOL: local-only?
+
+t local-only? set-global
+
+: back-edge? ( from to -- ? )
+    [ number>> ] bi@ > ;
+
+: sync-state? ( -- ? )
+    basic-block get successors>>
+    [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
+    local-only? get or ;
+
+M: sync-if-back-edge visit
+    sync-state? [ sync-state ] when , ;
+
+: adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
+
+M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
+
+: adjust-r ( n -- ) state get [ + ] change-rs-height drop ;
+
+M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
+
+: eliminate-peek ( dst src -- )
+    ! the requested stack location is already in 'src'
+    [ ##copy ] [ swap copies get set-at ] 2bi ;
+
+M: ##peek visit
+    dup
+    [ dst>> ] [ loc>> translate-loc ] bi
+    dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
+
+M: ##replace visit
+    [ src>> resolve ] [ loc>> translate-loc ] bi
+    record-replace ;
+
+M: ##copy visit
+    [ call-next-method ] [ record-copy ] bi ;
+
+M: ##call visit
+    [ call-next-method ] [ height>> adjust-d ] bi ;
+
+! Instructions that poison the stack state
+UNION: poison-insn
+    ##jump
+    ##return
+    ##callback-return
+    ##fixnum-mul-tail
+    ##fixnum-add-tail
+    ##fixnum-sub-tail ;
+
+M: poison-insn visit call-next-method poison-state ;
+
+! Instructions that kill all live vregs
+UNION: kill-vreg-insn
+    poison-insn
+    ##stack-frame
+    ##call
+    ##prologue
+    ##epilogue
+    ##fixnum-mul
+    ##fixnum-add
+    ##fixnum-sub
+    ##alien-invoke
+    ##alien-indirect ;
+
+M: kill-vreg-insn visit sync-state , ;
+
+: visit-alien-node ( node -- )
+    params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
+
+M: ##alien-invoke visit
+    [ call-next-method ] [ visit-alien-node ] bi ;
+
+M: ##alien-indirect visit
+    [ call-next-method ] [ visit-alien-node ] bi ;
+
+M: ##alien-callback visit , ;
+
+! Maps basic-blocks to states
+SYMBOLS: state-in state-out ;
+
+: initial-state ( bb states -- state ) 2drop <state> ;
+
+: single-predecessor ( bb states -- state ) nip first clone ;
+
+ERROR: must-equal-failed seq ;
+
+: must-equal ( seq -- elt )
+    dup all-equal? [ first ] [ must-equal-failed ] if ;
+
+: merge-heights ( state predecessors states -- state )
+    nip
+    [ [ ds-height>> ] map must-equal >>ds-height ]
+    [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
+
+: insert-peek ( predecessor loc -- vreg )
+    ! XXX critical edges
+    '[ _ ^^peek ] add-instructions ;
+
+: merge-loc ( predecessors locs>vregs loc -- vreg )
+    ! Insert a ##phi in the current block where the input
+    ! is the vreg storing loc from each predecessor block
+    [ '[ [ _ ] dip at ] map ] keep
+    '[ [ ] [ _ insert-peek ] ?if ] 2map
+    dup all-equal? [ first ] [ ^^phi ] if ;
+
+: (merge-locs) ( predecessors assocs -- assoc )
+    dup [ keys ] map concat prune
+    [ [ 2nip ] [ merge-loc ] 3bi ] with with
+    H{ } map>assoc ;
+
+: merge-locs ( state predecessors states -- state )
+    [ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
+
+: merge-loc' ( locs>vregs loc -- vreg )
+    ! Insert a ##phi in the current block where the input
+    ! is the vreg storing loc from each predecessor block
+    '[ [ _ ] dip at ] map
+    dup all-equal? [ first ] [ drop f ] if ;
+
+: merge-actual-locs ( state predecessors states -- state )
+    nip
+    [ actual-locs>vregs>> ] map
+    dup [ keys ] map concat prune
+    [ [ nip ] [ merge-loc' ] 2bi ] with
+    H{ } map>assoc
+    [ nip ] assoc-filter
+    >>actual-locs>vregs ;
+
+: merge-changed-locs ( state predecessors states -- state )
+    nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
+
+ERROR: cannot-merge-poisoned states ;
+
+: multiple-predecessors ( bb states -- state )
+    dup [ not ] any? [
+        [ <state> ] 2dip
+        sift merge-heights
+    ] [
+        dup [ poisoned?>> ] any? [
+            cannot-merge-poisoned
+        ] [
+            [ state new ] 2dip
+            [ predecessors>> ] dip
+            {
+                [ merge-locs ]
+                [ merge-actual-locs ]
+                [ merge-heights ]
+                [ merge-changed-locs ]
+            } 2cleave
+        ] if
+    ] if ;
+
+: merge-states ( bb states -- state )
+    ! If any states are poisoned, save all registers
+    ! to the stack in each branch
+    dup length {
+        { 0 [ initial-state ] }
+        { 1 [ single-predecessor ] }
+        [ drop multiple-predecessors ]
+    } case ;
+
+: block-in-state ( bb -- states )
+    dup predecessors>> state-out get '[ _ at ] map merge-states ;
+
+: set-block-in-state ( state bb -- )
+    [ clone ] dip state-in get set-at ;
+
+: 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
+        [ swap set-block-in-state ] [
+            state [
+                [ instructions>> [ visit ] each ]
+                [ [ state get ] dip set-block-out-state ]
+                [ ]
+                tri
+            ] with-variable
+        ] 2bi
+    ] V{ } make >>instructions drop ;
+
+: stack-analysis ( cfg -- cfg' )
+    [
+        H{ } clone copies set
+        H{ } clone state-in set
+        H{ } clone state-out set
+        dup [ visit-block ] each-basic-block
+    ] with-scope ;
diff --git a/basis/compiler/cfg/stack-frame/authors.txt b/basis/compiler/cfg/stack-frame/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/compiler/cfg/stack-frame/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor
index d545b6d15c..5cb5762b78 100644
--- a/basis/compiler/cfg/stack-frame/stack-frame.factor
+++ b/basis/compiler/cfg/stack-frame/stack-frame.factor
@@ -1,72 +1,55 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces accessors math.order assocs kernel sequences
-combinators make classes words cpu.architecture
-compiler.cfg.instructions compiler.cfg.registers ;
+USING: math math.order namespaces accessors kernel layouts combinators
+combinators.smart assocs sequences cpu.architecture ;
 IN: compiler.cfg.stack-frame
 
-SYMBOL: frame-required?
+TUPLE: stack-frame
+{ params integer }
+{ return integer }
+{ total-size integer }
+{ gc-root-size integer }
+spill-counts ;
 
-SYMBOL: spill-counts
+! Stack frame utilities
+: param-base ( -- n )
+    stack-frame get [ params>> ] [ return>> ] bi + ;
 
-GENERIC: compute-stack-frame* ( insn -- )
+: spill-float-offset ( n -- offset )
+    double-float-regs reg-size * ;
+
+: spill-integer-base ( -- n )
+    stack-frame get spill-counts>> double-float-regs [ swap at ] keep reg-size *
+    param-base + ;
+
+: spill-integer-offset ( n -- offset )
+    cells spill-integer-base + ;
+
+: spill-area-size ( stack-frame -- n )
+    spill-counts>> [ swap reg-size * ] { } assoc>map sum ;
+
+: gc-root-base ( -- n )
+    stack-frame get spill-area-size
+    param-base + ;
+
+: gc-root-offset ( n -- n' ) gc-root-base + ;
+
+: gc-roots-size ( live-registers live-spill-slots -- n )
+    [ keys [ reg-class>> reg-size ] sigma ] bi@ + ;
+
+: (stack-frame-size) ( stack-frame -- n )
+    [
+        {
+            [ spill-area-size ]
+            [ gc-root-size>> ]
+            [ params>> ]
+            [ return>> ]
+        } cleave
+    ] sum-outputs ;
 
 : max-stack-frame ( frame1 frame2 -- frame3 )
     [ stack-frame new ] 2dip
         [ [ params>> ] bi@ max >>params ]
         [ [ return>> ] bi@ max >>return ]
-        2bi ;
-
-M: ##stack-frame compute-stack-frame*
-    frame-required? on
-    stack-frame>> stack-frame [ max-stack-frame ] change ;
-
-M: ##call compute-stack-frame*
-    word>> sub-primitive>> [ frame-required? on ] unless ;
-
-M: _spill-counts compute-stack-frame*
-    counts>> stack-frame get (>>spill-counts) ;
-
-M: insn compute-stack-frame*
-    class frame-required? word-prop [
-        frame-required? on
-    ] when ;
-
-\ _gc t frame-required? set-word-prop
-\ _spill t frame-required? set-word-prop
-\ ##fixnum-add t frame-required? set-word-prop
-\ ##fixnum-sub t frame-required? set-word-prop
-\ ##fixnum-mul t frame-required? set-word-prop
-\ ##fixnum-add-tail f frame-required? set-word-prop
-\ ##fixnum-sub-tail f frame-required? set-word-prop
-\ ##fixnum-mul-tail f frame-required? set-word-prop
-
-: compute-stack-frame ( insns -- )
-    frame-required? off
-    T{ stack-frame } clone stack-frame set
-    [ compute-stack-frame* ] each
-    stack-frame get dup stack-frame-size >>total-size drop ;
-
-GENERIC: insert-pro/epilogues* ( insn -- )
-
-M: ##stack-frame insert-pro/epilogues* drop ;
-
-M: ##prologue insert-pro/epilogues*
-    drop frame-required? get [ stack-frame get _prologue ] when ;
-
-M: ##epilogue insert-pro/epilogues*
-    drop frame-required? get [ stack-frame get _epilogue ] when ;
-
-M: insn insert-pro/epilogues* , ;
-
-: insert-pro/epilogues ( insns -- insns )
-    [ [ insert-pro/epilogues* ] each ] { } make ;
-
-: build-stack-frame ( mr -- mr )
-    [
-        [
-            [ compute-stack-frame ]
-            [ insert-pro/epilogues ]
-            bi
-        ] change-instructions
-    ] with-scope ;
+        [ [ gc-root-size>> ] bi@ max >>gc-root-size ]
+        2tri ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor
index dabecaeec4..d30a02b0d3 100644
--- a/basis/compiler/cfg/two-operand/two-operand.factor
+++ b/basis/compiler/cfg/two-operand/two-operand.factor
@@ -1,40 +1,39 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel sequences compiler.utilities
-compiler.cfg.instructions cpu.architecture ;
+USING: accessors kernel sequences make compiler.cfg.instructions
+compiler.cfg.local cpu.architecture ;
 IN: compiler.cfg.two-operand
 
 ! On x86, instructions take the form x = x op y
 ! Our SSA IR is x = y op z
 
-! We don't bother with ##add, ##add-imm or ##sub-imm since x86
-! has a LEA instruction which is effectively a three-operand
-! addition
+! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
+! since x86 has LEA and IMUL instructions which are effectively
+! three-operand addition and multiplication, respectively.
 
-: make-copy ( dst src -- insn ) f \ ##copy boa ; inline
+: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline
 
-: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline
+: make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline
 
-: convert-two-operand/integer ( insn -- insns )
-    [ [ dst>> ] [ src1>> ] bi make-copy ]
-    [ dup dst>> >>src1 ]
-    bi 2array ; inline
+: convert-two-operand/integer ( insn -- )
+    [ [ dst>> ] [ src1>> ] bi ##copy ]
+    [ dup dst>> >>src1 , ]
+    bi ; inline
 
-: convert-two-operand/float ( insn -- insns )
-    [ [ dst>> ] [ src1>> ] bi make-copy/float ]
-    [ dup dst>> >>src1 ]
-    bi 2array ; inline
+: convert-two-operand/float ( insn -- )
+    [ [ dst>> ] [ src1>> ] bi ##copy-float ]
+    [ dup dst>> >>src1 , ]
+    bi ; inline
 
-GENERIC: convert-two-operand* ( insn -- insns )
+GENERIC: convert-two-operand* ( insn -- )
 
 M: ##not convert-two-operand*
-    [ [ dst>> ] [ src>> ] bi make-copy ]
-    [ dup dst>> >>src ]
-    bi 2array ;
+    [ [ dst>> ] [ src>> ] bi ##copy ]
+    [ dup dst>> >>src , ]
+    bi ;
 
 M: ##sub convert-two-operand* convert-two-operand/integer ;
 M: ##mul convert-two-operand* convert-two-operand/integer ;
-M: ##mul-imm convert-two-operand* convert-two-operand/integer ;
 M: ##and convert-two-operand* convert-two-operand/integer ;
 M: ##and-imm convert-two-operand* convert-two-operand/integer ;
 M: ##or convert-two-operand* convert-two-operand/integer ;
@@ -50,11 +49,11 @@ M: ##sub-float convert-two-operand* convert-two-operand/float ;
 M: ##mul-float convert-two-operand* convert-two-operand/float ;
 M: ##div-float convert-two-operand* convert-two-operand/float ;
 
-M: insn convert-two-operand* ;
+M: insn convert-two-operand* , ;
 
-: convert-two-operand ( mr -- mr' )
-    [
-        two-operand? [
-            [ convert-two-operand* ] map-flat
-        ] when
-    ] change-instructions ;
+: convert-two-operand ( cfg -- cfg' )
+    two-operand? [
+        [ drop ]
+        [ [ [ convert-two-operand* ] each ] V{ } make ]
+        local-optimization
+    ] when ;
diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
new file mode 100644
index 0000000000..1d14cef193
--- /dev/null
+++ b/basis/compiler/cfg/useless-blocks/useless-blocks-tests.factor
@@ -0,0 +1,11 @@
+IN: compiler.cfg.useless-blocks.tests
+USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
+compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
+
+{
+    [ [ drop 1 ] when ]
+    [ [ drop 1 ] unless ]
+} [
+    [ [ ] ] dip
+    '[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
+] each
\ No newline at end of file
diff --git a/basis/compiler/cfg/useless-blocks/useless-blocks.factor b/basis/compiler/cfg/useless-blocks/useless-blocks.factor
index 05cb13748b..cbe006b4d7 100644
--- a/basis/compiler/cfg/useless-blocks/useless-blocks.factor
+++ b/basis/compiler/cfg/useless-blocks/useless-blocks.factor
@@ -1,10 +1,12 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences combinators classes vectors
-compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
+USING: kernel accessors sequences combinators combinators.short-circuit
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
 IN: compiler.cfg.useless-blocks
 
 : update-predecessor-for-delete ( 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
@@ -12,9 +14,13 @@ IN: compiler.cfg.useless-blocks
     ] change-successors drop ;
 
 : update-successor-for-delete ( bb -- )
-    [ predecessors>> first ]
-    [ successors>> first predecessors>> ]
-    bi set-first ;
+    ! 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-for-delete ]
@@ -23,17 +29,17 @@ IN: compiler.cfg.useless-blocks
 
 : delete-basic-block? ( bb -- ? )
     {
-        { [ dup instructions>> length 1 = not ] [ f ] }
-        { [ dup predecessors>> length 1 = not ] [ f ] }
-        { [ dup successors>> length 1 = not ] [ f ] }
-        { [ dup instructions>> first ##branch? not ] [ f ] }
-        [ t ]
-    } cond nip ;
+        [ instructions>> length 1 = ]
+        [ predecessors>> length 1 = ]
+        [ successors>> length 1 = ]
+        [ instructions>> first ##branch? ]
+    } 1&& ;
 
 : delete-useless-blocks ( cfg -- cfg' )
     dup [
         dup delete-basic-block? [ delete-basic-block ] [ drop ] if
-    ] each-basic-block ;
+    ] each-basic-block
+    f >>post-order ;
 
 : delete-conditional? ( bb -- ? )
     dup instructions>> [ drop f ] [
@@ -46,10 +52,11 @@ IN: compiler.cfg.useless-blocks
 
 : delete-conditional ( bb -- )
     dup successors>> first 1vector >>successors
-    [ but-last f \ ##branch boa suffix ] change-instructions
+    [ but-last \ ##branch new-insn suffix ] change-instructions
     drop ;
 
 : delete-useless-conditionals ( cfg -- cfg' )
     dup [
         dup delete-conditional? [ delete-conditional ] [ drop ] if
-    ] each-basic-block ;
+    ] each-basic-block
+    f >>post-order ;
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index 99a138a763..e415008808 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -35,5 +35,8 @@ IN: compiler.cfg.utilities
 
 : stop-iterating ( -- next ) end-basic-block f ;
 
+: call-height ( ##call -- n )
+    [ out-d>> length ] [ in-d>> length ] bi - ;
+
 : emit-primitive ( node -- )
-    word>> ##call ##branch begin-basic-block ;
+    [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index cc790c6c0a..bf750231c7 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -22,17 +22,17 @@ M: constant-expr equal?
         and
     ] [ 2drop f ] if ;
 
-SYMBOL: input-expr-counter
-
-: next-input-expr ( -- n )
-    input-expr-counter [ dup 1 + ] change ;
-
 ! Expressions whose values are inputs to the basic block. We
 ! can eliminate a second computation having the same 'n' as
 ! the first one; we can also eliminate input-exprs whose
 ! result is not used.
 TUPLE: input-expr < expr n ;
 
+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 )
@@ -80,7 +80,7 @@ M: ##compare-imm >expr compare-imm>expr ;
 
 M: ##compare-float >expr compare>expr ;
 
-M: ##flushable >expr class next-input-expr input-expr boa ;
+M: ##flushable >expr class next-input-expr ;
 
 : init-expressions ( -- )
     0 input-expr-counter set ;
diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
index 990543ed7a..7630d0a658 100644
--- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
+++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
@@ -13,7 +13,7 @@ GENERIC: rewrite ( insn -- insn' )
 
 M: ##mul-imm rewrite
     dup src2>> dup power-of-2? [
-        [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa
+        [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
         dup number-values
     ] [ drop ] if ;
 
@@ -36,9 +36,9 @@ M: ##mul-imm rewrite
 
 : rewrite-boolean-comparison ( expr -- insn )
     src1>> vreg>expr dup op>> {
-        { \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
-        { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
-        { \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
+        { \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
+        { \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
+        { \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
     } case ;
 
 : tag-fixnum-expr? ( expr -- ? )
@@ -60,11 +60,11 @@ M: ##mul-imm rewrite
 GENERIC: rewrite-tagged-comparison ( insn -- insn' )
 
 M: ##compare-imm-branch rewrite-tagged-comparison
-    (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
+    (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
 
 M: ##compare-imm rewrite-tagged-comparison
     [ dst>> ] [ (rewrite-tagged-comparison) ] bi
-    i f \ ##compare-imm boa ;
+    i \ ##compare-imm new-insn ;
 
 M: ##compare-imm-branch rewrite
     dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
@@ -79,7 +79,7 @@ M: ##compare-imm-branch rewrite
     [ dst>> ]
     [ src2>> ]
     [ src1>> vreg>vn vn>constant ] tri
-    cc= f i \ ##compare-imm boa ;
+    cc= i \ ##compare-imm new-insn ;
 
 M: ##compare rewrite
     dup flip-comparison? [
@@ -96,9 +96,9 @@ M: ##compare rewrite
 
 : rewrite-redundant-comparison ( insn -- insn' )
     [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
-        { \ ##compare [ >compare-expr< i f \ ##compare boa ] }
-        { \ ##compare-imm [ >compare-imm-expr< i f \ ##compare-imm boa ] }
-        { \ ##compare-float [ >compare-expr< i f \ ##compare-float boa ] }
+        { \ ##compare [ >compare-expr< i \ ##compare new-insn ] }
+        { \ ##compare-imm [ >compare-imm-expr< i \ ##compare-imm new-insn ] }
+        { \ ##compare-float [ >compare-expr< i \ ##compare-float new-insn ] }
     } case
     swap cc= eq? [ [ negate-cc ] change-cc ] when ;
 
@@ -114,18 +114,4 @@ M: ##compare-imm rewrite
         ] when
     ] when ;
 
-: dispatch-offset ( expr -- n )
-    [ in2>> vn>constant tag-bits get neg shift ] [ op>> ] bi
-    \ ##sub-imm eq? [ neg ] when ;
-
-: add-dispatch-offset? ( insn -- expr ? )
-    src>> vreg>expr dup op>> { ##add-imm ##sub-imm } memq? ; inline
-
-M: ##dispatch rewrite
-    dup add-dispatch-offset? [
-        [ clone ] dip
-        [ in1>> vn>vreg >>src ]
-        [ dispatch-offset '[ _ + ] change-offset ] bi
-    ] [ drop ] if ;
-
 M: insn rewrite ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index abd2720817..5063273bf4 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -2,7 +2,7 @@ IN: compiler.cfg.value-numbering.tests
 USING: compiler.cfg.value-numbering compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger cpu.architecture
 tools.test kernel math combinators.short-circuit accessors
-sequences ;
+sequences compiler.cfg vectors arrays ;
 
 : trim-temps ( insns -- insns )
     [
@@ -13,6 +13,10 @@ sequences ;
         } 1|| [ f >>temp ] when
     ] map ;
 
+: test-value-numbering ( insns -- insns )
+    { } init-value-numbering
+    value-numbering-step ;
+
 [
     {
         T{ ##peek f V int-regs 45 D 1 }
@@ -24,7 +28,7 @@ sequences ;
         T{ ##peek f V int-regs 45 D 1 }
         T{ ##copy f V int-regs 48 V int-regs 45 }
         T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
-    } value-numbering
+    } test-value-numbering
 ] unit-test
 
 [
@@ -40,14 +44,14 @@ sequences ;
         T{ ##peek f V int-regs 3 D 0 }
         T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
         T{ ##replace f V int-regs 4 D 0 }
-    } value-numbering
+    } test-value-numbering
 ] unit-test
 
 [ t ] [
     {
         T{ ##peek f V int-regs 1 D 0 }
-        T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
-    } dup value-numbering =
+        T{ ##dispatch f V int-regs 1 V int-regs 2 }
+    } dup test-value-numbering =
 ] unit-test
 
 [ t ] [
@@ -60,7 +64,7 @@ sequences ;
         T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
         T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
         T{ ##replace f V int-regs 23 D 0 }
-    } dup value-numbering =
+    } dup test-value-numbering =
 ] unit-test
 
 [
@@ -76,7 +80,7 @@ sequences ;
         T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
         T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
         T{ ##replace f V int-regs 3 D 0 }
-    } value-numbering
+    } test-value-numbering
 ] unit-test
 
 [
@@ -94,7 +98,7 @@ sequences ;
         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 }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
 ] unit-test
 
 [
@@ -112,7 +116,7 @@ sequences ;
         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 }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
 ] unit-test
 
 [
@@ -134,7 +138,7 @@ sequences ;
         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 }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
 ] unit-test
 
 [
@@ -150,5 +154,18 @@ sequences ;
         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/= }
-    } value-numbering trim-temps
+    } test-value-numbering trim-temps
+] unit-test
+
+[
+    {
+        T{ ##copy f V int-regs 48 V int-regs 45 }
+        T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
+    }
+] [
+    { V int-regs 45 } init-value-numbering
+    {
+        T{ ##copy f V int-regs 48 V int-regs 45 }
+        T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
+    } value-numbering-step
 ] unit-test
diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor
index d17b2a7e1f..9f5473c62f 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering.factor
@@ -2,6 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs biassocs classes kernel math accessors
 sorting sets sequences
+compiler.cfg.local
+compiler.cfg.liveness
 compiler.cfg.value-numbering.graph
 compiler.cfg.value-numbering.expressions
 compiler.cfg.value-numbering.propagate
@@ -9,7 +11,16 @@ compiler.cfg.value-numbering.simplify
 compiler.cfg.value-numbering.rewrite ;
 IN: compiler.cfg.value-numbering
 
-: value-numbering ( insns -- insns' )
+: number-input-values ( live-in -- )
+    [ [ f next-input-expr simplify ] dip set-vn ] each ;
+
+: init-value-numbering ( live-in -- )
     init-value-graph
     init-expressions
+    number-input-values ;
+
+: value-numbering-step ( insns -- insns' )
     [ [ number-values ] [ rewrite propagate ] bi ] map ;
+
+: value-numbering ( cfg -- cfg' )
+    [ init-value-numbering ] [ value-numbering-step ] local-optimization ;
diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
index 73748dbc37..c1a667c004 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor
@@ -1,8 +1,11 @@
 USING: compiler.cfg.write-barrier compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-arrays tools.test ;
+arrays tools.test vectors compiler.cfg kernel accessors ;
 IN: compiler.cfg.write-barrier.tests
 
+: test-write-barrier ( insns -- insns )
+    write-barriers-step ;
+
 [
     {
         T{ ##peek f V int-regs 4 D 0 f }
@@ -24,7 +27,7 @@ IN: compiler.cfg.write-barrier.tests
         T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
         T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
         T{ ##replace f V int-regs 7 D 0 }
-    } eliminate-write-barriers
+    } test-write-barrier
 ] unit-test
 
 [
@@ -42,7 +45,7 @@ IN: compiler.cfg.write-barrier.tests
         T{ ##peek f V int-regs 6 D -2 }
         T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
         T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
-    } eliminate-write-barriers
+    } test-write-barrier
 ] unit-test
 
 [
@@ -69,5 +72,5 @@ IN: compiler.cfg.write-barrier.tests
         T{ ##copy f V int-regs 29 V int-regs 19 }
         T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
         T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
-    } eliminate-write-barriers
+    } 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 4a55cb3266..b260b0464e 100644
--- a/basis/compiler/cfg/write-barrier/write-barrier.factor
+++ b/basis/compiler/cfg/write-barrier/write-barrier.factor
@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! 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 compiler.cfg.instructions compiler.cfg.copy-prop
+compiler.cfg.liveness compiler.cfg.local ;
 IN: compiler.cfg.write-barrier
 
 ! Eliminate redundant write barrier hits.
@@ -35,8 +36,11 @@ M: ##set-slot-imm eliminate-write-barrier
 
 M: insn eliminate-write-barrier ;
 
-: eliminate-write-barriers ( insns -- insns' )
+: write-barriers-step ( insns -- insns' )
     H{ } clone safe set
     H{ } clone mutated set
     H{ } clone copies set
     [ eliminate-write-barrier ] map sift ;
+
+: eliminate-write-barriers ( cfg -- cfg' )
+    [ drop ] [ write-barriers-step ] local-optimization ;
diff --git a/basis/compiler/codegen/codegen-tests.factor b/basis/compiler/codegen/codegen-tests.factor
new file mode 100644
index 0000000000..9c3817bad6
--- /dev/null
+++ b/basis/compiler/codegen/codegen-tests.factor
@@ -0,0 +1,14 @@
+IN: compiler.codegen.tests
+USING: compiler.codegen.fixup tools.test cpu.architecture math kernel make
+compiler.constants ;
+
+[ ] [ [ ] with-fixup drop ] unit-test
+[ ] [ [ \ + %call ] with-fixup drop ] unit-test
+
+[ ] [ [ <label> dup define-label dup resolve-label %jump-label ] with-fixup drop ] unit-test
+[ ] [ [ <label> dup define-label dup resolve-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup drop ] unit-test
+
+! Error checking
+[ [ <label> dup define-label %jump-label ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-relative label-fixup ] with-fixup ] must-fail
+[ [ <label> dup define-label B{ 0 0 0 0 } % rc-absolute-cell label-fixup ] with-fixup ] must-fail
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index c7b67b72b4..a1583d2a5d 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -8,8 +8,10 @@ continuations.private fry cpu.architecture
 source-files.errors
 compiler.errors
 compiler.alien
+compiler.constants
 compiler.cfg
 compiler.cfg.instructions
+compiler.cfg.stack-frame
 compiler.cfg.registers
 compiler.cfg.builder
 compiler.codegen.fixup
@@ -26,14 +28,6 @@ SYMBOL: registers
 : ?register ( obj -- operand )
     dup vreg? [ register ] when ;
 
-: generate-insns ( insns -- code )
-    [
-        [
-            dup regs>> registers set
-            generate-insn
-        ] each
-    ] { } make fixup ;
-
 TUPLE: asm label code calls ;
 
 SYMBOL: calls
@@ -51,17 +45,22 @@ SYMBOL: labels
 
 : init-generator ( word -- )
     H{ } clone labels set
-    V{ } clone literal-table set
     V{ } clone calls set
     compiling-word set
     compiled-stack-traces? [ compiling-word get add-literal ] when ;
 
+: generate-insns ( asm -- code )
+    [
+        [ word>> init-generator ]
+        [
+            instructions>>
+            [ [ regs>> registers set ] [ generate-insn ] bi ] each
+        ] bi
+    ] with-fixup ;
+
 : generate ( mr -- asm )
     [
-        [ label>> ]
-        [ word>> init-generator ]
-        [ instructions>> generate-insns ] tri
-        calls get
+        [ label>> ] [ generate-insns ] bi calls get
         asm boa
     ] with-scope ;
 
@@ -92,10 +91,13 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
 
 M: ##return generate-insn drop %return ;
 
-M: ##dispatch-label generate-insn label>> %dispatch-label ;
+M: _dispatch generate-insn
+    [ src>> register ] [ temp>> register ] bi %dispatch ;
 
-M: ##dispatch generate-insn
-    [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
+M: _dispatch-label generate-insn
+    label>> lookup-label
+    cell 0 <repetition> %
+    rc-absolute-cell label-fixup ;
 
 : >slot< ( insn -- dst obj slot tag )
     {
@@ -236,7 +238,13 @@ M: ##write-barrier generate-insn
     [ table>> register ]
     tri %write-barrier ;
 
-M: _gc generate-insn drop %gc ;
+M: _gc generate-insn
+    {
+        [ temp1>> register ]
+        [ temp2>> register ]
+        [ gc-roots>> ]
+        [ gc-root-count>> ]
+    } cleave %gc ;
 
 M: ##loop-entry generate-insn drop %loop-entry ;
 
@@ -245,16 +253,6 @@ M: ##alien-global generate-insn
     %alien-global ;
 
 ! ##alien-invoke
-GENERIC: reg-size ( register-class -- n )
-
-M: int-regs reg-size drop cell ;
-
-M: single-float-regs reg-size drop 4 ;
-
-M: double-float-regs reg-size drop 8 ;
-
-M: stack-params reg-size drop "void*" heap-size ;
-
 GENERIC: reg-class-variable ( register-class -- symbol )
 
 M: reg-class reg-class-variable ;
@@ -486,7 +484,7 @@ M: _epilogue generate-insn
     stack-frame>> total-size>> %epilogue ;
 
 M: _label generate-insn
-    id>> lookup-label , ;
+    id>> lookup-label resolve-label ;
 
 M: _branch generate-insn
     label>> lookup-label %jump-label ;
@@ -533,4 +531,10 @@ M: _reload generate-insn
         { double-float-regs [ %reload-float ] }
     } case ;
 
+M: _copy generate-insn
+    [ dst>> ] [ src>> ] [ class>> ] tri {
+        { int-regs [ %copy ] }
+        { double-float-regs [ %copy-float ] }
+    } case ;
+
 M: _spill-counts generate-insn drop ;
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index d0c874feb0..d44f6afd99 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -4,48 +4,48 @@ USING: arrays byte-arrays byte-vectors generic assocs hashtables
 io.binary kernel kernel.private math namespaces make sequences
 words quotations strings alien.accessors alien.strings layouts
 system combinators math.bitwise math.order
-accessors growable cpu.architecture compiler.constants ;
+accessors growable compiler.constants ;
 IN: compiler.codegen.fixup
 
-GENERIC: fixup* ( obj -- )
+! Literal table
+SYMBOL: literal-table
+
+: add-literal ( obj -- ) literal-table get push ;
+
+! Labels
+SYMBOL: label-table
+
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
 
 : compiled-offset ( -- n ) building get length ;
 
+: resolve-label ( label/name -- )
+    dup label? [ get ] unless
+    compiled-offset >>offset drop ;
+
+: offset-for-class ( class -- n )
+    rc-absolute-cell = cell 4 ? compiled-offset swap - ;
+
+TUPLE: label-fixup { label label } { class integer } { offset integer } ;
+
+: label-fixup ( label class -- )
+    dup offset-for-class \ label-fixup boa label-table get push ;
+
+! Relocation table
 SYMBOL: relocation-table
-SYMBOL: label-table
-
-M: label fixup* compiled-offset >>offset drop ;
-
-TUPLE: label-fixup label class ;
-
-: label-fixup ( label class -- ) \ label-fixup boa , ;
-
-M: label-fixup fixup*
-    dup class>> rc-absolute?
-    [ "Absolute labels not supported" throw ] when
-    [ class>> ] [ label>> ] bi compiled-offset 4 - swap
-    3array label-table get push ;
-
-TUPLE: rel-fixup class type ;
-
-: rel-fixup ( class type -- ) \ rel-fixup boa , ;
 
 : push-4 ( value vector -- )
     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
     swap set-alien-unsigned-4 ;
 
-M: rel-fixup fixup*
-    [ type>> ]
-    [ class>> ]
-    [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] tri
-    { 0 24 28 } bitfield
-    relocation-table get push-4 ;
+: add-relocation-entry ( type class offset -- )
+    { 0 24 28 } bitfield relocation-table get push-4 ;
 
-M: integer fixup* , ;
-
-SYMBOL: literal-table
-
-: add-literal ( obj -- ) literal-table get push ;
+: rel-fixup ( class type -- )
+    swap dup offset-for-class add-relocation-entry ;
 
 : add-dlsym-literals ( symbol dll -- )
     [ string>symbol add-literal ] [ add-literal ] bi* ;
@@ -74,22 +74,34 @@ SYMBOL: literal-table
 : rel-here ( offset class -- )
     [ add-literal ] dip rt-here rel-fixup ;
 
+! And the rest
+: resolve-offset ( label-fixup -- offset )
+    label>> offset>> [ "Unresolved label" throw ] unless* ;
+
+: resolve-absolute-label ( label-fixup -- )
+    dup resolve-offset neg add-literal
+    [ rt-here ] dip [ class>> ] [ offset>> ] bi add-relocation-entry ;
+
+: resolve-relative-label ( label-fixup -- label )
+    [ class>> ] [ offset>> ] [ resolve-offset ] tri 3array ;
+
+: resolve-labels ( label-fixups -- labels' )
+    [ class>> rc-absolute? ] partition
+    [ [ resolve-absolute-label ] each ]
+    [ [ resolve-relative-label ] map concat ]
+    bi* ;
+
 : init-fixup ( -- )
-    BV{ } clone relocation-table set
-    V{ } clone label-table set ;
+    V{ } clone literal-table set
+    V{ } clone label-table set
+    BV{ } clone relocation-table set ;
 
-: resolve-labels ( labels -- labels' )
-    [
-        first3 offset>>
-        [ "Unresolved label" throw ] unless*
-        3array
-    ] map concat ;
-
-: fixup ( fixup-directives -- code )
+: with-fixup ( quot -- code )
     [
         init-fixup
-        [ fixup* ] each
+        call
+        label-table [ resolve-labels ] change
         literal-table get >array
         relocation-table get >byte-array
-        label-table get resolve-labels
-    ] B{ } make 4array ;
+        label-table get
+    ] B{ } make 4array ; inline
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index c3d70fdc5b..6d0f6f3ace 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -3,13 +3,20 @@
 USING: accessors kernel namespaces arrays sequences io words fry
 continuations vocabs assocs dlists definitions math graphs generic
 generic.single combinators deques search-deques macros
-source-files.errors stack-checker stack-checker.state
-stack-checker.inlining stack-checker.errors combinators.short-circuit
-compiler.errors compiler.units compiler.tree.builder
-compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
-compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
-compiler.utilities ;
+source-files.errors combinators.short-circuit
+
+stack-checker stack-checker.state stack-checker.inlining stack-checker.errors
+
+compiler.errors compiler.units compiler.utilities
+
+compiler.tree.builder
+compiler.tree.optimizer
+
+compiler.cfg.builder
+compiler.cfg.optimizer
+compiler.cfg.mr
+
+compiler.codegen ;
 IN: compiler
 
 SYMBOL: compile-queue
@@ -89,11 +96,11 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
 : not-compiled-def ( word error -- def )
     '[ _ _ not-compiled ] [ ] like ;
 
+: deoptimize* ( word -- * )
+    dup def>> deoptimize-with ;
+
 : ignore-error ( word error -- * )
-    drop
-    [ clear-compiler-error ]
-    [ dup def>> deoptimize-with ]
-    bi ;
+    drop [ clear-compiler-error ] [ deoptimize* ] bi ;
 
 : remember-error ( word error -- * )
     [ swap <compiler-error> compiler-error ]
@@ -117,13 +124,13 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
 : contains-breakpoints? ( -- ? )
     dependencies get keys [ "break?" word-prop ] any? ;
 
-: frontend ( word -- nodes )
+: frontend ( word -- tree )
     #! If the word contains breakpoints, don't optimize it, since
     #! the walker does not support this.
     dup optimize? [
         [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
-        contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
-    ] [ dup def>> deoptimize-with ] if ;
+        contains-breakpoints? [ nip deoptimize* ] [ drop ] if
+    ] [ deoptimize* ] if ;
 
 : compile-dependency ( word -- )
     #! If a word calls an unoptimized word, try to compile the callee.
@@ -143,13 +150,10 @@ t compile-dependencies? set-global
     [ compile-dependencies ]
     bi ;
 
-: backend ( nodes word -- )
+: backend ( tree word -- )
     build-cfg [
         optimize-cfg
         build-mr
-        convert-two-operand
-        linear-scan
-        build-stack-frame
         generate
         save-asm
     ] each ;
@@ -189,7 +193,8 @@ M: optimizing-compiler recompile ( words -- alist )
         ] each
         compile-queue get compile-loop
         compiled get >alist
-    ] with-scope ;
+    ] with-scope
+    "trace-compilation" get [ "--- compile done" print flush ] when ;
 
 : with-optimizer ( quot -- )
     [ optimizing-compiler compiler-impl ] dip with-variable ; inline
diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor
index e0bc917f1c..36ee5eb94d 100644
--- a/basis/compiler/tests/codegen.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -2,7 +2,7 @@ USING: generalizations accessors arrays compiler kernel kernel.private
 math hashtables.private math.private namespaces sequences tools.test
 namespaces.private slots.private sequences.private byte-arrays alien
 alien.accessors layouts words definitions compiler.units io
-combinators vectors grouping make ;
+combinators vectors grouping make alien.c-types ;
 QUALIFIED: namespaces.private
 IN: compiler.tests.codegen
 
@@ -282,3 +282,32 @@ TUPLE: cucumber ;
 M: cucumber equal? "The cucumber has no equal" throw ;
 
 [ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
+
+[ 4294967295 B{ 255 255 255 255 } -1 ]
+[
+    -1 <int> -1 <int>
+    [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
+    compile-call
+] unit-test
+
+! Regression found while working on global register allocation
+
+: linear-scan-regression-1 ( a b c -- ) 3array , ;
+: linear-scan-regression-2 ( a b -- ) 2array , ;
+
+: linear-scan-regression ( a b c -- )
+    [ linear-scan-regression-2 ]
+    [ linear-scan-regression-1 ]
+    bi-curry bi-curry interleave ;
+
+[
+    {
+        { 1 "x" "y" }
+        { "x" "y" }
+        { 2 "x" "y" }
+        { "x" "y" }
+        { 3 "x" "y" }
+    }
+] [
+    [ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
+] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 708992f918..2688f7f8f1 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -327,4 +327,11 @@ C: <ro-box> ro-box
 
 TUPLE: empty-tuple ;
 
-[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
\ No newline at end of file
+[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
+
+! Make sure that initial-quot: doesn't inhibit unboxing
+TUPLE: initial-quot-tuple { x read-only initial-quot: [ 0 ] } ;
+
+[ 1 ] [
+    [ initial-quot-tuple new x>> ] count-unboxed-allocations
+] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor
index fe3c7acb92..d1f5b03be0 100644
--- a/basis/compiler/tree/optimizer/optimizer.factor
+++ b/basis/compiler/tree/optimizer/optimizer.factor
@@ -25,18 +25,20 @@ SYMBOL: check-optimizer?
     ] when ;
 
 : optimize-tree ( nodes -- nodes' )
-    analyze-recursive
-    normalize
-    propagate
-    cleanup
-    dup run-escape-analysis? [
-        escape-analysis
-        unbox-tuples
-    ] when
-    apply-identities
-    compute-def-use
-    remove-dead-code
-    ?check
-    compute-def-use
-    optimize-modular-arithmetic
-    finalize ;
+    [
+        analyze-recursive
+        normalize
+        propagate
+        cleanup
+        dup run-escape-analysis? [
+            escape-analysis
+            unbox-tuples
+        ] when
+        apply-identities
+        compute-def-use
+        remove-dead-code
+        ?check
+        compute-def-use
+        optimize-modular-arithmetic
+        finalize
+    ] with-scope ;
diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor
index 6ef9c2fabc..9ece36e6cd 100755
--- a/basis/compression/huffman/huffman.factor
+++ b/basis/compression/huffman/huffman.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Marc Fauconneau.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs constructors fry
+USING: accessors arrays assocs fry
 hashtables io kernel locals math math.order math.parser
 math.ranges multiline sequences ;
 IN: compression.huffman
@@ -58,7 +58,10 @@ TUPLE: huffman-decoder
     { rtable }
     { bits/level } ;
 
-CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )
+: <huffman-decoder> ( bs tdesc -- decoder )
+    huffman-decoder new
+    swap >>tdesc
+    swap >>bs
     16 >>bits/level
     [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;
 
diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor
old mode 100755
new mode 100644
index 7cb43ac68f..05ec94a794
--- a/basis/compression/inflate/inflate.factor
+++ b/basis/compression/inflate/inflate.factor
@@ -1,212 +1,220 @@
-! Copyright (C) 2009 Marc Fauconneau.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs byte-arrays
-byte-vectors combinators constructors fry grouping hashtables
-compression.huffman images io.binary kernel locals
-math math.bitwise math.order math.ranges multiline sequences
-sorting ;
-IN: compression.inflate
-
-QUALIFIED-WITH: bitstreams bs
-
-<PRIVATE
-
-: enum>seq ( assoc -- seq )
-    dup keys [ ] [ max ] map-reduce 1 + f <array>
-    [ '[ swap _ set-nth ] assoc-each ] keep ;
-
-ERROR: zlib-unimplemented ;
-ERROR: bad-zlib-data ;
-ERROR: bad-zlib-header ;
-    
-:: check-zlib-header ( data -- )
-    16 data bs:peek 2 >le be> 31 mod    ! checksum
-    0 assert=                           
-    4 data bs:read 8 assert=            ! compression method: deflate
-    4 data bs:read                      ! log2(max length)-8, 32K max
-    7 <= [ bad-zlib-header ] unless     
-    5 data bs:seek                      ! drop check bits 
-    1 data bs:read 0 assert=            ! dictionnary - not allowed in png
-    2 data bs:seek                      ! compression level; ignore
-    ;
-
-:: default-table ( -- table )
-    0 <hashtable> :> table
-    0 143 [a,b] 280 287 [a,b] append 8 table set-at
-    144 255 [a,b] >array 9 table set-at
-    256 279 [a,b] >array 7 table set-at 
-    table enum>seq 1 tail ;
-
-CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
-
-: get-table ( values size -- table ) 
-    16 f <array> clone <enum> 
-    [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
-
-:: decode-huffman-tables ( bitstream -- tables )
-    5 bitstream bs:read 257 +
-    5 bitstream bs:read 1 +
-    4 bitstream bs:read 4 +
-    clen-shuffle swap head
-    dup [ drop 3 bitstream bs:read ] map
-    get-table
-    bitstream swap <huffman-decoder> 
-    [ 2dup + ] dip swap :> k!
-    '[
-        _ read1-huff2
-        {
-            { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
-            { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
-            { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
-            [ ]
-        } cond
-        dup array? [ dup second ] [ 1 ] if
-        k swap - dup k! 0 >
-    ] 
-    [ ] produce swap suffix
-    { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
-    [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
-    nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
-    
-CONSTANT: length-table
-    {
-        3 4 5 6 7 8 9 10
-        11 13 15 17
-        19 23 27 31
-        35 43 51 59
-        67 83 99 115
-        131 163 195 227 258
-    }
-
-CONSTANT: dist-table
-    {
-        1 2 3 4 
-        5 7 9 13 
-        17 25 33 49
-        65 97 129 193
-        257 385 513 769
-        1025 1537 2049 3073
-        4097 6145 8193 12289
-        16385 24577
-    }
-
-: nth* ( n seq -- elt )
-    [ length 1- swap - ] [ nth ] bi ;
-
-:: inflate-lz77 ( seq -- bytes )
-    1000 <byte-vector> :> bytes
-    seq
-    [
-        dup array?
-        [ first2 '[ _ 1- bytes nth* bytes push ] times ]
-        [ bytes push ] if
-    ] each 
-    bytes ;
-
-:: inflate-dynamic ( bitstream -- bytes )
-    bitstream decode-huffman-tables
-    bitstream '[ _ swap <huffman-decoder> ] map :> tables
-    [
-        tables first read1-huff2
-        dup 256 >
-        [
-            dup 285 = 
-            [ ]
-            [ 
-                dup 264 > 
-                [ 
-                    dup 261 - 4 /i dup 5 > 
-                    [ bad-zlib-data ] when 
-                    bitstream bs:read 2array 
-                ]
-                when 
-            ] if
-            ! 5 bitstream read-bits ! distance
-            tables second read1-huff2
-            dup 3 > 
-            [ 
-                dup 2 - 2 /i dup 13 >
-                [ bad-zlib-data ] when
-                bitstream bs:read 2array
-            ] 
-            when
-            2array
-        ]
-        when
-        dup 256 = not
-    ]
-    [ ] produce nip
-    [
-        dup array? [
-            first2
-            [  
-                dup array? [ first2 ] [ 0 ] if
-                [ 257 - length-table nth ] [ + ] bi*
-            ] 
-            [
-                dup array? [ first2 ] [ 0 ] if
-                [ dist-table nth ] [ + ] bi*
-            ] bi*
-            2array
-        ] when
-    ] map ;
-    
-: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;
-: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
-
-:: inflate-loop ( bitstream -- bytes )
-    [ 1 bitstream bs:read 0 = ]
-    [
-        bitstream
-        2 bitstream bs:read
-        { 
-            { 0 [ inflate-raw ] }
-            { 1 [ inflate-static ] }
-            { 2 [ inflate-dynamic ] }
-            { 3 [ bad-zlib-data f ] }
-        }
-        case
-    ]
-    [ produce ] keep call suffix concat ;
-    
-  !  [ produce ] keep dip swap suffix
-
-:: paeth ( a b c -- p ) 
-    a b + c - { a b c } [ [ - abs ] keep 2array ] with map 
-    sort-keys first second ;
-    
-:: png-unfilter-line ( prev curr filter -- curr' )
-    prev :> c
-    prev 3 tail-slice :> b
-    curr :> a
-    curr 3 tail-slice :> x
-    x length [0,b)
-    filter
-    {
-        { 0 [ drop ] }
-        { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
-        { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
-        { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
-        { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
-        
-    } case 
-    curr 3 tail ;
-
-PRIVATE>
-
-! for debug -- shows residual values
-: reverse-png-filter' ( lines -- filtered )
-    [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
-    concat [ 128 + 256 wrap ] map ;
-    
-: reverse-png-filter ( lines -- filtered )
-    dup first [ 0 ] replicate prefix
-    [ { 0 0 } prepend  ] map
-    2 clump [
-        first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
-    ] map concat ;
-
-: zlib-inflate ( bytes -- bytes )
-    bs:<lsb0-bit-reader>
-    [ check-zlib-header ] [ inflate-loop ] bi
-    inflate-lz77 ;
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs byte-arrays
+byte-vectors combinators fry grouping hashtables
+compression.huffman images io.binary kernel locals
+math math.bitwise math.order math.ranges multiline sequences
+sorting ;
+IN: compression.inflate
+
+QUALIFIED-WITH: bitstreams bs
+
+<PRIVATE
+
+: enum>seq ( assoc -- seq )
+    dup keys [ ] [ max ] map-reduce 1 + f <array>
+    [ '[ swap _ set-nth ] assoc-each ] keep ;
+
+ERROR: zlib-unimplemented ;
+ERROR: bad-zlib-data ;
+ERROR: bad-zlib-header ;
+    
+:: check-zlib-header ( data -- )
+    16 data bs:peek 2 >le be> 31 mod    ! checksum
+    0 assert=                           
+    4 data bs:read 8 assert=            ! compression method: deflate
+    4 data bs:read                      ! log2(max length)-8, 32K max
+    7 <= [ bad-zlib-header ] unless     
+    5 data bs:seek                      ! drop check bits 
+    1 data bs:read 0 assert=            ! dictionnary - not allowed in png
+    2 data bs:seek                      ! compression level; ignore
+    ;
+
+:: default-table ( -- table )
+    0 <hashtable> :> table
+    0 143 [a,b] 280 287 [a,b] append 8 table set-at
+    144 255 [a,b] >array 9 table set-at
+    256 279 [a,b] >array 7 table set-at 
+    table enum>seq 1 tail ;
+
+CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
+
+: get-table ( values size -- table ) 
+    16 f <array> clone <enum> 
+    [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
+
+:: decode-huffman-tables ( bitstream -- tables )
+    5 bitstream bs:read 257 +
+    5 bitstream bs:read 1 +
+    4 bitstream bs:read 4 +
+    clen-shuffle swap head
+    dup [ drop 3 bitstream bs:read ] map
+    get-table
+    bitstream swap <huffman-decoder> 
+    [ 2dup + ] dip swap :> k!
+    '[
+        _ read1-huff2
+        {
+            { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
+            { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
+            { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
+            [ ]
+        } cond
+        dup array? [ dup second ] [ 1 ] if
+        k swap - dup k! 0 >
+    ] 
+    [ ] produce swap suffix
+    { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
+    [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
+    nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
+    
+CONSTANT: length-table
+    {
+        3 4 5 6 7 8 9 10
+        11 13 15 17
+        19 23 27 31
+        35 43 51 59
+        67 83 99 115
+        131 163 195 227 258
+    }
+
+CONSTANT: dist-table
+    {
+        1 2 3 4 
+        5 7 9 13 
+        17 25 33 49
+        65 97 129 193
+        257 385 513 769
+        1025 1537 2049 3073
+        4097 6145 8193 12289
+        16385 24577
+    }
+
+: nth* ( n seq -- elt )
+    [ length 1- swap - ] [ nth ] bi ;
+
+:: inflate-lz77 ( seq -- bytes )
+    1000 <byte-vector> :> bytes
+    seq
+    [
+        dup array?
+        [ first2 '[ _ 1- bytes nth* bytes push ] times ]
+        [ bytes push ] if
+    ] each 
+    bytes ;
+
+:: inflate-dynamic ( bitstream -- bytes )
+    bitstream decode-huffman-tables
+    bitstream '[ _ swap <huffman-decoder> ] map :> tables
+    [
+        tables first read1-huff2
+        dup 256 >
+        [
+            dup 285 = 
+            [ ]
+            [ 
+                dup 264 > 
+                [ 
+                    dup 261 - 4 /i dup 5 > 
+                    [ bad-zlib-data ] when 
+                    bitstream bs:read 2array 
+                ]
+                when 
+            ] if
+            ! 5 bitstream read-bits ! distance
+            tables second read1-huff2
+            dup 3 > 
+            [ 
+                dup 2 - 2 /i dup 13 >
+                [ bad-zlib-data ] when
+                bitstream bs:read 2array
+            ] 
+            when
+            2array
+        ]
+        when
+        dup 256 = not
+    ]
+    [ ] produce nip
+    [
+        dup array? [
+            first2
+            [  
+                dup array? [ first2 ] [ 0 ] if
+                [ 257 - length-table nth ] [ + ] bi*
+            ] 
+            [
+                dup array? [ first2 ] [ 0 ] if
+                [ dist-table nth ] [ + ] bi*
+            ] bi*
+            2array
+        ] when
+    ] map ;
+    
+:: inflate-raw ( bitstream -- bytes ) 
+    8 bitstream bs:align 
+    16 bitstream bs:read :> len
+    16 bitstream bs:read :> nlen
+    len nlen + 16 >signed -1 assert= ! len + ~len = -1
+    bitstream byte-pos>>
+    bitstream byte-pos>> len +
+    bitstream bytes>> <slice>
+    len 8 * bitstream bs:seek ;
+
+: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
+
+:: inflate-loop ( bitstream -- bytes )
+    [ 1 bitstream bs:read 0 = ]
+    [
+        bitstream
+        2 bitstream bs:read
+        { 
+            { 0 [ inflate-raw ] }
+            { 1 [ inflate-static ] }
+            { 2 [ inflate-dynamic ] }
+            { 3 [ bad-zlib-data f ] }
+        }
+        case
+    ]
+    [ produce ] keep call suffix concat ;
+    
+  !  [ produce ] keep dip swap suffix
+
+:: paeth ( a b c -- p ) 
+    a b + c - { a b c } [ [ - abs ] keep 2array ] with map 
+    sort-keys first second ;
+    
+:: png-unfilter-line ( prev curr filter -- curr' )
+    prev :> c
+    prev 3 tail-slice :> b
+    curr :> a
+    curr 3 tail-slice :> x
+    x length [0,b)
+    filter
+    {
+        { 0 [ drop ] }
+        { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
+        { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
+        { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
+        { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
+        
+    } case 
+    curr 3 tail ;
+
+PRIVATE>
+
+: reverse-png-filter' ( lines -- byte-array )
+    [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
+    concat [ 128 + ] B{ } map-as ;
+
+: reverse-png-filter ( lines -- byte-array )
+    dup first [ 0 ] replicate prefix
+    [ { 0 0 } prepend  ] map
+    2 clump [
+        first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
+    ] map B{ } concat-as ;
+
+: zlib-inflate ( bytes -- bytes )
+    bs:<lsb0-bit-reader>
+    [ check-zlib-header ] [ inflate-loop ] bi
+    inflate-lz77 ;
diff --git a/basis/compression/run-length/authors.txt b/basis/compression/run-length/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/compression/run-length/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor
new file mode 100644
index 0000000000..cde2a7e113
--- /dev/null
+++ b/basis/compression/run-length/run-length.factor
@@ -0,0 +1,75 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators grouping kernel locals math
+math.matrices math.order multiline sequence-parser sequences
+tools.continuations ;
+IN: compression.run-length
+
+: run-length-uncompress ( byte-array -- byte-array' )
+    2 group [ first2 <array> ] map B{ } concat-as ;
+
+: 8hi-lo ( byte -- hi lo )
+    [ HEX: f0 bitand -4 shift ] [ HEX: f bitand ] bi ; inline
+
+:: run-length-uncompress-bitmap4 ( byte-array m n -- byte-array' )
+    byte-array <sequence-parser> :> sp
+    m  1 + n zero-matrix :> matrix
+    n 4 mod n + :> stride
+    0 :> i!
+    0 :> j!
+    f :> done?!
+    [
+        ! i j [ number>string ] bi@ " " glue .
+        sp next dup 0 = [
+            sp next dup HEX: 03 HEX: ff between? [
+                nip [ sp ] dip dup odd?
+                [ 1 + take-n but-last ] [ take-n ] if
+                [ j matrix i swap nth copy ] [ length j + j! ] bi
+            ] [
+                nip {
+                    { 0 [ i 1 + i!  0 j! ] }
+                    { 1 [ t done?! ] }
+                    { 2 [ sp next j + j!  sp next i + i! ] }
+                } case
+            ] if
+        ] [
+            [ sp next 8hi-lo 2array <repetition> concat ] [ head ] bi
+            [ j matrix i swap nth copy ] [ length j + j! ] bi
+        ] if
+        
+        ! j stride >= [ i 1 + i!  0 j! ] when
+        j stride >= [ 0 j! ] when
+        done? not
+    ] loop
+    matrix B{ } concat-as ;
+
+:: run-length-uncompress-bitmap8 ( byte-array m n -- byte-array' )
+    byte-array <sequence-parser> :> sp
+    m  1 + n zero-matrix :> matrix
+    n 4 mod n + :> stride
+    0 :> i!
+    0 :> j!
+    f :> done?!
+    [
+        ! i j [ number>string ] bi@ " " glue .
+        sp next dup 0 = [
+            sp next dup HEX: 03 HEX: ff between? [
+                nip [ sp ] dip dup odd?
+                [ 1 + take-n but-last ] [ take-n ] if
+                [ j matrix i swap nth copy ] [ length j + j! ] bi
+            ] [
+                nip {
+                    { 0 [ i 1 + i!  0 j! ] }
+                    { 1 [ t done?! ] }
+                    { 2 [ sp next j + j!  sp next i + i! ] }
+                } case
+            ] if
+        ] [
+            sp next <array> [ j matrix i swap nth copy ] [ length j + j! ] bi
+        ] if
+        
+        ! j stride >= [ i 1 + i!  0 j! ] when
+        j stride >= [ 0 j! ] when
+        done? not
+    ] loop
+    matrix B{ } concat-as ;
diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor
index ca1c5762f6..52627f2ed9 100644
--- a/basis/concurrency/distributed/distributed.factor
+++ b/basis/concurrency/distributed/distributed.factor
@@ -13,9 +13,8 @@ SYMBOL: local-node
     [ first2 get-process send ] [ stop-this-server ] if* ;
 
 : <node-server> ( addrspec -- threaded-server )
-    <threaded-server>
+    binary <threaded-server>
         swap >>insecure
-        binary >>encoding
         "concurrency.distributed" >>name
         [ handle-node-client ] >>handler ;
 
diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor
deleted file mode 100644
index 367f0ad143..0000000000
--- a/basis/constructors/constructors-tests.factor
+++ /dev/null
@@ -1,21 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit ;
-IN: constructors.tests
-
-TUPLE: stock-spread stock spread timestamp ;
-
-CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
-   now >>timestamp ;
-
-SYMBOL: AAPL
-
-[ t ] [
-    AAPL 1234 <stock-spread>
-    {
-        [ stock>> AAPL eq? ]
-        [ spread>> 1234 = ]
-        [ timestamp>> timestamp? ]
-    } 1&&
-] unit-test
\ No newline at end of file
diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor
deleted file mode 100644
index 7a98cd5e0a..0000000000
--- a/basis/constructors/constructors.factor
+++ /dev/null
@@ -1,23 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: slots kernel sequences fry accessors parser lexer words
-effects.parser macros ;
-IN: constructors
-
-! An experiment
-
-MACRO: set-slots ( slots -- quot )
-    <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
-
-: construct ( ... class slots -- instance )
-    [ new ] dip set-slots ; inline
-
-: define-constructor ( name class effect body -- )
-    [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
-    define-declared ;
-
-SYNTAX: CONSTRUCTOR:
-    scan-word [ name>> "<" ">" surround create-in ] keep
-    complete-effect
-    parse-definition
-    define-constructor ;
\ No newline at end of file
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index de5d1da4e0..556424f50c 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -5,13 +5,6 @@ memory namespaces make sequences layouts system hashtables
 classes alien byte-arrays combinators words sets fry ;
 IN: cpu.architecture
 
-! Labels
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-: define-label ( name -- ) <label> swap set ;
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
 ! Register classes
 SINGLETON: int-regs
 SINGLETON: single-float-regs
@@ -19,12 +12,22 @@ SINGLETON: double-float-regs
 UNION: float-regs single-float-regs double-float-regs ;
 UNION: reg-class int-regs float-regs ;
 
-! Mapping from register class to machine registers
-HOOK: machine-registers cpu ( -- assoc )
-
 ! A pseudo-register class for parameters spilled on the stack
 SINGLETON: stack-params
 
+GENERIC: reg-size ( register-class -- n )
+
+M: int-regs reg-size drop cell ;
+
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+M: stack-params reg-size drop cell ;
+
+! Mapping from register class to machine registers
+HOOK: machine-registers cpu ( -- assoc )
+
 ! Return values of this class go here
 GENERIC: return-reg ( register-class -- reg )
 
@@ -51,8 +54,7 @@ HOOK: %jump cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 HOOK: %return cpu ( -- )
 
-HOOK: %dispatch cpu ( src temp offset -- )
-HOOK: %dispatch-label cpu ( word -- )
+HOOK: %dispatch cpu ( src temp -- )
 
 HOOK: %slot cpu ( dst obj slot tag temp -- )
 HOOK: %slot-imm cpu ( dst obj slot tag -- )
@@ -126,7 +128,7 @@ HOOK: %alien-global cpu ( dst symbol library -- )
 
 HOOK: %allot cpu ( dst size class temp -- )
 HOOK: %write-barrier cpu ( src card# table -- )
-HOOK: %gc cpu ( -- )
+HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- )
 
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 617a7c5141..003eccfa18 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -3,10 +3,11 @@
 USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
 alien alien.accessors alien.c-types literals cpu.architecture
-cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers
+cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers
 compiler.cfg.instructions compiler.constants compiler.codegen
 compiler.codegen.fixup compiler.cfg.intrinsics
-compiler.cfg.stack-frame compiler.units ;
+compiler.cfg.stack-frame compiler.cfg.build-stack-frame
+compiler.units ;
 FROM: cpu.ppc.assembler => B ;
 IN: cpu.ppc
 
@@ -124,16 +125,13 @@ M: ppc %jump ( word -- )
 M: ppc %jump-label ( label -- ) B ;
 M: ppc %return ( -- ) BLR ;
 
-M:: ppc %dispatch ( src temp offset -- )
+M:: ppc %dispatch ( src temp -- )
     0 temp LOAD32
-    4 offset + cells rc-absolute-ppc-2/2 rel-here
+    4 cells rc-absolute-ppc-2/2 rel-here
     temp temp src LWZX
     temp MTCTR
     BCTR ;
 
-M: ppc %dispatch-label ( word -- )
-    B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
-
 :: (%slot) ( obj slot tag temp -- reg offset )
     temp slot obj ADD
     temp tag neg ; inline
@@ -464,16 +462,18 @@ M:: ppc %write-barrier ( src card# table -- )
     src card# deck-bits SRWI
     table scratch-reg card# STBX ;
 
-M: ppc %gc
+M:: ppc %gc ( temp1 temp2 gc-roots gc-root-count -- )
     "end" define-label
-    12 load-zone-ptr
-    11 12 cell LWZ ! nursery.here -> r11
-    12 12 3 cells LWZ ! nursery.end -> r12
-    11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
-    11 0 12 CMP ! is here >= end?
+    temp2 load-zone-ptr
+    temp1 temp2 cell LWZ
+    temp2 temp2 3 cells LWZ
+    temp1 temp1 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
+    temp1 0 temp2 CMP ! is here >= end?
     "end" get BLE
     %prepare-alien-invoke
-    "minor_gc" f %alien-invoke
+    0 3 LI
+    0 4 LI
+    "inline_gc" f %alien-invoke
     "end" resolve-label ;
 
 M: ppc %prologue ( n -- )
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 0a0ac4a53e..b591b254f8 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -3,10 +3,11 @@
 USING: locals alien.c-types alien.syntax arrays kernel
 math namespaces sequences system layouts io vocabs.loader
 accessors init combinators command-line cpu.x86.assembler
-cpu.x86 cpu.architecture compiler compiler.units
+cpu.x86 cpu.architecture make compiler compiler.units
 compiler.constants compiler.alien compiler.codegen
 compiler.codegen.fixup compiler.cfg.instructions
-compiler.cfg.builder compiler.cfg.intrinsics make ;
+compiler.cfg.builder compiler.cfg.intrinsics
+compiler.cfg.stack-frame ;
 IN: cpu.x86.32
 
 ! We implement the FFI for Linux, OS X and Windows all at once.
@@ -26,10 +27,10 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 temp-reg-1 ECX ;
 M: x86.32 temp-reg-2 EDX ;
 
-M:: x86.32 %dispatch ( src temp offset -- )
+M:: x86.32 %dispatch ( src temp -- )
     ! Load jump table base.
     src HEX: ffffffff ADD
-    offset cells rc-absolute-cell rel-here
+    0 rc-absolute-cell rel-here
     ! Go
     src HEX: 7f [+] JMP
     ! Fix up the displacement above
@@ -305,10 +306,7 @@ os windows? [
     4 "double" c-type (>>align)
 ] unless
 
-FUNCTION: bool check_sse2 ( ) ;
-
-: sse2? ( -- ? )
-    check_sse2 ;
+USING: cpu.x86.features cpu.x86.features.private ;
 
 "-no-sse2" (command-line) member? [
     [ { check_sse2 } compile ] with-optimizer
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index b77539b7e7..3a7221c239 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel math namespaces make sequences
 system layouts alien alien.c-types alien.accessors alien.structs
@@ -6,7 +6,7 @@ slots splitting assocs combinators locals cpu.x86.assembler
 cpu.x86 cpu.architecture compiler.constants
 compiler.codegen compiler.codegen.fixup
 compiler.cfg.instructions compiler.cfg.builder
-compiler.cfg.intrinsics ;
+compiler.cfg.intrinsics compiler.cfg.stack-frame ;
 IN: cpu.x86.64
 
 M: x86.64 machine-registers
@@ -22,10 +22,10 @@ M: x86.64 ds-reg R14 ;
 M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
 
-M:: x86.64 %dispatch ( src temp offset -- )
+M:: x86.64 %dispatch ( src temp -- )
     ! Load jump table base.
     temp HEX: ffffffff MOV
-    offset cells rc-absolute-cell rel-here
+    0 rc-absolute-cell rel-here
     ! Add jump table base
     src temp ADD
     src HEX: 7f [+] JMP
diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor
index 203edf956e..a8c54fa65e 100644
--- a/basis/cpu/x86/assembler/assembler-tests.factor
+++ b/basis/cpu/x86/assembler/assembler-tests.factor
@@ -64,3 +64,11 @@ IN: cpu.x86.assembler.tests
 [ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
 
 [ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
+
+[ { HEX: 4d HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 R8 3 IMUL3 ] { } make ] unit-test
+[ { HEX: 49 HEX: 6b HEX: c0 HEX: 03 } ] [ [ RAX R8 3 IMUL3 ] { } make ] unit-test
+[ { HEX: 4c HEX: 6b HEX: c0 HEX: 03 } ] [ [ R8 RAX 3 IMUL3 ] { } make ] unit-test
+[ { HEX: 48 HEX: 6b HEX: c1 HEX: 03 } ] [ [ RAX RCX 3 IMUL3 ] { } make ] unit-test
+[ { HEX: 48 HEX: 69 HEX: c1 HEX: 44 HEX: 03 HEX: 00 HEX: 00 } ] [ [ RAX RCX HEX: 344 IMUL3 ] { } make ] unit-test
+
+[ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test
diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor
index 2b40aa2053..95b85ac2dd 100644
--- a/basis/cpu/x86/assembler/assembler.factor
+++ b/basis/cpu/x86/assembler/assembler.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io.binary kernel combinators
-kernel.private math namespaces make sequences words system layouts
-math.order accessors cpu.x86.assembler.syntax ;
+USING: arrays io.binary kernel combinators kernel.private math
+namespaces make sequences words system layouts math.order accessors
+cpu.x86.assembler.syntax ;
 IN: cpu.x86.assembler
 
 ! A postfix assembler for x86-32 and x86-64.
@@ -402,20 +402,26 @@ M: operand TEST OCT: 204 2-operand ;
 : SHR ( dst n -- ) BIN: 101 (SHIFT) ;
 : SAR ( dst n -- ) BIN: 111 (SHIFT) ;
 
-GENERIC: IMUL2 ( dst src -- )
-M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
-M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
+: IMUL2 ( dst src -- )
+    OCT: 257 extended-opcode (2-operand) ;
+
+: IMUL3 ( dst src imm -- )
+    dup fits-in-byte? [
+        [ swap HEX: 6a 2-operand ] dip 1,
+    ] [
+        [ swap HEX: 68 2-operand ] dip 4,
+    ] if ;
 
 : MOVSX ( dst src -- )
-    dup register-32? OCT: 143 OCT: 276 extended-opcode ?
-    over register-16? [ BIN: 1 opcode-or ] when
-    swapd
+    swap
+    over register-32? OCT: 143 OCT: 276 extended-opcode ?
+    pick register-16? [ BIN: 1 opcode-or ] when
     (2-operand) ;
 
 : MOVZX ( dst src -- )
+    swap
     OCT: 266 extended-opcode
-    over register-16? [ BIN: 1 opcode-or ] when
-    swapd
+    pick register-16? [ BIN: 1 opcode-or ] when
     (2-operand) ;
 
 ! Conditional move
diff --git a/basis/cpu/x86/features/authors.txt b/basis/cpu/x86/features/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/cpu/x86/features/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/cpu/x86/features/features-tests.factor b/basis/cpu/x86/features/features-tests.factor
new file mode 100644
index 0000000000..69847cacfa
--- /dev/null
+++ b/basis/cpu/x86/features/features-tests.factor
@@ -0,0 +1,7 @@
+IN: cpu.x86.features.tests
+USING: cpu.x86.features tools.test kernel sequences math system ;
+
+cpu x86? [
+    [ t ] [ sse2? { t f } member? ] unit-test
+    [ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test
+] when
\ No newline at end of file
diff --git a/basis/cpu/x86/features/features.factor b/basis/cpu/x86/features/features.factor
new file mode 100644
index 0000000000..bc4818d6af
--- /dev/null
+++ b/basis/cpu/x86/features/features.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: system kernel math alien.syntax ;
+IN: cpu.x86.features
+
+<PRIVATE
+
+FUNCTION: bool check_sse2 ( ) ;
+
+FUNCTION: longlong read_timestamp_counter ( ) ;
+
+PRIVATE>
+
+HOOK: sse2? cpu ( -- ? )
+
+M: x86.32 sse2? check_sse2 ;
+
+M: x86.64 sse2? t ;
+
+HOOK: instruction-count cpu ( -- n )
+
+M: x86 instruction-count read_timestamp_counter ;
+
+: count-instructions ( quot -- n )
+    instruction-count [ call ] dip instruction-count swap - ; inline
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index e12cec9738..15c54aa7d8 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -6,7 +6,7 @@ kernel kernel.private math memory namespaces make sequences
 words system layouts combinators math.order fry locals
 compiler.constants compiler.cfg.registers
 compiler.cfg.instructions compiler.cfg.intrinsics
-compiler.codegen compiler.codegen.fixup ;
+compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
 IN: cpu.x86
 
 << enable-fixnum-log2 >>
@@ -17,6 +17,32 @@ M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
 
 M: x86 two-operand? t ;
 
+HOOK: stack-reg cpu ( -- reg )
+
+HOOK: reserved-area-size cpu ( -- n )
+
+: stack@ ( n -- op ) stack-reg swap [+] ;
+
+: param@ ( n -- op ) reserved-area-size + stack@ ;
+
+: spill-integer@ ( n -- op ) spill-integer-offset param@ ;
+
+: spill-float@ ( n -- op ) spill-float-offset param@ ;
+
+: gc-root@ ( n -- op ) gc-root-offset param@ ;
+
+: decr-stack-reg ( n -- )
+    dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
+
+: incr-stack-reg ( n -- )
+    dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
+
+: align-stack ( n -- n' )
+    os macosx? cpu x86.64? or [ 16 align ] when ;
+
+M: x86 stack-frame-size ( stack-frame -- i )
+    (stack-frame-size) 3 cells reserved-area-size + + align-stack ;
+
 HOOK: temp-reg-1 cpu ( -- reg )
 HOOK: temp-reg-2 cpu ( -- reg )
 
@@ -45,20 +71,6 @@ M: x86 %replace loc>operand swap MOV ;
 M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
 M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
 
-: align-stack ( n -- n' )
-    os macosx? cpu x86.64? or [ 16 align ] when ;
-
-HOOK: reserved-area-size cpu ( -- n )
-
-M: x86 stack-frame-size ( stack-frame -- i )
-    [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
-    [ params>> ]
-    [ return>> ]
-    tri + +
-    3 cells +
-    reserved-area-size +
-    align-stack ;
-
 M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
 
 : xt-tail-pic-offset ( -- n )
@@ -74,14 +86,11 @@ M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
 M: x86 %return ( -- ) 0 RET ;
 
 : code-alignment ( align -- n )
-    [ building get [ integer? ] count dup ] dip align swap - ;
+    [ building get length dup ] dip align swap - ;
 
 : align-code ( n -- )
     0 <repetition> % ;
 
-M: x86 %dispatch-label ( word -- )
-    0 cell, rc-absolute-cell rel-word ;
-
 :: (%slot) ( obj slot tag temp -- op )
     temp slot obj [+] LEA
     temp tag neg [+] ; inline
@@ -99,7 +108,7 @@ M: x86 %add-imm [+] LEA ;
 M: x86 %sub     nip SUB ;
 M: x86 %sub-imm neg [+] LEA ;
 M: x86 %mul     nip swap IMUL2 ;
-M: x86 %mul-imm nip IMUL2 ;
+M: x86 %mul-imm IMUL3 ;
 M: x86 %and     nip AND ;
 M: x86 %and-imm nip AND ;
 M: x86 %or      nip OR ;
@@ -315,17 +324,29 @@ M:: x86 %box-alien ( dst src temp -- )
         "end" resolve-label
     ] with-scope ;
 
-: small-reg-4 ( reg -- reg' )
+: small-reg-8 ( reg -- reg' )
     H{
-        { EAX EAX }
-        { ECX ECX }
-        { EDX EDX }
-        { EBX EBX }
-        { ESP ESP }
-        { EBP EBP }
-        { ESI ESP }
-        { EDI EDI }
+        { EAX RAX }
+        { ECX RCX }
+        { EDX RDX }
+        { EBX RBX }
+        { ESP RSP }
+        { EBP RBP }
+        { ESI RSP }
+        { EDI RDI }
 
+        { RAX RAX }
+        { RCX RCX }
+        { RDX RDX }
+        { RBX RBX }
+        { RSP RSP }
+        { RBP RBP }
+        { RSI RSP }
+        { RDI RDI }
+    } at ; inline
+
+: small-reg-4 ( reg -- reg' )
+    small-reg-8 H{
         { RAX EAX }
         { RCX ECX }
         { RDX EDX }
@@ -361,12 +382,21 @@ M:: x86 %box-alien ( dst src temp -- )
         { 1 [ small-reg-1 ] }
         { 2 [ small-reg-2 ] }
         { 4 [ small-reg-4 ] }
+        { 8 [ small-reg-8 ] }
     } case ;
 
-: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
+HOOK: small-regs cpu ( -- regs )
+
+M: x86.32 small-regs { EAX ECX EDX EBX } ;
+M: x86.64 small-regs { RAX RCX RDX RBX } ;
+
+HOOK: small-reg-native cpu ( reg -- reg' )
+
+M: x86.32 small-reg-native small-reg-4 ;
+M: x86.64 small-reg-native small-reg-8 ;
 
 : small-reg-that-isn't ( exclude -- reg' )
-    small-regs swap [ small-reg-4 ] map '[ _ memq? not ] find nip ;
+    small-regs swap [ small-reg-native ] map '[ _ memq? not ] find nip ;
 
 : with-save/restore ( reg quot -- )
     [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
@@ -376,7 +406,7 @@ M:: x86 %box-alien ( dst src temp -- )
     #! call the quot with that. Otherwise, we find a small
     #! register that is not in exclude, and call quot, saving
     #! and restoring the small register.
-    dst small-reg-4 small-regs memq? [ dst quot call ] [
+    dst small-reg-native small-regs memq? [ dst quot call ] [
         exclude small-reg-that-isn't
         [ quot call ] with-save/restore
     ] if ; inline
@@ -492,29 +522,58 @@ M:: x86 %write-barrier ( src card# table -- )
     table table [] MOV
     table card# [+] card-mark <byte> MOV ;
 
-M: x86 %gc ( -- )
-    "end" define-label
-    temp-reg-1 load-zone-ptr
-    temp-reg-2 temp-reg-1 cell [+] MOV
-    temp-reg-2 1024 ADD
-    temp-reg-1 temp-reg-1 3 cells [+] MOV
-    temp-reg-2 temp-reg-1 CMP
-    "end" get JLE
+:: check-nursery ( temp1 temp2 -- )
+    temp1 load-zone-ptr
+    temp2 temp1 cell [+] MOV
+    temp2 1024 ADD
+    temp1 temp1 3 cells [+] MOV
+    temp2 temp1 CMP ;
+
+GENERIC# save-gc-root 1 ( gc-root operand temp -- )
+
+M:: spill-slot save-gc-root ( gc-root spill-slot temp -- )
+    temp spill-slot n>> spill-integer@ MOV
+    gc-root gc-root@ temp MOV ;
+
+M:: word save-gc-root ( gc-root register temp -- )
+    gc-root gc-root@ register MOV ;
+
+: save-gc-roots ( gc-roots temp -- )
+    '[ _ save-gc-root ] assoc-each ;
+
+GENERIC# load-gc-root 1 ( gc-root operand temp -- )
+
+M:: spill-slot load-gc-root ( gc-root spill-slot temp -- )
+    temp gc-root gc-root@ MOV
+    spill-slot n>> spill-integer@ temp MOV ;
+
+M:: word load-gc-root ( gc-root register temp -- )
+    register gc-root gc-root@ MOV ;
+
+: load-gc-roots ( gc-roots temp -- )
+    '[ _ load-gc-root ] assoc-each ;
+
+:: call-gc ( gc-root-count -- )
+    ! Pass pointer to start of GC roots as first parameter
+    param-reg-1 gc-root-base param@ LEA
+    ! Pass number of roots as second parameter
+    param-reg-2 gc-root-count MOV
+    ! Call GC
     %prepare-alien-invoke
-    "minor_gc" f %alien-invoke
+    "inline_gc" f %alien-invoke ;
+
+M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- )
+    "end" define-label
+    temp1 temp2 check-nursery
+    "end" get JLE
+    gc-roots temp1 save-gc-roots
+    gc-root-count call-gc
+    gc-roots temp1 load-gc-roots
     "end" resolve-label ;
 
 M: x86 %alien-global
     [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
 
-HOOK: stack-reg cpu ( -- reg )
-
-: decr-stack-reg ( n -- )
-    dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
-
-: incr-stack-reg ( n -- )
-    dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
-
 M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
 
 :: %boolean ( dst temp word -- )
@@ -568,28 +627,6 @@ M: x86 %compare-float-branch ( label cc src1 src2 -- )
         { cc/= [ JNE ] }
     } case ;
 
-: stack@ ( n -- op ) stack-reg swap [+] ;
-
-: param@ ( n -- op ) reserved-area-size + stack@ ;
-
-: spill-integer-base ( stack-frame -- n )
-    [ params>> ] [ return>> ] bi + reserved-area-size + ;
-
-: spill-integer@ ( n -- op )
-    cells
-    stack-frame get spill-integer-base
-    + stack@ ;
-
-: spill-float-base ( stack-frame -- n )
-    [ spill-integer-base ]
-    [ spill-counts>> int-regs swap at int-regs reg-size * ]
-    bi + ;
-
-: spill-float@ ( n -- op )
-    double-float-regs reg-size *
-    stack-frame get spill-float-base
-    + stack@ ;
-
 M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
 M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
 
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index 7994c3ed96..b10ca775f4 100644
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -104,8 +104,8 @@ HOOK: signal-error. os ( obj -- )
     "Cannot do next-object outside begin/end-scan" print drop ;
 
 : undefined-symbol-error. ( obj -- )
-    "The image refers to a library or symbol that was not found"
-    " at load time" append print drop ;
+    "The image refers to a library or symbol that was not found at load time"
+    print drop ;
 
 : stack-underflow. ( obj name -- )
     write " stack underflow" print drop ;
@@ -252,12 +252,15 @@ M: no-current-vocab summary
     drop "Not in a vocabulary; IN: form required" ;
 
 M: no-word-error summary
-    name>> "No word named ``" "'' found in current vocabulary search path" surround ;
+    name>>
+    "No word named ``"
+    "'' found in current vocabulary search path" surround ;
 
 M: no-word-error error. summary print ;
 
 M: ambiguous-use-error summary
-    words>> first name>> "More than one vocabulary defines a word named ``" "''" surround ;
+    words>> first name>>
+    "More than one vocabulary defines a word named ``" "''" surround ;
 
 M: ambiguous-use-error error. summary print ;
 
@@ -317,4 +320,4 @@ M: wrong-values summary drop "Quotation called with wrong stack effect" ;
 {
     { [ os windows? ] [ "debugger.windows" require ] }
     { [ os unix? ] [ "debugger.unix" require ] }
-} cond
\ No newline at end of file
+} cond
diff --git a/basis/formatting/formatting-tests.factor b/basis/formatting/formatting-tests.factor
index c7e9fb985e..c56372f023 100644
--- a/basis/formatting/formatting-tests.factor
+++ b/basis/formatting/formatting-tests.factor
@@ -77,6 +77,9 @@ IN: formatting.tests
 [ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
 [ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
 
+[ t ] [ "{ 1, 2, 3 }" { 1 2 3 } "%[%s, %]" sprintf = ] unit-test
+[ t ] [ "{ 1:2, 3:4 }" H{ { 1 2 } { 3 4 } } "%[%s: %s %]" sprintf = ] unit-test
+
 
 [ "%H:%M:%S" strftime ] must-infer
 
@@ -95,3 +98,4 @@ IN: formatting.tests
 [ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test
 [ t ] [ "PM" testtime "%p" strftime = ] unit-test
 
+
diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor
index 8438aae94e..c9518bdef1 100644
--- a/basis/ftp/server/server.factor
+++ b/basis/ftp/server/server.factor
@@ -341,12 +341,11 @@ M: ftp-server handle-client* ( server -- )
     ] with-destructors ;
 
 : <ftp-server> ( directory port -- server )
-    ftp-server new-threaded-server
+    latin1 ftp-server new-threaded-server
         swap >>insecure
         swap canonicalize-path >>serving-directory
         "ftp.server" >>name
-        5 minutes >>timeout
-        latin1 >>encoding ;
+        5 minutes >>timeout ;
 
 : ftpd ( directory port -- )
     <ftp-server> start-server ;
diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor
index 8540907db9..0ecf543baa 100755
--- a/basis/game-input/dinput/dinput.factor
+++ b/basis/game-input/dinput/dinput.factor
@@ -1,14 +1,13 @@
-USING: windows.dinput windows.dinput.constants parser
-alien.c-types windows.ole32 namespaces assocs kernel arrays
-vectors windows.kernel32 windows.com windows.dinput shuffle
-windows.user32 windows.messages sequences combinators locals
-math.rectangles accessors math alien alien.strings
-io.encodings.utf16 io.encodings.utf16n continuations
-byte-arrays game-input.dinput.keys-array game-input
-ui.backend.windows windows.errors struct-arrays
-math.bitwise ;
+USING: accessors alien alien.c-types alien.strings arrays
+assocs byte-arrays combinators continuations game-input
+game-input.dinput.keys-array io.encodings.utf16
+io.encodings.utf16n kernel locals math math.bitwise
+math.rectangles namespaces parser sequences shuffle
+struct-arrays ui.backend.windows vectors windows.com
+windows.dinput windows.dinput.constants windows.errors
+windows.kernel32 windows.messages windows.ole32
+windows.user32 ;
 IN: game-input.dinput
-
 CONSTANT: MOUSE-BUFFER-SIZE 16
 
 SINGLETON: dinput-game-input-backend
diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor
index d0f614f9cd..c877acf936 100644
--- a/basis/generalizations/generalizations-tests.factor
+++ b/basis/generalizations/generalizations-tests.factor
@@ -59,4 +59,11 @@ IN: generalizations.tests
 { 3 5 } [ 2 nweave ] must-infer-as
 
 [ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]
-[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
\ No newline at end of file
+[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
+
+[ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test
+
+[ [ 1 2 3 ] [ 1 2 3 ] ]
+[ 1 2 3 [ ] [ ] 3 nbi-curry ] unit-test
+
+[ 15 3 ] [ 1 2 3 4 5 [ + + + + ] [ - - - - ] 5 nbi ] unit-test
diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index 28a1f7dddb..0ea179b52c 100644
--- a/basis/generalizations/generalizations.factor
+++ b/basis/generalizations/generalizations.factor
@@ -39,6 +39,9 @@ MACRO: firstn ( n -- )
 MACRO: npick ( n -- )
     1- [ dup ] [ '[ _ dip swap ] ] repeat ;
 
+MACRO: nover ( n -- )
+    dup '[ _ 1 + npick ] n*quot ;
+
 MACRO: ndup ( n -- )
     dup '[ _ npick ] n*quot ;
 
@@ -69,6 +72,9 @@ MACRO: ncurry ( n -- )
 MACRO: nwith ( n -- )
     [ with ] n*quot ;
 
+MACRO: nbi ( n -- )
+    '[ [ _ nkeep ] dip call ] ;
+
 MACRO: ncleave ( quots n -- )
     [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
     compose ;
@@ -91,6 +97,9 @@ MACRO: nweave ( n -- )
     [ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
     '[ _ _ ncleave ] ;
 
+MACRO: nbi-curry ( n -- )
+    [ bi-curry ] n*quot ;
+
 : nappend-as ( n exemplar -- seq )
     [ narray concat ] dip like ; inline
 
diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor
index f2ccaad1b4..becfb6826d 100644
--- a/basis/heaps/heaps.factor
+++ b/basis/heaps/heaps.factor
@@ -192,6 +192,9 @@ M: heap heap-pop ( heap -- value key )
     [ dup heap-pop swap 2array ]
     produce nip ;
 
+: heap-values ( heap -- alist )
+    data>> [ value>> ] { } map-as ;
+
 : slurp-heap ( heap quot: ( elt -- ) -- )
     over heap-empty? [ 2drop ] [
         [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index 08cf4b2cd4..4ead01159a 100755
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -3,7 +3,7 @@
 USING: assocs continuations fry help help.lint.checks
 help.topics io kernel namespaces parser sequences
 source-files.errors vocabs.hierarchy vocabs words classes
-locals tools.errors ;
+locals tools.errors listener ;
 FROM: help.lint.checks => all-vocabs ;
 IN: help.lint
 
diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor
index c838471e3f..8682c97c73 100755
--- a/basis/http/server/server.factor
+++ b/basis/http/server/server.factor
@@ -269,7 +269,7 @@ M: http-server handle-client*
     ] with-destructors ;
 
 : <http-server> ( -- server )
-    http-server new-threaded-server
+    ascii http-server new-threaded-server
         "http.server" >>name
         "http" protocol-port >>insecure
         "https" protocol-port >>secure ;
diff --git a/basis/images/authors.txt b/basis/images/authors.txt
index b4bd0e7b35..a4a77d97e9 100644
--- a/basis/images/authors.txt
+++ b/basis/images/authors.txt
@@ -1 +1,2 @@
-Doug Coleman
\ No newline at end of file
+Doug Coleman
+Daniel Ehrenberg
diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor
index ea8b0d4c0c..950fd0b3a6 100644
--- a/basis/images/bitmap/bitmap-tests.factor
+++ b/basis/images/bitmap/bitmap-tests.factor
@@ -1,7 +1,6 @@
 USING: images.bitmap images.viewer io.encodings.binary
 io.files io.files.unique kernel tools.test images.loader
-literals sequences checksums.md5 checksums
-images.normalization ;
+literals sequences checksums.md5 checksums ;
 IN: images.bitmap.tests
 
 CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
@@ -26,8 +25,8 @@ ${
 
 : test-bitmap-save ( path -- ? )
     [ md5 checksum-file ]
-    [ load-image normalize-image ] bi
-    "bitmap-save-test" unique-file
+    [ load-image ] bi
+    "bitmap-save-test" ".bmp" make-unique-file
     [ save-bitmap ]
     [ md5 checksum-file ] bi = ;
 
diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor
index 48095bb26b..cb73e4e274 100755
--- a/basis/images/bitmap/bitmap.factor
+++ b/basis/images/bitmap/bitmap.factor
@@ -1,156 +1,22 @@
 ! Copyright (C) 2007, 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types arrays byte-arrays columns
-combinators fry grouping io io.binary io.encodings.binary io.files
-kernel macros math math.bitwise math.functions namespaces sequences
-strings images endian summary locals ;
+combinators compression.run-length endian fry grouping images
+images.bitmap.loading images.loader io io.binary
+io.encodings.binary io.encodings.string io.files
+io.streams.limited kernel locals macros math math.bitwise
+math.functions namespaces sequences specialized-arrays.uint
+specialized-arrays.ushort strings summary ;
 IN: images.bitmap
 
-: assert-sequence= ( a b -- )
-    2dup sequence= [ 2drop ] [ assert ] if ;
-
-: read2 ( -- n ) 2 read le> ;
-: read4 ( -- n ) 4 read le> ;
 : write2 ( n -- ) 2 >le write ;
 : write4 ( n -- ) 4 >le write ;
 
-TUPLE: bitmap-image < image ;
-
-! Used to construct the final bitmap-image
-
-TUPLE: loading-bitmap 
-size reserved offset header-length width
-height planes bit-count compression size-image
-x-pels y-pels color-used color-important rgb-quads color-index ;
-
-ERROR: bitmap-magic magic ;
-
-M: bitmap-magic summary
-    drop "First two bytes of bitmap stream must be 'BM'" ;
-
-<PRIVATE
-
-: 8bit>buffer ( bitmap -- array )
-    [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
-    [ color-index>> >array ] bi [ swap nth ] with map concat ;
-
-ERROR: bmp-not-supported n ;
-
-: reverse-lines ( byte-array width -- byte-array )
-    <sliced-groups> <reversed> concat ; inline
-
-: raw-bitmap>seq ( loading-bitmap -- array )
-    dup bit-count>>
-    {
-        { 32 [ color-index>> ] }
-        { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
-        { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
-        [ bmp-not-supported ]
-    } case >byte-array ;
-
-: parse-file-header ( loading-bitmap -- loading-bitmap )
-    2 read "BM" assert-sequence=
-    read4 >>size
-    read4 >>reserved
-    read4 >>offset ;
-
-: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
-    read4 >>header-length
-    read4 >>width
-    read4 32 >signed >>height
-    read2 >>planes
-    read2 >>bit-count
-    read4 >>compression
-    read4 >>size-image
-    read4 >>x-pels
-    read4 >>y-pels
-    read4 >>color-used
-    read4 >>color-important ;
-
-: rgb-quads-length ( loading-bitmap -- n )
-    [ offset>> 14 - ] [ header-length>> ] bi - ;
-
-: color-index-length ( loading-bitmap -- n )
-    {
-        [ width>> ]
-        [ planes>> * ]
-        [ bit-count>> * 31 + 32 /i 4 * ]
-        [ height>> abs * ]
-    } cleave ;
-
-: image-size ( loading-bitmap -- n )
-    [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
-
-: bitmap-padding ( width -- n )
-    3 * 4 mod 4 swap - 4 mod ; inline
-
-:: fixup-color-index ( loading-bitmap -- loading-bitmap )
-    loading-bitmap width>> :> width
-    width 3 * :> width*3
-    loading-bitmap width>> bitmap-padding :> padding
-    loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
-    loading-bitmap
-    padding 0 > [
-        [
-            stride <sliced-groups>
-            [ width*3 head-slice ] map concat
-        ] change-color-index
-    ] when ;
-
-: parse-bitmap ( loading-bitmap -- loading-bitmap )
-    dup rgb-quads-length read >>rgb-quads
-    dup color-index-length read >>color-index
-    fixup-color-index ;
-
-: load-bitmap-data ( path -- loading-bitmap )
-    binary [
-        loading-bitmap new
-        parse-file-header parse-bitmap-header parse-bitmap
-    ] with-file-reader ;
-
-ERROR: unknown-component-order bitmap ;
-
-: bitmap>component-order ( loading-bitmap -- object )
-    bit-count>> {
-        { 32 [ BGRA ] }
-        { 24 [ BGR ] }
-        { 8 [ BGR ] }
-        [ unknown-component-order ]
-    } case ;
-
-: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
-    {
-        [ raw-bitmap>seq >>bitmap ]
-        [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
-        [ height>> 0 < [ t >>upside-down? ] when ]
-        [ bitmap>component-order >>component-order ]
-    } cleave ;
-
-M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
-    swap load-bitmap-data loading-bitmap>bitmap-image ;
-
-PRIVATE>
-
-: bitmap>color-index ( bitmap -- byte-array )
-    [
-        bitmap>>
-        4 <sliced-groups>
-        [ 3 head-slice <reversed> ] map
-        B{ } join
-    ] [
-        dim>> first dup bitmap-padding dup 0 > [
-            [ 3 * group ] dip '[ _ <byte-array> append ] map
-            B{ } join
-        ] [
-            2drop
-        ] if
-    ] bi ;
-
 : save-bitmap ( image path -- )
     binary [
         B{ CHAR: B CHAR: M } write
         [
-            bitmap>color-index length 14 + 40 + write4
+            bitmap>> length 14 + 40 + write4
             0 write4
             54 write4
             40 write4
@@ -168,8 +34,8 @@ PRIVATE>
                 ! compression
                 [ drop 0 write4 ]
 
-                ! size-image
-                [ bitmap>color-index length write4 ]
+                ! image-size
+                [ bitmap>> length write4 ]
 
                 ! x-pels
                 [ drop 0 write4 ]
@@ -183,13 +49,8 @@ PRIVATE>
                 ! color-important
                 [ drop 0 write4 ]
 
-                ! rgb-quads
-                [
-                    [ bitmap>color-index ]
-                    [ dim>> first 3 * ]
-                    [ dim>> first bitmap-padding + ] tri
-                    reverse-lines write
-                ]
+                ! color-palette
+                [ bitmap>> write ]
             } cleave
         ] bi
     ] with-file-writer ;
diff --git a/basis/images/bitmap/loading/authors.txt b/basis/images/bitmap/loading/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/images/bitmap/loading/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/images/bitmap/loading/loading.factor b/basis/images/bitmap/loading/loading.factor
new file mode 100644
index 0000000000..b0bd501f09
--- /dev/null
+++ b/basis/images/bitmap/loading/loading.factor
@@ -0,0 +1,374 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays combinators
+compression.run-length fry grouping images images.loader io
+io.binary io.encodings.8-bit io.encodings.binary
+io.encodings.string io.streams.limited kernel math math.bitwise
+sequences specialized-arrays.ushort summary ;
+QUALIFIED-WITH: bitstreams b
+IN: images.bitmap.loading
+
+SINGLETON: bitmap-image
+"bmp" bitmap-image register-image-class
+
+! http://www.fileformat.info/format/bmp/egff.htm
+! http://www.digicamsoft.com/bmp/bmp.html
+
+ERROR: unknown-component-order bitmap ;
+ERROR: unknown-bitmap-header n ;
+
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
+
+TUPLE: loading-bitmap
+    file-header header
+    color-palette color-index bitfields ;
+
+TUPLE: file-header
+    { magic initial: "BM" }
+    { size }
+    { reserved1 initial: 0 }
+    { reserved2 initial: 0 }
+    { offset }
+    { header-length } ;
+
+TUPLE: v3-header
+    { width initial: 0 }
+    { height initial: 0 }
+    { planes initial: 0 }
+    { bit-count initial: 0 }
+    { compression initial: 0 }
+    { image-size initial: 0 }
+    { x-resolution initial: 0 }
+    { y-resolution initial: 0 }
+    { colors-used initial: 0 }
+    { colors-important initial: 0 } ;
+
+TUPLE: v4-header < v3-header
+    { red-mask initial: 0 }
+    { green-mask initial: 0 }
+    { blue-mask initial: 0 }
+    { alpha-mask initial: 0 }
+    { cs-type initial: 0 }
+    { end-points initial: 0 }
+    { gamma-red initial: 0 }
+    { gamma-green initial: 0 }
+    { gamma-blue initial: 0 } ;
+
+TUPLE: v5-header < v4-header
+    { intent initial: 0 }
+    { profile-data initial: 0 }
+    { profile-size initial: 0 }
+    { reserved3 initial: 0 } ;
+
+TUPLE: os2v1-header
+    { width initial: 0 }
+    { height initial: 0 }
+    { planes initial: 0 }
+    { bit-count initial: 0 } ;
+
+TUPLE: os2v2-header < os2v1-header
+    { compression initial: 0 }
+    { image-size initial: 0 }
+    { x-resolution initial: 0 }
+    { y-resolution initial: 0 }
+    { colors-used initial: 0 }
+    { colors-important initial: 0 }
+    { units initial: 0 }
+    { reserved initial: 0 }
+    { recording initial: 0 }
+    { rendering initial: 0 }
+    { size1 initial: 0 }
+    { size2 initial: 0 }
+    { color-encoding initial: 0 }
+    { identifier initial: 0 } ;
+
+UNION: v-header v3-header v4-header v5-header ;
+UNION: os2-header os2v1-header os2v2-header ;
+
+: parse-file-header ( -- file-header )
+    \ file-header new
+        2 read latin1 decode >>magic
+        read4 >>size
+        read2 >>reserved1
+        read2 >>reserved2
+        read4 >>offset
+        read4 >>header-length ;
+
+: read-v3-header-data ( header -- header )
+    read4 >>width
+    read4 32 >signed >>height
+    read2 >>planes
+    read2 >>bit-count
+    read4 >>compression
+    read4 >>image-size
+    read4 >>x-resolution
+    read4 >>y-resolution
+    read4 >>colors-used
+    read4 >>colors-important ;
+
+: read-v3-header ( -- header )
+    \ v3-header new
+        read-v3-header-data ;
+
+: read-v4-header-data ( header -- header )
+    read4 >>red-mask
+    read4 >>green-mask
+    read4 >>blue-mask
+    read4 >>alpha-mask
+    read4 >>cs-type
+    read4 read4 read4 3array >>end-points
+    read4 >>gamma-red
+    read4 >>gamma-green
+    read4 >>gamma-blue ;
+
+: read-v4-header ( -- v4-header )
+    \ v4-header new
+        read-v3-header-data
+        read-v4-header-data ;
+
+: read-v5-header-data ( v5-header -- v5-header )
+    read4 >>intent
+    read4 >>profile-data
+    read4 >>profile-size
+    read4 >>reserved3 ;
+
+: read-v5-header ( -- loading-bitmap )
+    \ v5-header new
+        read-v3-header-data
+        read-v4-header-data
+        read-v5-header-data ;
+
+: read-os2v1-header ( -- os2v1-header )
+    \ os2v1-header new
+        read2 >>width
+        read2 16 >signed >>height
+        read2 >>planes
+        read2 >>bit-count ;
+
+: read-os2v2-header-data ( os2v2-header -- os2v2-header )
+    read4 >>width
+    read4 32 >signed >>height
+    read2 >>planes
+    read2 >>bit-count
+    read4 >>compression
+    read4 >>image-size
+    read4 >>x-resolution
+    read4 >>y-resolution
+    read4 >>colors-used
+    read4 >>colors-important
+    read2 >>units
+    read2 >>reserved
+    read2 >>recording
+    read2 >>rendering
+    read4 >>size1
+    read4 >>size2
+    read4 >>color-encoding
+    read4 >>identifier ;
+
+: read-os2v2-header ( -- os2v2-header )
+    \ os2v2-header new
+        read-os2v2-header-data ;
+
+: parse-header ( n -- header )
+    {
+        { 12 [ read-os2v1-header ] }
+        { 64 [ read-os2v2-header ] }
+        { 40 [ read-v3-header ] }
+        { 108 [ read-v4-header ] }
+        { 124 [ read-v5-header ] }
+        [ unknown-bitmap-header ]
+    } case ;
+
+: color-index-length ( header -- n )
+    {
+        [ width>> ]
+        [ planes>> * ]
+        [ bit-count>> * 31 + 32 /i 4 * ]
+        [ height>> abs * ]
+    } cleave ;
+
+: color-palette-length ( loading-bitmap -- n )
+    file-header>>
+    [ offset>> 14 - ] [ header-length>> ] bi - ;
+
+: parse-color-palette ( loading-bitmap -- loading-bitmap )
+    dup color-palette-length read >>color-palette ;
+
+GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
+
+: parse-color-data ( loading-bitmap -- loading-bitmap )
+    dup header>> parse-color-data* ;
+
+M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
+    color-index-length read >>color-index ;
+
+M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
+    dup image-size>> [ 0 ] unless* dup 0 >
+    [ nip ] [ drop color-index-length ] if read >>color-index ;
+
+: alpha-used? ( loading-bitmap -- ? )
+    color-index>> 4 <sliced-groups> [ fourth 0 = ] all? not ;
+
+GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
+
+: bitmap>component-order ( loading-bitmap -- object )
+    dup header>> bitmap>component-order* ;
+
+: simple-bitmap>component-order ( loading-bitamp -- object )
+    header>> bit-count>> {
+        { 32 [ BGRX ] }
+        { 24 [ BGR ] }
+        { 16 [ BGR ] }
+        { 8 [ BGR ] }
+        { 4 [ BGR ] }
+        { 1 [ BGR ] }
+        [ unknown-component-order ]
+    } case ;
+
+: advanced-bitmap>component-order ( loading-bitmap -- object )
+    [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
+        { { 32 t } [ drop BGRA ] }
+        { { 32 f } [ drop BGRX ] }
+        [ drop simple-bitmap>component-order ]
+    } case ;
+
+: color-lookup3 ( loading-bitmap -- seq )
+    [ color-index>> >array ]
+    [ color-palette>> 3 <sliced-groups> ] bi
+    '[ _ nth ] map concat ;
+
+: color-lookup4 ( loading-bitmap -- seq )
+    [ color-index>> >array ]
+    [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
+    '[ _ nth ] map concat ;
+
+! os2v1 is 3bytes each, all others are 3 + 1 unused
+: color-lookup ( loading-bitmap -- seq )
+    dup file-header>> header-length>> {
+        { 12 [ color-lookup3 ] }
+        { 64 [ color-lookup4 ] }
+        { 40 [ color-lookup4 ] }
+        { 108 [ color-lookup4 ] }
+        { 124 [ color-lookup4 ] }
+    } case ;
+
+M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
+M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
+
+: uncompress-bitfield ( seq masks -- bytes' )
+    '[
+        _ [
+            [ bitand ] [ bit-count ] [ log2 ] tri - shift
+        ] with map
+    ] { } map-as B{ } concat-as ;
+
+ERROR: bmp-not-supported n ;
+
+: bitmap>bytes ( loading-bitmap -- byte-array )
+    dup header>> bit-count>>
+    {
+        { 32 [ color-index>> ] }
+        { 24 [ color-index>> ] }
+        { 16 [
+            [
+                ! byte-array>ushort-array
+                2 group [ le> ] map
+                ! 5 6 5
+                ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
+                ! 5 5 5
+                { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
+            ] change-color-index
+            color-index>>
+        ] }
+        { 8 [ color-lookup ] }
+        { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
+        { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
+        [ bmp-not-supported ]
+    } case >byte-array ;
+
+: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+    dup header>> bit-count>> {
+        { 16 [ dup color-palette>> 4 group [ le> ] map ] }
+        { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
+    } case reverse >>bitfields ;
+
+ERROR: unsupported-bitfield-widths n ;
+
+M: unsupported-bitfield-widths summary
+    drop "Bitmaps only support bitfield compression in 16/32bit images" ;
+
+: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+    set-bitfield-widths
+    dup header>> bit-count>> {
+        { 16 [
+            dup bitfields>> '[
+                byte-array>ushort-array _ uncompress-bitfield
+            ] change-color-index
+        ] }
+        { 32 [ ] }
+        [ unsupported-bitfield-widths ]
+    } case ;
+
+ERROR: unsupported-bitmap-compression compression ;
+
+GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
+
+: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
+    dup header>> uncompress-bitmap* ;
+
+M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+    drop ;
+
+: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
+    dupd '[
+        _ header>> [ width>> ] [ height>> ] bi
+        _ execute
+    ] change-color-index ; inline
+
+M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+    compression>> {
+        { f [ ] }
+        { 0 [ ] }
+        { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
+        { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
+        { 3 [ uncompress-bitfield-widths ] }
+        { 4 [ "jpeg" unsupported-bitmap-compression ] }
+        { 5 [ "png" unsupported-bitmap-compression ] }
+    } case ;
+
+ERROR: unsupported-bitmap-file magic ;
+
+: load-bitmap ( path -- loading-bitmap )
+    binary stream-throws <limited-file-reader> [
+        \ loading-bitmap new
+        parse-file-header [ >>file-header ] [ ] bi magic>> {
+            { "BM" [
+                dup file-header>> header-length>> parse-header >>header
+                parse-color-palette
+                parse-color-data
+            ] }
+            ! { "BA" [ parse-os2-bitmap-array ] }
+            ! { "CI" [ parse-os2-color-icon ] }
+            ! { "CP" [ parse-os2-color-pointer ] }
+            ! { "IC" [ parse-os2-icon ] }
+            ! { "PT" [ parse-os2-pointer ] }
+            [ unsupported-bitmap-file ]
+        } case
+    ] with-input-stream ;
+
+: loading-bitmap>bytes ( loading-bitmap -- byte-array )
+    uncompress-bitmap bitmap>bytes ;
+
+M: bitmap-image load-image* ( path bitmap-image -- bitmap )
+    drop load-bitmap
+    [ image new ] dip
+    {
+        [ loading-bitmap>bytes >>bitmap ]
+        [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
+        [ header>> height>> 0 < not >>upside-down? ]
+        [ bitmap>component-order >>component-order ]
+    } cleave ;
diff --git a/basis/images/images-tests.factor b/basis/images/images-tests.factor
new file mode 100644
index 0000000000..8918dcb38c
--- /dev/null
+++ b/basis/images/images-tests.factor
@@ -0,0 +1,29 @@
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: images tools.test kernel accessors ;
+IN: images.tests
+
+[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA f B{
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+    57 57 57 255
+    0 0 0 0 
+    0 0 0 0 
+} } pixel-at ] unit-test
+
+[ B{
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+    57 57 57 255
+    0 0 0 0 
+    0 0 0 0 
+} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA f B{
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+    0 0 0 0 
+} } [ set-pixel-at ] keep bitmap>> ] unit-test
diff --git a/basis/images/images.factor b/basis/images/images.factor
index 178b91ab52..4c76b85459 100755
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2009 Doug Coleman.
+! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel accessors ;
+USING: combinators kernel accessors sequences math arrays ;
 IN: images
 
 SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
@@ -34,4 +34,22 @@ TUPLE: image dim component-order upside-down? bitmap ;
 
 : has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
 
-GENERIC: load-image* ( path tuple -- image )
+GENERIC: load-image* ( path class -- image )
+
+<PRIVATE
+
+: pixel@ ( x y image -- start end bitmap )
+    [ dim>> first * + ]
+    [ component-order>> bytes-per-pixel [ * dup ] keep + ]
+    [ bitmap>> ] tri ;
+
+: set-subseq ( new-value from to victim -- )
+    <slice> 0 swap copy ; inline
+
+PRIVATE>
+
+: pixel-at ( x y image -- pixel )
+    pixel@ subseq ;
+
+: set-pixel-at ( pixel x y image -- )
+    pixel@ set-subseq ;
diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor
old mode 100755
new mode 100644
index 648923704a..f61254c3cf
--- a/basis/images/jpeg/jpeg.factor
+++ b/basis/images/jpeg/jpeg.factor
@@ -1,304 +1,368 @@
-! Copyright (C) 2009 Marc Fauconneau.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays combinators
-constructors grouping compression.huffman images
-images.processing io io.binary io.encodings.binary io.files
-io.streams.byte-array kernel locals math math.bitwise
-math.constants math.functions math.matrices math.order
-math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep ;
-IN: images.jpeg
-
-QUALIFIED-WITH: bitstreams bs
-
-TUPLE: jpeg-image < image
-    { headers }
-    { bitstream }
-    { color-info initial: { f f f f } }
-    { quant-tables initial: { f f } }
-    { huff-tables initial: { f f f f } }
-    { components } ;
-
-<PRIVATE
-
-CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
-
-SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
-APP JPG COM TEM RES ;
-
-! ISO/IEC 10918-1 Table B.1
-:: >marker ( byte -- marker )
-    byte
-    {
-      { [ dup HEX: CC = ] [ { DAC } ] }
-      { [ dup HEX: C4 = ] [ { DHT } ] }
-      { [ dup HEX: C9 = ] [ { JPG } ] }
-      { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
-
-      { [ dup HEX: D8 = ] [ { SOI } ] }
-      { [ dup HEX: D9 = ] [ { EOI } ] }
-      { [ dup HEX: DA = ] [ { SOS } ] }
-      { [ dup HEX: DB = ] [ { DQT } ] }
-      { [ dup HEX: DC = ] [ { DNL } ] }
-      { [ dup HEX: DD = ] [ { DRI } ] }
-      { [ dup HEX: DE = ] [ { DHP } ] }
-      { [ dup HEX: DF = ] [ { EXP } ] }
-      { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
-
-      { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
-      { [ dup HEX: FE = ] [ { COM } ] }
-      { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
-
-      { [ dup HEX: 01 = ] [ { TEM } ] }
-      [ { RES } ]
-    }
-    cond nip ;
-
-TUPLE: jpeg-chunk length type data ;
-
-CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
-
-TUPLE: jpeg-color-info
-    h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
-
-CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
-
-: jpeg> ( -- jpeg-image ) jpeg-image get ;
-
-: apply-diff ( dc color -- dc' )
-    [ diff>> + dup ] [ (>>diff) ] bi ;
-
-: fetch-tables ( component -- )
-    [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
-    [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
-    [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
-
-: read4/4 ( -- a b ) read1 16 /mod ;
-
-
-! headers
-
-: decode-frame ( header -- )
-    data>>
-    binary
-    [
-        read1 8 assert=
-        2 read be>
-        2 read be>
-        swap 2array jpeg> (>>dim)
-        read1
-        [
-            read1 read4/4 read1 <jpeg-color-info>
-            swap [ >>id ] keep jpeg> color-info>> set-nth
-        ] times
-    ] with-byte-reader ;
-
-: decode-quant-table ( chunk -- )
-    dup data>>
-    binary
-    [
-        length>>
-        2 - 65 /
-        [
-            read4/4 [ 0 assert= ] dip
-            64 read
-            swap jpeg> quant-tables>> set-nth
-        ] times
-    ] with-byte-reader ;
-
-: decode-huff-table ( chunk -- )
-    data>>
-    binary
-    [
-        1 ! %fixme: Should handle multiple tables at once
-        [
-            read4/4 swap 2 * +
-            16 read
-            dup [ ] [ + ] map-reduce read
-            binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
-            swap jpeg> huff-tables>> set-nth
-        ] times
-    ] with-byte-reader ;
-
-: decode-scan ( chunk -- )
-    data>>
-    binary
-    [
-        read1 [0,b)
-        [   drop
-            read1 jpeg> color-info>> nth clone
-            read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
-        ] map jpeg> (>>components)
-        read1 0 assert=
-        read1 63 assert=
-        read1 16 /mod [ 0 assert= ] bi@
-    ] with-byte-reader ;
-
-: singleton-first ( seq -- elt )
-    [ length 1 assert= ] [ first ] bi ;
-
-: baseline-parse ( -- )
-    jpeg> headers>>
-    {
-        [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
-        [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
-        [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
-        [ [ type>> { SOS } = ] filter singleton-first decode-scan ]
-    } cleave ;
-
-: parse-marker ( -- marker )
-    read1 HEX: FF assert=
-    read1 >marker ;
-
-: parse-headers ( -- chunks )
-    [ parse-marker dup { SOS } = not ]
-    [
-        2 read be>
-        dup 2 - read <jpeg-chunk>
-    ] [ produce ] keep dip swap suffix ;
-
-MEMO: zig-zag ( -- zz )
-    {
-        {  0  1  5  6 14 15 27 28 }
-        {  2  4  7 13 16 26 29 42 }
-        {  3  8 12 17 25 30 41 43 }
-        {  9 11 18 24 31 40 44 53 }
-        { 10 19 23 32 39 45 52 54 }
-        { 20 22 33 38 46 51 55 60 }
-        { 21 34 37 47 50 56 59 61 }
-        { 35 36 48 49 57 58 62 63 }
-    } flatten ;
-
-MEMO: yuv>bgr-matrix ( -- m )
-    {
-        { 1  2.03211  0       }
-        { 1 -0.39465 -0.58060 }
-        { 1  0        1.13983 }
-    } ;
-
-: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
-
-:: dct-vect ( u v -- basis )
-    { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
-    1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
-
-MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
-
-: mb-dim ( component -- dim )  [ h>> ] [ v>> ] bi 2array ;
-
-: all-macroblocks ( quot: ( mb -- ) -- )
-    [
-        jpeg>
-        [ dim>> 8 v/n ]
-        [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
-        [ ceiling ] map
-        coord-matrix flip concat
-    ]
-    [ each ] bi* ; inline
-
-: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
-
-: idct-factor ( b -- b' ) dct-matrix v.m ;
-
-USE: math.blas.vectors
-USE: math.blas.matrices
-
-MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
-: V.M ( x A -- x.A ) Mtranspose swap M.V ;
-: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
-
-: idct ( b -- b' ) idct-blas ;
-
-:: draw-block ( block x,y color jpeg-image -- )
-    block dup length>> sqrt >fixnum group flip
-    dup matrix-dim coord-matrix flip
-    [
-        [ first2 spin nth nth ]
-        [ x,y v+ color id>> 1- jpeg-image draw-color ] bi
-    ] with each^2 ;
-
-: sign-extend ( bits v -- v' )
-    swap [ ] [ 1- 2^ < ] 2bi
-    [ -1 swap shift 1+ + ] [ drop ] if ;
-
-: read1-jpeg-dc ( decoder -- dc )
-    [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
-
-: read1-jpeg-ac ( decoder -- run/ac )
-    [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
-
-:: decode-block ( pos color -- )
-    color dc-huff-table>> read1-jpeg-dc color apply-diff
-    64 0 <array> :> coefs
-    0 coefs set-nth
-    0 :> k!
-    [
-        color ac-huff-table>> read1-jpeg-ac
-        [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
-        { 0 0 } = not
-        k 63 < and
-    ] loop
-    coefs color quant-table>> v*
-    reverse-zigzag idct
-    ! %fixme: color hack
-    ! this eat 50% cpu time
-    color h>> 2 =
-    [ 8 group 2 matrix-zoom concat ] unless
-    pos { 8 8 } v* color jpeg> draw-block ;
-
-: decode-macroblock ( mb -- )
-    jpeg> components>>
-    [
-        [ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]
-        [ [ decode-block ] curry each ] bi
-    ] with each ;
-
-: cleanup-bitstream ( bytes -- bytes' )
-    binary [
-        [
-            { HEX: FF } read-until
-            read1 tuck HEX: 00 = and
-        ]
-        [ drop ] produce
-        swap >marker {  EOI } assert=
-        swap suffix
-        { HEX: FF } join
-    ] with-byte-reader ;
-
-: setup-bitmap ( image -- )
-    dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
-    BGR >>component-order
-    f >>upside-down?
-    dup dim>> first2 * 3 * 0 <array> >>bitmap
-    drop ;
-
-: baseline-decompress ( -- )
-    jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
-    >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
-    jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
-    jpeg> components>> [ fetch-tables ] each
-    jpeg> setup-bitmap
-    [ decode-macroblock ] all-macroblocks ;
-
-! this eats ~25% cpu time
-: color-transform ( yuv -- rgb )
-    { 128 0 0 } v+ yuv>bgr-matrix swap m.v
-    [ 0 max 255 min >fixnum ] map ;
-
-PRIVATE>
-
-: load-jpeg ( path -- image )
-    binary [
-        parse-marker { SOI } assert=
-        parse-headers
-        contents <jpeg-image>
-    ] with-file-reader
-    dup jpeg-image [
-        baseline-parse
-        baseline-decompress
-        jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
-        jpeg> [ >byte-array ] change-bitmap drop
-    ] with-variable ;
-
-M: jpeg-image load-image* ( path jpeg-image -- bitmap )
-    drop load-jpeg ;
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays combinators
+grouping compression.huffman images
+images.processing io io.binary io.encodings.binary io.files
+io.streams.byte-array kernel locals math math.bitwise
+math.constants math.functions math.matrices math.order
+math.ranges math.vectors memoize multiline namespaces
+sequences sequences.deep ;
+IN: images.jpeg
+
+QUALIFIED-WITH: bitstreams bs
+
+TUPLE: jpeg-image < image
+    { headers }
+    { bitstream }
+    { color-info initial: { f f f f } }
+    { quant-tables initial: { f f } }
+    { huff-tables initial: { f f f f } }
+    { components } ;
+
+<PRIVATE
+
+: <jpeg-image> ( headers bitstream -- image )
+    jpeg-image new swap >>bitstream swap >>headers ;
+
+SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
+APP JPG COM TEM RES ;
+
+! ISO/IEC 10918-1 Table B.1
+:: >marker ( byte -- marker )
+    byte
+    {
+      { [ dup HEX: CC = ] [ { DAC } ] }
+      { [ dup HEX: C4 = ] [ { DHT } ] }
+      { [ dup HEX: C9 = ] [ { JPG } ] }
+      { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
+
+      { [ dup HEX: D8 = ] [ { SOI } ] }
+      { [ dup HEX: D9 = ] [ { EOI } ] }
+      { [ dup HEX: DA = ] [ { SOS } ] }
+      { [ dup HEX: DB = ] [ { DQT } ] }
+      { [ dup HEX: DC = ] [ { DNL } ] }
+      { [ dup HEX: DD = ] [ { DRI } ] }
+      { [ dup HEX: DE = ] [ { DHP } ] }
+      { [ dup HEX: DF = ] [ { EXP } ] }
+      { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
+
+      { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
+      { [ dup HEX: FE = ] [ { COM } ] }
+      { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
+
+      { [ dup HEX: 01 = ] [ { TEM } ] }
+      [ { RES } ]
+    }
+    cond nip ;
+
+TUPLE: jpeg-chunk length type data ;
+
+: <jpeg-chunk> ( type length data -- jpeg-chunk )
+    jpeg-chunk new
+        swap >>data
+        swap >>length
+        swap >>type ;
+
+TUPLE: jpeg-color-info
+    h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
+
+: <jpeg-color-info> ( h v quant-table -- jpeg-color-info )
+    jpeg-color-info new
+        swap >>quant-table
+        swap >>v
+        swap >>h ;
+
+: jpeg> ( -- jpeg-image ) jpeg-image get ;
+
+: apply-diff ( dc color -- dc' )
+    [ diff>> + dup ] [ (>>diff) ] bi ;
+
+: fetch-tables ( component -- )
+    [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
+    [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
+    [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
+
+: read4/4 ( -- a b ) read1 16 /mod ;
+
+! headers
+
+: decode-frame ( header -- )
+    data>>
+    binary
+    [
+        read1 8 assert=
+        2 read be>
+        2 read be>
+        swap 2array jpeg> (>>dim)
+        read1
+        [
+            read1 read4/4 read1 <jpeg-color-info>
+            swap [ >>id ] keep jpeg> color-info>> set-nth
+        ] times
+    ] with-byte-reader ;
+
+: decode-quant-table ( chunk -- )
+    dup data>>
+    binary
+    [
+        length>>
+        2 - 65 /
+        [
+            read4/4 [ 0 assert= ] dip
+            64 read
+            swap jpeg> quant-tables>> set-nth
+        ] times
+    ] with-byte-reader ;
+
+: decode-huff-table ( chunk -- )
+    data>>
+    binary
+    [
+        1 ! %fixme: Should handle multiple tables at once
+        [
+            read4/4 swap 2 * +
+            16 read
+            dup [ ] [ + ] map-reduce read
+            binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
+            swap jpeg> huff-tables>> set-nth
+        ] times
+    ] with-byte-reader ;
+
+: decode-scan ( chunk -- )
+    data>>
+    binary
+    [
+        read1 [0,b)
+        [   drop
+            read1 jpeg> color-info>> nth clone
+            read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
+        ] map jpeg> (>>components)
+        read1 0 assert=
+        read1 63 assert=
+        read1 16 /mod [ 0 assert= ] bi@
+    ] with-byte-reader ;
+
+: singleton-first ( seq -- elt )
+    [ length 1 assert= ] [ first ] bi ;
+
+: baseline-parse ( -- )
+    jpeg> headers>>
+    {
+        [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
+        [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
+        [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
+        [ [ type>> { SOS } = ] filter singleton-first decode-scan ]
+    } cleave ;
+
+: parse-marker ( -- marker )
+    read1 HEX: FF assert=
+    read1 >marker ;
+
+: parse-headers ( -- chunks )
+    [ parse-marker dup { SOS } = not ]
+    [
+        2 read be>
+        dup 2 - read <jpeg-chunk>
+    ] [ produce ] keep dip swap suffix ;
+
+MEMO: zig-zag ( -- zz )
+    {
+        {  0  1  5  6 14 15 27 28 }
+        {  2  4  7 13 16 26 29 42 }
+        {  3  8 12 17 25 30 41 43 }
+        {  9 11 18 24 31 40 44 53 }
+        { 10 19 23 32 39 45 52 54 }
+        { 20 22 33 38 46 51 55 60 }
+        { 21 34 37 47 50 56 59 61 }
+        { 35 36 48 49 57 58 62 63 }
+    } flatten ;
+
+MEMO: yuv>bgr-matrix ( -- m )
+    {
+        { 1  2.03211  0       }
+        { 1 -0.39465 -0.58060 }
+        { 1  0        1.13983 }
+    } ;
+
+: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
+
+:: dct-vect ( u v -- basis )
+    { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
+    1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
+
+MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
+
+: mb-dim ( component -- dim )  [ h>> ] [ v>> ] bi 2array ;
+
+! : blocks ( component -- seq )
+!    mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ;
+
+: all-macroblocks ( quot: ( mb -- ) -- )
+    [
+        jpeg>
+        [ dim>> 8 v/n ]
+        [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
+        [ ceiling ] map
+        coord-matrix flip concat
+    ]
+    [ each ] bi* ; inline
+
+: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
+
+: idct-factor ( b -- b' ) dct-matrix v.m ;
+
+USE: math.blas.vectors
+USE: math.blas.matrices
+
+MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
+: V.M ( x A -- x.A ) Mtranspose swap M.V ;
+: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
+
+: idct ( b -- b' ) idct-blas ;
+
+:: draw-block ( block x,y color-id jpeg-image -- )
+    block dup length>> sqrt >fixnum group flip
+    dup matrix-dim coord-matrix flip
+    [
+        [ first2 spin nth nth ]
+        [ x,y v+ color-id jpeg-image draw-color ] bi
+    ] with each^2 ;
+
+: sign-extend ( bits v -- v' )
+    swap [ ] [ 1- 2^ < ] 2bi
+    [ -1 swap shift 1+ + ] [ drop ] if ;
+
+: read1-jpeg-dc ( decoder -- dc )
+    [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
+
+: read1-jpeg-ac ( decoder -- run/ac )
+    [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
+
+:: decode-block ( color -- pixels )
+    color dc-huff-table>> read1-jpeg-dc color apply-diff
+    64 0 <array> :> coefs
+    0 coefs set-nth
+    0 :> k!
+    [
+        color ac-huff-table>> read1-jpeg-ac
+        [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
+        { 0 0 } = not
+        k 63 < and
+    ] loop
+    coefs color quant-table>> v*
+    reverse-zigzag idct ;
+    
+:: draw-macroblock-yuv420 ( mb blocks -- )
+    mb { 16 16 } v* :> pos
+    0 blocks nth pos { 0 0 } v+ 0 jpeg> draw-block
+    1 blocks nth pos { 8 0 } v+ 0 jpeg> draw-block
+    2 blocks nth pos { 0 8 } v+ 0 jpeg> draw-block
+    3 blocks nth pos { 8 8 } v+ 0 jpeg> draw-block
+    4 blocks nth 8 group 2 matrix-zoom concat pos 1 jpeg> draw-block
+    5 blocks nth 8 group 2 matrix-zoom concat pos 2 jpeg> draw-block ;
+    
+:: draw-macroblock-yuv444 ( mb blocks -- )
+    mb { 8 8 } v* :> pos
+    3 iota [ [ blocks nth pos ] [ jpeg> draw-block ] bi ] each ;
+
+:: draw-macroblock-y ( mb blocks -- )
+    mb { 8 8 } v* :> pos
+    0 blocks nth pos 0 jpeg> draw-block
+    64 0 <array> pos 1 jpeg> draw-block
+    64 0 <array> pos 2 jpeg> draw-block ;
+ 
+    ! %fixme: color hack
+ !   color h>> 2 =
+ !   [ 8 group 2 matrix-zoom concat ] unless
+ !   pos { 8 8 } v* color jpeg> draw-block ;
+
+: decode-macroblock ( -- blocks )
+    jpeg> components>>
+    [
+        [ mb-dim first2 * iota ]
+        [ [ decode-block ] curry replicate ] bi
+    ] map concat ;
+
+: cleanup-bitstream ( bytes -- bytes' )
+    binary [
+        [
+            { HEX: FF } read-until
+            read1 tuck HEX: 00 = and
+        ]
+        [ drop ] produce
+        swap >marker {  EOI } assert=
+        swap suffix
+        { HEX: FF } join
+    ] with-byte-reader ;
+
+: setup-bitmap ( image -- )
+    dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
+    BGR >>component-order
+    f >>upside-down?
+    dup dim>> first2 * 3 * 0 <array> >>bitmap
+    drop ;
+
+ERROR: unsupported-colorspace ;
+SINGLETONS: YUV420 YUV444 Y MAGIC! ;
+
+:: detect-colorspace ( jpeg-image -- csp )
+    jpeg-image color-info>> sift :> colors
+    MAGIC!
+    colors length 1 = [ drop Y ] when
+    colors length 3 =
+    [
+        colors [ mb-dim { 1 1 } = ] all?
+        [ drop YUV444 ] when
+
+        colors unclip
+        [ [ mb-dim { 1 1 } = ] all? ]
+        [ mb-dim { 2 2 } =  ] bi* and
+        [ drop YUV420 ] when
+    ] when ;
+    
+! this eats ~50% cpu time
+: draw-macroblocks ( mbs -- )
+    jpeg> detect-colorspace
+    {
+        { YUV420 [ [ first2 draw-macroblock-yuv420 ] each ] }
+        { YUV444 [ [ first2 draw-macroblock-yuv444 ] each ] }
+        { Y      [ [ first2 draw-macroblock-y ] each ] }
+        [ unsupported-colorspace ]
+    } case ;
+
+! this eats ~25% cpu time
+: color-transform ( yuv -- rgb )
+    { 128 0 0 } v+ yuv>bgr-matrix swap m.v
+    [ 0 max 255 min >fixnum ] map ;
+
+: baseline-decompress ( -- )
+    jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
+    >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
+    jpeg> 
+    [ bitstream>> ] 
+    [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
+    jpeg> components>> [ fetch-tables ] each
+    [ decode-macroblock 2array ] accumulator 
+    [ all-macroblocks ] dip
+    jpeg> setup-bitmap draw-macroblocks 
+    jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
+    jpeg> [ >byte-array ] change-bitmap drop ;
+
+ERROR: not-a-jpeg-image ;
+
+PRIVATE>
+
+: load-jpeg ( path -- image )
+    binary [
+        parse-marker { SOI } = [ not-a-jpeg-image ] unless
+        parse-headers
+        contents <jpeg-image>
+    ] with-file-reader
+    dup jpeg-image [
+        baseline-parse
+        baseline-decompress
+    ] with-variable ;
+
+M: jpeg-image load-image* ( path jpeg-image -- bitmap )
+    drop load-jpeg ;
+
diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor
index d86b275635..dc0eec75c2 100644
--- a/basis/images/loader/loader.factor
+++ b/basis/images/loader/loader.factor
@@ -1,22 +1,24 @@
-! Copyright (C) 2009 Doug Coleman.
+! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: constructors kernel splitting unicode.case combinators
-accessors images.bitmap images.tiff images io.pathnames
-images.png ;
+USING: kernel splitting unicode.case combinators accessors images
+io.pathnames namespaces assocs ;
 IN: images.loader
 
 ERROR: unknown-image-extension extension ;
 
+<PRIVATE
+
+SYMBOL: types
+types [ H{ } clone ] initialize
+
 : image-class ( path -- class )
-    file-extension >lower {
-        { "bmp" [ bitmap-image ] }
-        { "tif" [ tiff-image ] }
-        { "tiff" [ tiff-image ] }
-        ! { "jpg" [ jpeg-image ] }
-        ! { "jpeg" [ jpeg-image ] }
-        { "png" [ png-image ] }
-        [ unknown-image-extension ]
-    } case ;
+    file-extension >lower types get ?at
+    [ unknown-image-extension ] unless ;
+
+PRIVATE>
+
+: register-image-class ( extension class -- )
+    swap types get set-at ;
 
 : load-image ( path -- image )
-    dup image-class new load-image* ;
+    dup image-class load-image* ;
diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor
index c5b84de221..bb470d8dd8 100755
--- a/basis/images/png/png.factor
+++ b/basis/images/png/png.factor
@@ -1,21 +1,27 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors constructors images io io.binary io.encodings.ascii
+USING: accessors images io io.binary io.encodings.ascii
 io.encodings.binary io.encodings.string io.files io.files.info kernel
-sequences io.streams.limited fry combinators arrays math
-checksums checksums.crc32 compression.inflate grouping byte-arrays ;
+sequences io.streams.limited fry combinators arrays math checksums
+checksums.crc32 compression.inflate grouping byte-arrays images.loader ;
 IN: images.png
 
-TUPLE: png-image < image chunks
-width height bit-depth color-type compression-method
-filter-method interlace-method uncompressed ;
+SINGLETON: png-image
+"png" png-image register-image-class
 
-CONSTRUCTOR: png-image ( -- image )
-V{ } clone >>chunks ;
+TUPLE: loading-png
+    chunks
+    width height bit-depth color-type compression-method
+    filter-method interlace-method uncompressed ;
+
+: <loading-png> ( -- image )
+    loading-png new
+    V{ } clone >>chunks ;
 
 TUPLE: png-chunk length type data ;
 
-CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
+: <png-chunk> ( -- png-chunk )
+    png-chunk new ; inline
 
 CONSTANT: png-header
     B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
@@ -29,22 +35,21 @@ ERROR: bad-png-header header ;
 
 ERROR: bad-checksum ;
 
-: read-png-chunks ( image -- image )
+: read-png-chunks ( loading-png -- loading-png )
     <png-chunk>
     4 read be> [ >>length ] [ 4 + ] bi
     read dup crc32 checksum-bytes
     4 read = [ bad-checksum ] unless
     4 cut-slice
-    [ ascii decode >>type ]
-    [ B{ } like >>data ] bi*
+    [ ascii decode >>type ] [ B{ } like >>data ] bi*
     [ over chunks>> push ] 
     [ type>> ] bi "IEND" =
     [ read-png-chunks ] unless ;
 
-: find-chunk ( image string -- chunk )
+: find-chunk ( loading-png string -- chunk )
     [ chunks>> ] dip '[ type>> _ = ] find nip ;
 
-: parse-ihdr-chunk ( image -- image )
+: parse-ihdr-chunk ( loading-png -- loading-png )
     dup "IHDR" find-chunk data>> {
         [ [ 0 4 ] dip subseq be> >>width ]
         [ [ 4 8 ] dip subseq be> >>height ]
@@ -55,44 +60,44 @@ ERROR: bad-checksum ;
         [ [ 12 ] dip nth >>interlace-method ]
     } cleave ;
 
-: find-compressed-bytes ( image -- bytes )
+: find-compressed-bytes ( loading-png -- bytes )
     chunks>> [ type>> "IDAT" = ] filter
     [ data>> ] map concat ;
 
-: fill-image-data ( image -- image )
-    dup [ width>> ] [ height>> ] bi 2array >>dim ;
 
-: zlib-data ( png-image -- bytes ) 
+: zlib-data ( loading-png -- bytes ) 
     chunks>> [ type>> "IDAT" = ] find nip data>> ;
 
 ERROR: unknown-color-type n ;
 ERROR: unimplemented-color-type image ;
 
-: inflate-data ( image -- bytes )
+: inflate-data ( loading-png -- bytes )
     zlib-data zlib-inflate ; 
 
-: decode-greyscale ( image -- image )
+: decode-greyscale ( loading-png -- loading-png )
     unimplemented-color-type ;
 
-: decode-truecolor ( image -- image )
-    {
-        [ inflate-data ]
-        [ dim>> first 3 * 1 + group reverse-png-filter ]
-        [ swap >byte-array >>bitmap drop ]
-        [ RGB >>component-order drop ]
-        [ ]
+: png-image-bytes ( loading-png -- byte-array )
+    [ inflate-data ] [ width>> 3 * 1 + ] bi group
+    reverse-png-filter ;
+
+: decode-truecolor ( loading-png -- loading-png )
+    [ <image> ] dip {
+        [ png-image-bytes >>bitmap ]
+        [ [ width>> ] [ height>> ] bi 2array >>dim ]
+        [ drop RGB >>component-order ]
     } cleave ;
     
-: decode-indexed-color ( image -- image )
+: decode-indexed-color ( loading-png -- loading-png )
     unimplemented-color-type ;
 
-: decode-greyscale-alpha ( image -- image )
+: decode-greyscale-alpha ( loading-png -- loading-png )
     unimplemented-color-type ;
 
-: decode-truecolor-alpha ( image -- image )
+: decode-truecolor-alpha ( loading-png -- loading-png )
     unimplemented-color-type ;
 
-: decode-png ( image -- image ) 
+: decode-png ( loading-png -- loading-png ) 
     dup color-type>> {
         { 0 [ decode-greyscale ] }
         { 2 [ decode-truecolor ] }
@@ -103,13 +108,11 @@ ERROR: unimplemented-color-type image ;
     } case ;
 
 : load-png ( path -- image )
-    [ binary <file-reader> ] [ file-info size>> ] bi
-    stream-throws <limited-stream> [
-        <png-image>
+    binary stream-throws <limited-file-reader> [
+        <loading-png>
         read-png-header
         read-png-chunks
         parse-ihdr-chunk
-        fill-image-data
         decode-png
     ] with-input-stream ;
 
diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor
index 27dc25de73..e00b05f2e7 100755
--- a/basis/images/tiff/tiff.factor
+++ b/basis/images/tiff/tiff.factor
@@ -1,24 +1,38 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs byte-arrays classes combinators
-compression.lzw constructors endian fry grouping images io
+compression.lzw endian fry grouping images io
 io.binary io.encodings.ascii io.encodings.binary
 io.encodings.string io.encodings.utf8 io.files kernel math
 math.bitwise math.order math.parser pack prettyprint sequences
-strings math.vectors specialized-arrays.float locals ;
+strings math.vectors specialized-arrays.float locals
+images.loader ;
 IN: images.tiff
 
-TUPLE: tiff-image < image ;
+SINGLETON: tiff-image
 
-TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
-CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
+TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
+
+: <loading-tiff> ( -- tiff )
+    loading-tiff new V{ } clone >>ifds ;
 
 TUPLE: ifd count ifd-entries next
 processed-tags strips bitmap ;
-CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
+
+: <ifd> ( count ifd-entries next -- ifd )
+    ifd new
+        swap >>next
+        swap >>ifd-entries
+        swap >>count ;
 
 TUPLE: ifd-entry tag type count offset/value ;
-CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ;
+
+: <ifd-entry> ( tag type count offset/value -- ifd-entry )
+    ifd-entry new
+        swap >>offset/value
+        swap >>count
+        swap >>type
+        swap >>tag ;
 
 SINGLETONS: photometric-interpretation
 photometric-interpretation-white-is-zero
@@ -409,7 +423,7 @@ ERROR: bad-small-ifd-type n ;
         [ nip unhandled-ifd-entry swap ]
     } case ;
 
-: process-ifds ( parsed-tiff -- parsed-tiff )
+: process-ifds ( loading-tiff -- loading-tiff )
     [
         [
             dup ifd-entries>>
@@ -442,7 +456,7 @@ ERROR: unhandled-compression compression ;
     '[
         _ group
         [ _ group unclip [ v+ ] accumulate swap suffix concat ] map
-        concat >byte-array
+        B{ } concat-as
     ] change-bitmap ;
 
 : strips-predictor ( ifd -- ifd )
@@ -482,18 +496,6 @@ ERROR: unknown-component-order ifd ;
         [ unknown-component-order ]
     } case ;
 
-: normalize-alpha-data ( seq -- byte-array )
-    B{ } like dup
-    byte-array>float-array
-    4 <sliced-groups>
-    [
-        dup fourth dup 0 = [
-            2drop
-        ] [
-            [ 3 head-slice ] dip '[ _ / ] change-each
-        ] if
-    ] each ;
-
 : handle-alpha-data ( ifd -- ifd )
     dup extra-samples find-tag {
         { extra-samples-associated-alpha-data [ ] }
@@ -503,21 +505,21 @@ ERROR: unknown-component-order ifd ;
     } case ;
 
 : ifd>image ( ifd -- image )
-    {
-        [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
-        [ ifd-component-order f ]
-        [ bitmap>> ]
-    } cleave tiff-image boa ;
+    [ <image> ] dip {
+        [ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ]
+        [ ifd-component-order >>component-order ]
+        [ bitmap>> >>bitmap ]
+    } cleave ;
 
 : tiff>image ( image -- image )
     ifds>> [ ifd>image ] map first ;
 
-: with-tiff-endianness ( parsed-tiff quot -- )
+: with-tiff-endianness ( loading-tiff quot -- )
     [ dup endianness>> ] dip with-endianness ; inline
 
-: load-tiff-ifds ( path -- parsed-tiff )
+: load-tiff-ifds ( path -- loading-tiff )
     binary [
-        <parsed-tiff>
+        <loading-tiff>
         read-header [
             dup ifd-offset>> read-ifds
             process-ifds
@@ -549,10 +551,10 @@ ERROR: unknown-component-order ifd ;
         drop "no planar configuration" throw
     ] if ;
 
-: process-tif-ifds ( parsed-tiff -- )
+: process-tif-ifds ( loading-tiff -- )
     ifds>> [ process-ifd ] each ;
 
-: load-tiff ( path -- parsed-tiff )
+: load-tiff ( path -- loading-tiff )
     [ load-tiff-ifds dup ] keep
     binary [
         [ process-tif-ifds ] with-tiff-endianness
@@ -561,3 +563,5 @@ ERROR: unknown-component-order ifd ;
 ! tiff files can store several images -- we just take the first for now
 M: tiff-image load-image* ( path tiff-image -- image )
     drop load-tiff tiff>image ;
+
+{ "tif" "tiff" } [ tiff-image register-image-class ] each
diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor
index 67c7cb13dd..0e8a8576fb 100644
--- a/basis/io/servers/connection/connection-docs.factor
+++ b/basis/io/servers/connection/connection-docs.factor
@@ -79,12 +79,12 @@ HELP: threaded-server
 { $class-description "The class of threaded servers. New instances are created with " { $link <threaded-server> } ". This class may be subclassed, and instances of subclasses should be created with " { $link new-threaded-server } ". See " { $link "server-config" } " for slot documentation." } ;
 
 HELP: new-threaded-server
-{ $values { "class" class } { "threaded-server" threaded-server } }
+{ $values { "encoding" "an encoding descriptor" } { "class" class } { "threaded-server" threaded-server } }
 { $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ;
 
 HELP: <threaded-server>
-{ $values { "threaded-server" threaded-server } }
-{ $description "Creates a new threaded server. Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ;
+{ $values { "encoding" "an encoding descriptor" } { "threaded-server" threaded-server } }
+{ $description "Creates a new threaded server with streams encoded " { $snippet "encoding" } ". Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ;
 
 HELP: remote-address
 { $var-description "Variable holding the address specifier of the current client connection. See " { $link "network-addressing" } "." } ;
diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor
index ab99531eb4..14100d3f04 100644
--- a/basis/io/servers/connection/connection-tests.factor
+++ b/basis/io/servers/connection/connection-tests.factor
@@ -3,10 +3,10 @@ USING: tools.test io.servers.connection io.sockets namespaces
 io.servers.connection.private kernel accessors sequences
 concurrency.promises io.encodings.ascii io threads calendar ;
 
-[ t ] [ <threaded-server> listen-on empty? ] unit-test
+[ t ] [ ascii <threaded-server> listen-on empty? ] unit-test
 
 [ f ] [
-    <threaded-server>
+    ascii <threaded-server>
         25 internet-server >>insecure
     listen-on
     empty?
@@ -19,16 +19,16 @@ concurrency.promises io.encodings.ascii io threads calendar ;
     and
 ] unit-test
 
-[ ] [ <threaded-server> init-server drop ] unit-test
+[ ] [ ascii <threaded-server> init-server drop ] unit-test
 
 [ 10 ] [
-    <threaded-server>
+    ascii <threaded-server>
         10 >>max-connections
     init-server semaphore>> count>> 
 ] unit-test
 
 [ ] [
-    <threaded-server>
+    ascii <threaded-server>
         5 >>max-connections
         0 >>insecure
         [ "Hello world." write stop-this-server ] >>handler
diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor
index 8eafe1b5bf..de75165c7a 100644
--- a/basis/io/servers/connection/connection.factor
+++ b/basis/io/servers/connection/connection.factor
@@ -11,34 +11,27 @@ combinators.short-circuit ;
 IN: io.servers.connection
 
 TUPLE: threaded-server
-name
-log-level
+{ name initial: "server" }
+{ log-level initial: DEBUG }
 secure insecure
-secure-config
-sockets
+{ secure-config initial-quot: [ <secure-config> ] }
+{ sockets initial-quot: [ V{ } clone ] }
 max-connections
 semaphore
-timeout
+{ timeout initial-quot: [ 1 minutes ] }
 encoding
-handler
-ready ;
+{ handler initial: [ "No handler quotation" throw ] }
+{ ready initial-quot: [ <flag> ] } ;
 
 : local-server ( port -- addrspec ) "localhost" swap <inet> ;
 
 : internet-server ( port -- addrspec ) f swap <inet> ;
 
-: new-threaded-server ( class -- threaded-server )
+: new-threaded-server ( encoding class -- threaded-server )
     new
-        "server" >>name
-        DEBUG >>log-level
-        ascii >>encoding
-        1 minutes >>timeout
-        V{ } clone >>sockets
-        <secure-config> >>secure-config
-        [ "No handler quotation" throw ] >>handler
-        <flag> >>ready ; inline
+        swap >>encoding ;
 
-: <threaded-server> ( -- threaded-server )
+: <threaded-server> ( encoding -- threaded-server )
     threaded-server new-threaded-server ;
 
 GENERIC: handle-client* ( threaded-server -- )
diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor
index 98b9a2ce23..6e41f083b7 100644
--- a/basis/io/sockets/sockets.factor
+++ b/basis/io/sockets/sockets.factor
@@ -117,7 +117,7 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ;
     <byte-array> glue ;
 
 : inet6-bytes ( seq -- bytes )
-    [ 2 >be ] { } map-as concat >byte-array ;
+    [ 2 >be ] { } map-as B{ } concat-as ;
 
 PRIVATE>
 
diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor
index b1b07a08c0..fd441e4c4d 100755
--- a/basis/io/streams/limited/limited.factor
+++ b/basis/io/streams/limited/limited.factor
@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math io io.encodings destructors accessors
-sequences namespaces byte-vectors fry combinators ;
+USING: accessors byte-vectors combinators destructors fry io
+io.encodings io.files io.files.info kernel math namespaces
+sequences ;
 IN: io.streams.limited
 
 TUPLE: limited-stream stream count limit mode stack ;
@@ -16,6 +17,12 @@ SINGLETONS: stream-throws stream-eofs ;
         swap >>stream
         0 >>count ;
 
+: <limited-file-reader> ( path encoding mode -- stream' )
+    [
+        [ <file-reader> ]
+        [ drop file-info size>> ] 2bi
+    ] dip <limited-stream> ;
+
 GENERIC# limit 2 ( stream limit mode -- stream' )
 
 M: decoder limit ( stream limit mode -- stream' )
diff --git a/basis/json/reader/authors.txt b/basis/json/reader/authors.txt
index 44b06f94bc..d269b4ffb5 100644
--- a/basis/json/reader/authors.txt
+++ b/basis/json/reader/authors.txt
@@ -1 +1,3 @@
 Chris Double
+Peter Burns
+Philipp Winkler
diff --git a/basis/json/reader/reader-tests.factor b/basis/json/reader/reader-tests.factor
index e97d45babe..14a54b89c0 100644
--- a/basis/json/reader/reader-tests.factor
+++ b/basis/json/reader/reader-tests.factor
@@ -19,6 +19,8 @@ IN: json.reader.tests
 { 10.25 } [ "1025e-2" json> ] unit-test
 { 0.125 } [ "0.125" json> ] unit-test
 { -0.125 } [ "-0.125" json> ] unit-test
+{ -0.00125 } [ "-0.125e-2" json> ] unit-test
+{ -012.5 } [ "-0.125e+2" json> ] unit-test
 
 ! not widely supported by javascript, but allowed in the grammar, and a nice
 ! feature to get
@@ -31,6 +33,7 @@ IN: json.reader.tests
 { 8 9 10 12 13 34 47 92 } >string 1array [ <" "\b\t\n\f\r\"\/\\" "> json> ] unit-test
 { HEX: abcd } >string 1array [ <" "\uaBCd" "> json> ] unit-test
 
+{ H{ { "a" { } } { "b" 123 } } } [ "{\"a\":[],\"b\":123}" json> ] unit-test
 { { } } [ "[]" json> ] unit-test 
 { { 1 "two" 3.0 } } [ <" [1, "two", 3.0] "> json> ] unit-test
 { H{ } } [ "{}" json> ] unit-test
diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor
index 887a7a50e5..9886e316d7 100644
--- a/basis/json/reader/reader.factor
+++ b/basis/json/reader/reader.factor
@@ -1,61 +1,103 @@
-! Copyright (C) 2008 Peter Burns.
+! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel peg peg.ebnf math.parser math.parser.private strings math
-math.functions sequences arrays vectors hashtables assocs
-prettyprint json ;
+USING: arrays assocs combinators io io.streams.string json
+kernel math math.parser math.parser.private prettyprint
+sequences strings vectors ;
 IN: json.reader
 
 <PRIVATE
+: value ( char -- num char )
+    1string " \t\r\n,:}]" read-until
+    [
+        append
+        [ string>float ]
+        [ [ "eE." index ] any? [ >integer ] unless ] bi
+    ] dip ;
 
-: grammar-list>vector ( seq -- vec ) first2 values swap prefix ;
+DEFER: j-string
+    
+: convert-string ( str -- str )
+    read1
+    {
+        { CHAR: b [ 8 ] }
+        { CHAR: f [ 12 ] }
+        { CHAR: n [ CHAR: \n ] }
+        { CHAR: r [ CHAR: \r ] }
+        { CHAR: t [ CHAR: \t ] }
+        { CHAR: u [ 4 read hex> ] }
+        [ ]
+    } case
+    dup
+    [ 1string append j-string append ]
+    [ drop ] if ;
+    
+: j-string ( -- str )
+    "\\\"" read-until CHAR: \" =
+    [ convert-string ] unless ;
+    
+: second-last ( seq -- second-last )
+    [ length 2 - ] keep nth ; inline
 
-! Grammar for JSON from RFC 4627
-EBNF: (json>)
+: third-last ( seq -- third-last )
+    [ length 3 - ] keep nth ; inline
+    
+: last2 ( seq -- second-last last )
+    [ second-last ] [ last ] bi ; inline
 
-ws = (" " | "\r" | "\t" | "\n")*
+: last3 ( seq -- third-last second-last last )
+    [ third-last ] [ last2 ] bi ; inline
 
-true = "true" => [[ t ]]
-false = "false" => [[ f ]]
-null = "null" => [[ json-null ]]
+: v-over-push ( vec -- vec' )
+    dup length 2 >=
+    [
+        dup
+        [ pop ]
+        [ last ] bi push
+    ] when ;
 
-hex = [0-9a-fA-F]
-char = '\\"'  [[ CHAR: "  ]]
-     | "\\\\" [[ CHAR: \  ]]
-     | "\\/"  [[ CHAR: /  ]]
-     | "\\b"  [[ 8        ]]
-     | "\\f"  [[ 12       ]]
-     | "\\n"  [[ CHAR: \n ]]
-     | "\\r"  [[ CHAR: \r ]]
-     | "\\t"  [[ CHAR: \t ]]
-     | "\\u" (hex hex hex hex) [[ hex> ]] => [[ second ]]
-     | [^"\]
-string = '"' char*:cs '"' => [[ cs >string ]]
+: v-pick-push ( vec -- vec' )
+    dup length 3 >=
+    [
+        dup
+        [ pop ]
+        [ second-last ] bi push
+    ] when ;
 
-sign = ("-" | "+")? => [[ "-" = "-" "" ? ]]
-digits = [0-9]+     => [[ >string ]]
-decimal = "." digits  => [[ concat ]]
-exp = ("e" | "E") sign digits => [[ concat ]]
-number = sign digits decimal? exp? => [[ dup concat swap fourth [ string>float ] [ string>number ] if ]]
+: (close-array) ( accum -- accum' )
+    dup last vector? [ v-over-push ] unless
+    dup pop >array over push ;
 
-elements = value ("," value)* => [[ grammar-list>vector ]]
-array = "[" elements?:arr "]" => [[ arr >array ]]
-
-pair = ws string:key ws ":" value:val => [[ { key val } ]]
-members = pair ("," pair)* => [[ grammar-list>vector ]]
-object = "{" members?:hash "}" => [[ hash >hashtable ]]
-
-val = true
-    | false
-    | null
-    | string
-    | number
-    | array
-    | object
-
-value = ws val:v ws => [[ v ]]
-
-;EBNF
+: (close-hash) ( accum -- accum' )
+    dup length 3 >= [ v-over-push ] when
+    dup dup [ pop ] dip pop swap
+    zip H{ } assoc-clone-like over push ;
+                                                 
+: scan ( accum char -- accum )
+    ! 2dup . . ! Great for debug...
+    [
+        {
+            { CHAR: \" [ j-string over push ] }
+            { CHAR: [  [ V{ } clone over push ] }
+            { CHAR: ,  [ v-over-push ] }
+            { CHAR: ]  [ (close-array) ] }
+            { CHAR: {  [ 2 [ V{ } clone over push ] times ] }
+            { CHAR: :  [ v-pick-push ] }
+            { CHAR: }  [ (close-hash) ] }
+            { CHAR: \u000020 [ ] }
+            { CHAR: \t [ ] }
+            { CHAR: \r [ ] }
+            { CHAR: \n [ ] }
+            { CHAR: t  [ 3 read drop t over push ] }
+            { CHAR: f  [ 4 read drop f over push ] }
+            { CHAR: n  [ 3 read drop json-null over push ] }
+            [ value [ over push ] dip [ scan ] when*  ]
+        } case 
+    ] when* ;
 
+: (json-parser>) ( string -- object )
+    [ V{ } clone [ read1 dup ] [ scan ] while drop first ] with-string-reader ;
+    
 PRIVATE>
-
-: json> ( string -- object ) (json>) ;
\ No newline at end of file
+    
+: json> ( string -- object )
+    (json-parser>) ;
\ No newline at end of file
diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor
index 0f13b6dd86..7470ef9daa 100644
--- a/basis/listener/listener-docs.factor
+++ b/basis/listener/listener-docs.factor
@@ -13,6 +13,10 @@ ARTICLE: "listener-watch" "Watching variables in the listener"
 "Hiding all visible variables:"
 { $subsection hide-all-vars } ;
 
+HELP: only-use-vocabs
+{ $values { "vocabs" "a sequence of vocabulary specifiers" } }
+{ $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ;
+
 HELP: show-var
 { $values { "var" "a variable name" } }
 { $description "Adds a variable to the watch list; its value will be printed by the listener after every expression." } ;
diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index 4563f61ab7..34d9eac121 100644
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory
 namespaces parser lexer sequences strings io.styles
 vectors words generic system combinators continuations debugger
 definitions compiler.units accessors colors prettyprint fry
-sets vocabs.parser source-files.errors locals ;
+sets vocabs.parser source-files.errors locals vocabs vocabs.loader ;
 IN: listener
 
 GENERIC: stream-read-quot ( stream -- quot/f )
@@ -124,6 +124,78 @@ t error-summary? set-global
 
 PRIVATE>
 
+SYMBOL: interactive-vocabs
+
+{
+    "accessors"
+    "arrays"
+    "assocs"
+    "combinators"
+    "compiler"
+    "compiler.errors"
+    "compiler.units"
+    "continuations"
+    "debugger"
+    "definitions"
+    "editors"
+    "help"
+    "help.apropos"
+    "help.lint"
+    "help.vocabs"
+    "inspector"
+    "io"
+    "io.files"
+    "io.pathnames"
+    "kernel"
+    "listener"
+    "math"
+    "math.order"
+    "memory"
+    "namespaces"
+    "parser"
+    "prettyprint"
+    "see"
+    "sequences"
+    "slicing"
+    "sorting"
+    "stack-checker"
+    "strings"
+    "syntax"
+    "tools.annotations"
+    "tools.crossref"
+    "tools.disassembler"
+    "tools.errors"
+    "tools.memory"
+    "tools.profiler"
+    "tools.test"
+    "tools.threads"
+    "tools.time"
+    "vocabs"
+    "vocabs.loader"
+    "vocabs.refresh"
+    "vocabs.hierarchy"
+    "words"
+    "scratchpad"
+} interactive-vocabs set-global
+
+: only-use-vocabs ( vocabs -- )
+    clear-manifest
+    [ vocab ] filter
+    [
+        vocab
+        [ find-vocab-root not ]
+        [ source-loaded?>> +done+ eq? ] bi or
+    ] filter
+    [ use-vocab ] each ;
+
+: with-interactive-vocabs ( quot -- )
+    [
+        <manifest> manifest set
+        "scratchpad" set-current-vocab
+        interactive-vocabs get only-use-vocabs
+        call
+    ] with-scope ; inline
+
 : listener ( -- )
     [ [ { } (listener) ] with-interactive-vocabs ] with-return ;
 
diff --git a/basis/math/bits/bits-docs.factor b/basis/math/bits/bits-docs.factor
index 6ae83f7af0..36043a5576 100644
--- a/basis/math/bits/bits-docs.factor
+++ b/basis/math/bits/bits-docs.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.syntax help.markup math ;
+USING: help.syntax help.markup math sequences ;
 IN: math.bits
 
 ABOUT: "math.bits"
@@ -24,3 +24,7 @@ HELP: make-bits
     { $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" }
     { $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" }
 } ;
+
+HELP: unbits
+{ $values { "seq" sequence } { "number" integer } }
+{ $description "Turns a sequence of booleans, of the same format made by the " { $link bits } " class, and calculates the number that it represents as little-endian." } ;
diff --git a/basis/math/bits/bits-tests.factor b/basis/math/bits/bits-tests.factor
index b17d9d8b6e..c6f4c6e8fa 100644
--- a/basis/math/bits/bits-tests.factor
+++ b/basis/math/bits/bits-tests.factor
@@ -29,3 +29,6 @@ IN: math.bits.tests
 [ t ] [
     1067811677921310779 >bignum make-bits last
 ] unit-test
+
+[ 6 ] [ 6 make-bits unbits ] unit-test
+[ 6 ] [ 6 3 <bits> >array unbits ] unit-test
diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor
index 72b83a991f..0fbfdf0bd9 100644
--- a/basis/math/bits/bits.factor
+++ b/basis/math/bits/bits.factor
@@ -14,3 +14,6 @@ M: bits length length>> ;
 M: bits nth-unsafe number>> swap bit? ;
 
 INSTANCE: bits immutable-sequence
+
+: unbits ( seq -- number )
+    <reversed> 0 [ [ 1 shift ] dip [ 1+ ] when ] reduce ;
diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor
index 66d813bab8..e47de14dba 100644
--- a/basis/math/functions/functions-tests.factor
+++ b/basis/math/functions/functions-tests.factor
@@ -22,6 +22,7 @@ IN: math.functions.tests
 [ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test
 
 [ t ] [ 0 0 ^ fp-nan? ] unit-test
+[ 0.0 ] [ 0.0 1.0 ^ ] unit-test
 [ 1/0. ] [ 0 -2 ^ ] unit-test
 [ t ] [ 0 0.0 ^ fp-nan? ] unit-test
 [ 1/0. ] [ 0 -2.0 ^ ] unit-test
@@ -162,3 +163,4 @@ IN: math.functions.tests
 [ 2.5  ] [ 1.0 2.5 1.0 lerp ] unit-test
 [ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test
 
+[ C{ 1 2 } ] [ C{ 1 2 } 1 ^ ] unit-test
diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
index a1bf9480d5..19a8f17a0c 100644
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@@ -34,8 +34,9 @@ M: integer ^n
 M: ratio ^n
     [ >fraction ] dip [ ^n ] curry bi@ / ;
 
-M: float ^n
-    (^n) ;
+M: float ^n (^n) ;
+
+M: complex ^n (^n) ;
 
 : integer^ ( x y -- z )
     dup 0 > [ ^n ] [ neg ^n recip ] if ; inline
@@ -88,7 +89,7 @@ PRIVATE>
 
 : ^ ( x y -- z )
     {
-        { [ over zero? ] [ nip 0^ ] }
+        { [ over 0 = ] [ nip 0^ ] }
         { [ dup integer? ] [ integer^ ] }
         { [ 2dup real^? ] [ fpow ] }
         [ ^complex ]
diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor
old mode 100755
new mode 100644
index cfdbe17c06..d6bee78c14
--- a/basis/math/matrices/matrices.factor
+++ b/basis/math/matrices/matrices.factor
@@ -1,12 +1,12 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order math.vectors
-sequences sequences.private accessors columns ;
+USING: accessors arrays columns kernel math math.bits
+math.order math.vectors sequences sequences.private fry ;
 IN: math.matrices
 
 ! Matrices
 : zero-matrix ( m n -- matrix )
-    [ nip 0 <array> ] curry map ;
+    '[ _ 0 <array> ] replicate ;
 
 : identity-matrix ( n -- matrix )
     #! Make a nxn identity matrix.
@@ -60,4 +60,8 @@ PRIVATE>
     gram-schmidt [ normalize ] map ;
 
 : cross-zip ( seq1 seq2 -- seq1xseq2 )
-    [ [ 2array ] with map ] curry map ;
\ No newline at end of file
+    [ [ 2array ] with map ] curry map ;
+    
+: m^n ( m n -- n ) 
+    make-bits over first length identity-matrix
+    [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;
diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor
index 39a8a2c4fe..be457dcd00 100644
--- a/basis/opengl/gl/gl.factor
+++ b/basis/opengl/gl/gl.factor
@@ -1872,7 +1872,7 @@ GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint*
 GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ;
 
 GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
-GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
+GL-FUNCTION: GLint glGetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
 
 CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD
 CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0
diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
index f0edab23a3..d43e1736d1 100755
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -50,7 +50,7 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
         [ dup 1 = [ next-power-of-2 ] unless ] map
     ] unless ;
 
-: (tex-image) ( image bitmap -- )
+: tex-image ( image bitmap -- )
     [
         [ GL_TEXTURE_2D 0 GL_RGBA ] dip
         [ dim>> adjust-texture-dim first2 0 ]
@@ -58,9 +58,11 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
     ] dip
     glTexImage2D ;
 
-: (tex-sub-image) ( image -- )
+: tex-sub-image ( image -- )
     [ GL_TEXTURE_2D 0 0 0 ] dip
-    [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
+    [ dim>> first2 ]
+    [ component-order>> component-order>format ]
+    [ bitmap>> ] tri
     glTexSubImage2D ;
 
 : init-texture ( -- )
@@ -173,8 +175,8 @@ PRIVATE>
         GL_TEXTURE_BIT [
             GL_TEXTURE_2D swap glBindTexture
             non-power-of-2-textures? get
-            [ dup bitmap>> (tex-image) ]
-            [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
+            [ dup bitmap>> tex-image ]
+            [ [ f tex-image ] [ tex-sub-image ] bi ] if
         ] do-attribs
     ] keep ;
 
diff --git a/basis/porter-stemmer/porter-stemmer.factor b/basis/porter-stemmer/porter-stemmer.factor
index 35ed84aaf4..4765df10d7 100644
--- a/basis/porter-stemmer/porter-stemmer.factor
+++ b/basis/porter-stemmer/porter-stemmer.factor
@@ -1,5 +1,5 @@
+USING: combinators kernel math parser sequences splitting ;
 IN: porter-stemmer
-USING: kernel math parser sequences combinators splitting ;
 
 : consonant? ( i str -- ? )
     2dup nth dup "aeiou" member? [
diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor
index cd10278760..a2696b1263 100644
--- a/basis/prettyprint/prettyprint-tests.factor
+++ b/basis/prettyprint/prettyprint-tests.factor
@@ -3,7 +3,8 @@ kernel math namespaces parser prettyprint prettyprint.config
 prettyprint.sections sequences tools.test vectors words
 effects splitting generic.standard prettyprint.private
 continuations generic compiler.units tools.continuations
-tools.continuations.private eval accessors make vocabs.parser see ;
+tools.continuations.private eval accessors make vocabs.parser see
+listener ;
 IN: prettyprint.tests
 
 [ "4" ] [ 4 unparse ] unit-test
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 46572de47b..270b55fda6 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -277,8 +277,6 @@ IN: tools.deploy.shaker
                 compiled-generic-crossref
                 compiler-impl
                 compiler.errors:compiler-errors
-                ! definition-observers
-                interactive-vocabs
                 lexer-factory
                 print-use-hook
                 root-cache
diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor
index 666e051088..f8a8bb96aa 100644
--- a/basis/tools/hexdump/hexdump.factor
+++ b/basis/tools/hexdump/hexdump.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.streams.string kernel math math.parser
-namespaces sequences splitting grouping strings ascii
-byte-arrays byte-vectors ;
+USING: arrays ascii byte-arrays byte-vectors grouping io
+io.encodings.binary io.files io.streams.string kernel math
+math.parser namespaces sequences splitting strings ;
 IN: tools.hexdump
 
 <PRIVATE
@@ -42,3 +42,6 @@ M: byte-vector hexdump. hexdump-bytes ;
 
 : hexdump ( byte-array -- str )
     [ hexdump. ] with-string-writer ;
+
+: hexdump-file ( path -- )
+    binary file-contents hexdump. ;
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index 38fb220c69..dfce3d3eee 100755
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -217,4 +217,3 @@ M: world check-world-pixel-format
 : with-world-pixel-format ( world quot -- )
     [ dup dup world-pixel-format-attributes <pixel-format> ]
     dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline
-
diff --git a/basis/ui/images/images.factor b/basis/ui/images/images.factor
index 2b1caa8ab9..519217a644 100755
--- a/basis/ui/images/images.factor
+++ b/basis/ui/images/images.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces cache images images.loader accessors assocs
 kernel opengl opengl.gl opengl.textures ui.gadgets.worlds
-memoize ;
+memoize images.tiff ;
 IN: ui.images
 
 TUPLE: image-name path ;
@@ -29,4 +29,4 @@ PRIVATE>
     rendered-image draw-scaled-texture ;
 
 : image-dim ( image-name -- dim )
-    cached-image dim>> ;
\ No newline at end of file
+    cached-image dim>> ;
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index 144530399c..aee19279a4 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -206,8 +206,11 @@ PRIVATE>
 : open-world-window ( world -- )
     dup pref-dim >>dim dup relayout graft ;
 
+: open-window* ( gadget title/attributes -- window )
+    ?attributes <world> [ open-world-window ] keep ;
+
 : open-window ( gadget title/attributes -- )
-    ?attributes <world> open-world-window ;
+    open-window* drop ;
 
 : set-fullscreen ( gadget ? -- )
     [ find-world ] dip (set-fullscreen) ;
diff --git a/build-support/factor.sh b/build-support/factor.sh
index ba5815cfc1..d5b8bd5411 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -174,6 +174,7 @@ find_os() {
         CYGWIN_NT-5.2-WOW64) OS=winnt;;
         *CYGWIN_NT*) OS=winnt;;
         *CYGWIN*) OS=winnt;;
+        MINGW32*) OS=winnt;;
         *darwin*) OS=macosx;;
         *Darwin*) OS=macosx;;
         *linux*) OS=linux;;
diff --git a/core/assocs/assocs-tests.factor b/core/assocs/assocs-tests.factor
index c473ac0dfa..75607b0258 100644
--- a/core/assocs/assocs-tests.factor
+++ b/core/assocs/assocs-tests.factor
@@ -130,3 +130,7 @@ unit-test
 
 [ 1 f ] [ 1 H{ } ?at ] unit-test
 [ 2 t ] [ 1 H{ { 1 2 } } ?at ] 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
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index d655b99c30..62ab9f86ae 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -22,6 +22,9 @@ M: assoc assoc-like drop ;
 : ?at ( key assoc -- value/key ? )
     2dup at* [ 2nip t ] [ 2drop f ] if ; inline
 
+: maybe-set-at ( value key assoc -- changed? )
+    3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
+
 <PRIVATE
 
 : (assoc-each) ( assoc quot -- seq quot' )
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index f5182a0210..24538229c6 100644
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -80,6 +80,7 @@ IN: bootstrap.syntax
     ">>"
     "call-next-method"
     "initial:"
+    "initial-quot:"
     "read-only"
     "call("
     "execute("
diff --git a/core/classes/parser/parser.factor b/core/classes/parser/parser.factor
index bd2e6ea4a0..0697537d12 100644
--- a/core/classes/parser/parser.factor
+++ b/core/classes/parser/parser.factor
@@ -6,7 +6,7 @@ IN: classes.parser
 : save-class-location ( class -- )
     location remember-class ;
 
-: create-class-in ( word -- word )
+: create-class-in ( string -- word )
     current-vocab create
     dup save-class-location
     dup predicate-word dup set-word save-location ;
diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index b95507c78b..350b594274 100644
--- a/core/classes/tuple/parser/parser-tests.factor
+++ b/core/classes/tuple/parser/parser-tests.factor
@@ -1,7 +1,7 @@
 IN: classes.tuple.parser.tests
 USING: accessors classes.tuple.parser lexer words classes
 sequences math kernel slots tools.test parser compiler.units
-arrays classes.tuple eval ;
+arrays classes.tuple eval multiline ;
 
 TUPLE: test-1 ;
 
@@ -142,3 +142,11 @@ TUPLE: parsing-corner-case x ;
         "    x 3 }"
     } "\n" join eval( -- tuple )
 ] [ error>> unexpected-eof? ] must-fail-with
+
+
+[ ] [
+    <" USE: sequences
+    IN: classes.tuple.tests
+    TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;">
+    eval( -- )
+] unit-test
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index e3452194c6..4b23578a29 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -1,11 +1,12 @@
-USING: definitions generic kernel kernel.private math math.constants
-parser sequences tools.test words assocs namespaces quotations
-sequences.private classes continuations generic.single
-generic.standard effects classes.tuple classes.tuple.private arrays
-vectors strings compiler.units accessors classes.algebra calendar
-prettyprint io.streams.string splitting summary columns math.order
-classes.private slots slots.private eval see words.symbol
-compiler.errors parser.notes ;
+USING: accessors arrays assocs calendar classes classes.algebra
+classes.private classes.tuple classes.tuple.private columns
+compiler.errors compiler.units continuations definitions
+effects eval generic generic.single generic.standard grouping
+io.streams.string kernel kernel.private math math.constants
+math.order namespaces parser parser.notes prettyprint
+quotations random see sequences sequences.private slots
+slots.private splitting strings summary threads tools.test
+vectors vocabs words words.symbol ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -421,7 +422,6 @@ TUPLE: redefinition-problem-2 ;
 [ t ] [ 3 redefinition-problem'? ] unit-test
 
 ! Hardcore unit tests
-USE: threads
 
 \ thread "slots" word-prop "slots" set
 
@@ -439,8 +439,6 @@ USE: threads
     ] with-compilation-unit
 ] unit-test
 
-USE: vocabs
-
 \ vocab "slots" word-prop "slots" set
 
 [ ] [
@@ -731,3 +729,50 @@ DEFER: redefine-tuple-twice
 [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
 
 [ t ] [ \ redefine-tuple-twice symbol? ] unit-test
+
+TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ;
+SLOT: winner?
+
+[ t ] [ lucky-number new n>> integer? ] unit-test
+
+: compiled-lucky-number ( -- tuple ) lucky-number new ;
+
+[ t ] [ compiled-lucky-number n>> integer? ] unit-test
+
+! Reshaping initial-quot:
+lucky-number new dup n>> 2array "luckiest-number" set
+
+[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
+
+[ ] [ "USING: accessors random ; IN: classes.tuple.tests TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } { winner? initial-quot: [ t ] } ;" eval( -- ) ] unit-test
+
+[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
+[ t ] [ "luckiest-number" get first winner?>> ] unit-test
+
+! invalid-quot: together with type declaration
+TUPLE: decl-initial-quot { x integer initial-quot: [ 1 ] } ;
+
+[ t ] [ decl-initial-quot new x>> integer? ] unit-test
+
+: compiled-decl-initial-quot ( -- tuple ) decl-initial-quot new ;
+
+[ t ] [ compiled-decl-initial-quot x>> integer? ] unit-test
+
+! invalid-quot: with read-only
+TUPLE: read-only-initial-quot { x integer read-only initial-quot: [ 1 ] } ;
+
+[ t ] [ read-only-initial-quot new x>> integer? ] unit-test
+
+: compiled-read-only-initial-quot ( -- tuple ) read-only-initial-quot new ;
+
+[ t ] [ compiled-read-only-initial-quot x>> integer? ] unit-test
+
+! Specifying both initial: and initial-quot: should fail
+2 [
+    [
+        "IN: classes.tuple.test TUPLE: redundant-decl { x initial: 0 initial-quot: [ 0 ] } ;"
+        eval( -- )
+    ]
+    [ error>> duplicate-initial-values? ]
+    must-fail-with
+] times
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 225176f4e5..4ca57a59ed 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -50,6 +50,9 @@ M: tuple class layout-of 2 slot { word } declare ;
 
 PRIVATE>
 
+: initial-quots? ( class -- ? )
+    all-slots [ initial-quot>> ] any? ;
+
 : initial-values ( class -- slots )
     all-slots [ initial>> ] map ;
 
@@ -66,7 +69,7 @@ PRIVATE>
 
 GENERIC: slots>tuple ( seq class -- tuple )
 
-M: tuple-class slots>tuple
+M: tuple-class slots>tuple ( seq class -- tuple )
     check-slots pad-slots
     tuple-layout <tuple> [
         [ tuple-size ]
@@ -146,12 +149,21 @@ ERROR: bad-superclass class ;
 : define-boa-check ( class -- )
     dup boa-check-quot "boa-check" set-word-prop ;
 
+: tuple-initial-quots-quot ( class -- quot )
+    all-slots [ initial-quot>> ] filter
+    [
+        [
+            [ initial-quot>> % \ over , ] [ offset>> , ] bi \ set-slot ,
+        ] each
+    ] [ ] make f like ;
+
 : tuple-prototype ( class -- prototype )
-    [ initial-values ] keep
-    over [ ] any? [ slots>tuple ] [ 2drop f ] if ;
+    [ initial-values ] [ over [ ] any? ] [ initial-quots? or ] tri
+    [ slots>tuple ] [ 2drop f ] if ;
 
 : define-tuple-prototype ( class -- )
-    dup tuple-prototype "prototype" set-word-prop ;
+    dup [ tuple-prototype ] [ tuple-initial-quots-quot ] bi 2array
+    dup [ ] any? [ drop f ] unless "prototype" set-word-prop ;
 
 : prepare-slots ( slots superclass -- slots' )
     [ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
@@ -173,10 +185,16 @@ ERROR: bad-superclass class ;
 : define-tuple-layout ( class -- )
     dup make-tuple-layout "layout" set-word-prop ;
 
+: calculate-initial-value ( slot-spec -- value )
+    dup initial>> [ ] [
+        dup initial-quot>>
+        [ call( -- obj ) ] [ drop f ] ?if
+    ] ?if ;
+
 : compute-slot-permutation ( new-slots old-slots -- triples )
     [ [ [ name>> ] map ] bi@ [ index ] curry map ]
     [ drop [ class>> ] map ]
-    [ drop [ initial>> ] map ]
+    [ drop [ calculate-initial-value ] map ]
     2tri 3array flip ;
 
 : update-slot ( old-values n class initial -- value )
@@ -340,8 +358,11 @@ M: tuple tuple-hashcode
 M: tuple hashcode* tuple-hashcode ;
 
 M: tuple-class new
-    dup "prototype" word-prop
-    [ (clone) ] [ tuple-layout <tuple> ] ?if ;
+    dup "prototype" word-prop [
+        first2 [ (clone) ] dip [ call( obj -- obj ) ] when*
+    ] [
+        tuple-layout <tuple>
+    ] ?if ;
 
 M: tuple-class boa
     [ "boa-check" word-prop [ call ] when* ]
diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor
index 536ee19c8b..1abcba0720 100644
--- a/core/destructors/destructors-docs.factor
+++ b/core/destructors/destructors-docs.factor
@@ -8,16 +8,16 @@ HELP: dispose
 $nl
 "No further operations can be performed on a disposable object after this call."
 $nl
-"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
+"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $slot "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
 { $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
 $nl
-"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ;
+"The default implementation assumes the object has a " { $snippet "disposed" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link t } "." } ;
 
 HELP: dispose*
 { $values { "disposable" "a disposable object" } }
 { $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." }
 { $notes
-    "This word should not be called directly. It can be implemented on objects with a " { $snippet "disposable" } " slot to ensure that the object is only disposed once."
+    "This word should not be called directly. It can be implemented on objects with a " { $slot "disposed" } " slot to ensure that the object is only disposed once."
 } ;
 
 HELP: with-disposal
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 8d52dcaa2c..94eb0a865c 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -112,68 +112,6 @@ SYMBOL: bootstrap-syntax
         call
     ] with-scope ; inline
 
-SYMBOL: interactive-vocabs
-
-{
-    "accessors"
-    "arrays"
-    "assocs"
-    "combinators"
-    "compiler"
-    "compiler.errors"
-    "compiler.units"
-    "continuations"
-    "debugger"
-    "definitions"
-    "editors"
-    "help"
-    "help.apropos"
-    "help.lint"
-    "help.vocabs"
-    "inspector"
-    "io"
-    "io.files"
-    "io.pathnames"
-    "kernel"
-    "listener"
-    "math"
-    "math.order"
-    "memory"
-    "namespaces"
-    "parser"
-    "prettyprint"
-    "see"
-    "sequences"
-    "slicing"
-    "sorting"
-    "stack-checker"
-    "strings"
-    "syntax"
-    "tools.annotations"
-    "tools.crossref"
-    "tools.disassembler"
-    "tools.errors"
-    "tools.memory"
-    "tools.profiler"
-    "tools.test"
-    "tools.threads"
-    "tools.time"
-    "vocabs"
-    "vocabs.loader"
-    "vocabs.refresh"
-    "vocabs.hierarchy"
-    "words"
-    "scratchpad"
-} interactive-vocabs set-global
-
-: with-interactive-vocabs ( quot -- )
-    [
-        <manifest> manifest set
-        "scratchpad" set-current-vocab
-        interactive-vocabs get only-use-vocabs
-        call
-    ] with-scope ; inline
-
 SYMBOL: print-use-hook
 
 print-use-hook [ [ ] ] initialize
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 304ded0adb..c8be08e79b 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -6,7 +6,7 @@ classes classes.algebra slots.private combinators accessors
 words sequences.private assocs alien quotations hashtables ;
 IN: slots
 
-TUPLE: slot-spec name offset class initial read-only ;
+TUPLE: slot-spec name offset class initial initial-quot read-only ;
 
 PREDICATE: reader < word "reader" word-prop ;
 
@@ -190,6 +190,7 @@ ERROR: bad-slot-attribute key ;
     dup empty? [
         unclip {
             { initial: [ [ first >>initial ] [ rest ] bi ] }
+            { initial-quot: [ [ first >>initial-quot ] [ rest ] bi ] }
             { read-only [ [ t >>read-only ] dip ] }
             [ bad-slot-attribute ]
         } case
@@ -197,7 +198,14 @@ ERROR: bad-slot-attribute key ;
 
 ERROR: bad-initial-value name ;
 
+ERROR: duplicate-initial-values slot ;
+
+: check-duplicate-initial-values ( slot-spec -- slot-spec )
+    dup [ initial>> ] [ initial-quot>> ] bi and
+    [ duplicate-initial-values ] when ;
+
 : check-initial-value ( slot-spec -- slot-spec )
+    check-duplicate-initial-values
     dup initial>> [
         [ ] [
             dup [ initial>> ] [ class>> ] bi instance?
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 56ac9fa36e..8093b6345b 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -245,7 +245,9 @@ IN: bootstrap.syntax
     ] define-core-syntax
     
     "initial:" "syntax" lookup define-symbol
-    
+
+    "initial-quot:" "syntax" lookup define-symbol
+
     "read-only" "syntax" lookup define-symbol
 
     "call(" [ \ call-effect parse-call( ] define-core-syntax
diff --git a/core/vocabs/parser/parser-docs.factor b/core/vocabs/parser/parser-docs.factor
index e54993b6eb..96619a7114 100644
--- a/core/vocabs/parser/parser-docs.factor
+++ b/core/vocabs/parser/parser-docs.factor
@@ -65,7 +65,6 @@ $nl
 "Words for working with the current manifest:"
 { $subsection use-vocab }
 { $subsection unuse-vocab }
-{ $subsection only-use-vocabs }
 { $subsection add-qualified }
 { $subsection add-words-from }
 { $subsection add-words-excluding }
@@ -117,10 +116,6 @@ HELP: unuse-vocab
 { $description "Removes a vocabulary from the current manifest." }
 { $notes "This word is used to implement " { $link POSTPONE: UNUSE: } "." } ;
 
-HELP: only-use-vocabs
-{ $values { "vocabs" "a sequence of vocabulary specifiers" } }
-{ $description "Replaces the current manifest's vocabulary search path with the given set of vocabularies." } ;
-
 HELP: add-qualified
 { $values { "vocab" "a vocabulary specifier" } { "prefix" string } }
 { $description "Adds the vocabulary's words, prefixed with the given string, to the current manifest." }
diff --git a/core/vocabs/parser/parser.factor b/core/vocabs/parser/parser.factor
index 5305b42809..98b8b8d0e8 100644
--- a/core/vocabs/parser/parser.factor
+++ b/core/vocabs/parser/parser.factor
@@ -52,8 +52,6 @@ M: extra-words equal?
 
 C: <extra-words> extra-words
 
-<PRIVATE
-
 : clear-manifest ( -- )
     manifest get
     [ search-vocab-names>> clear-assoc ]
@@ -61,6 +59,8 @@ C: <extra-words> extra-words
     [ qualified-vocabs>> delete-all ]
     tri ;
 
+<PRIVATE
+
 : (add-qualified) ( qualified -- )
     manifest get qualified-vocabs>> push ;
 
@@ -126,9 +126,6 @@ TUPLE: no-current-vocab ;
         2bi
     ] [ drop ] if ;
 
-: only-use-vocabs ( vocabs -- )
-    clear-manifest [ vocab ] filter [ use-vocab ] each ;
-
 TUPLE: qualified vocab prefix words ;
 
 : <qualified> ( vocab prefix -- qualified )
diff --git a/extra/brainfuck/authors.txt b/extra/brainfuck/authors.txt
new file mode 100644
index 0000000000..e091bb8164
--- /dev/null
+++ b/extra/brainfuck/authors.txt
@@ -0,0 +1 @@
+John Benediktsson
diff --git a/extra/brainfuck/brainfuck-docs.factor b/extra/brainfuck/brainfuck-docs.factor
new file mode 100644
index 0000000000..c11c05a2e2
--- /dev/null
+++ b/extra/brainfuck/brainfuck-docs.factor
@@ -0,0 +1,49 @@
+! Copyright (C) 2009 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: help.syntax help.markup brainfuck strings ;
+
+IN: brainfuck 
+
+HELP: run-brainfuck
+{ $values { "code" string } }
+{ $description
+    "A brainfuck program is a sequence of eight commands that are "
+    "executed sequentially.  An instruction pointer begins at the first "
+    "command, and each command is executed until the program terminates "
+    "when the instruction pointer moves beyond the last command.\n"
+    "\n"
+    "The eight language commands, each consisting of a single character, "
+    "are the following:\n"
+    { $table
+        { "Character" "Meaning" }
+        { ">" "increment the data pointer (to point to the next cell to the right)." }
+        { "<" "decrement the data pointer (to point to the next cell to the left)." }
+        { "+" "increment (increase by one) the byte at the data pointer." }
+        { "-" "decrement (decrease by one) the byte at the data pointer." }
+        { "." "output the value of the byte at the data pointer." }
+        { "," "accept one byte of input, storing its value in the byte at the data pointer." }
+        { "[" "if the byte at the data pointer is zero, then instead of moving the instruction pointer forward to the next command, jump it forward to the command after the matching ] command*." }
+        { "]" "if the byte at the data pointer is nonzero, then instead of moving the instruction pointer forward to the next command, jump it back to the command after the matching [ command*." }
+    }
+    "\n"
+    "Brainfuck programs can be translated into C using the following "
+    "substitutions, assuming ptr is of type unsigned char* and has been "
+    "initialized to point to an array of zeroed bytes:\n"
+    { $table
+        { "Character" "C equivalent" }
+        { ">" "++ptr;" }
+        { "<" "--ptr;" }
+        { "+" "++*ptr;" }
+        { "-" "--*ptr;" }
+        { "." "putchar(*ptr);" }
+        { "," "*ptr=getchar();" }
+        { "[" "while (*ptr) {" }
+        { "]" "}" }
+    }
+} ;
+
+HELP: get-brainfuck
+{ $values { "code" string } { "result" string } }
+{ $description "Returns the output from a brainfuck program as a result string." }  
+{ $see-also run-brainfuck } ;
diff --git a/extra/brainfuck/brainfuck-tests.factor b/extra/brainfuck/brainfuck-tests.factor
new file mode 100644
index 0000000000..2fa6b84a19
--- /dev/null
+++ b/extra/brainfuck/brainfuck-tests.factor
@@ -0,0 +1,62 @@
+! Copyright (C) 2009 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: brainfuck kernel io.streams.string math math.parser math.ranges 
+multiline quotations sequences tools.test ;
+
+
+[ "+" run-brainfuck ] must-infer
+[ "+" get-brainfuck ] must-infer
+
+! Hello World!
+
+[ "Hello World!\n" ] [ <" ++++++++++[>+++++++>++++++++++>+++>+<<<<-]
+                          >++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.
+                          ------.--------.>+.>. "> get-brainfuck ] unit-test
+
+! Addition (single-digit)
+
+[ "8" ] [ "35" [ ",>++++++[<-------->-],[<+>-]<." 
+          get-brainfuck ] with-string-reader ] unit-test
+
+! Multiplication (single-digit)
+
+[ "8\0" ] [ "24" [ <" ,>,>++++++++[<------<------>>-]
+                    <<[>[>+>+<<-]>>[<<+>>-]<<<-]
+                    >>>++++++[<++++++++>-],<.>. "> 
+          get-brainfuck ] with-string-reader ] unit-test
+
+! Division (single-digit, integer)
+
+[ "3" ] [ "62" [ <" ,>,>++++++[-<--------<-------->>]
+                    <<[
+                    >[->+>+<<]
+                    >[-<<-
+                    [>]>>>[<[>>>-<<<[-]]>>]<<]
+                    >>>+
+                    <<[-<<+>>]
+                    <<<]
+                    >[-]>>>>[-<<<<<+>>>>>]
+                    <<<<++++++[-<++++++++>]<. ">
+           get-brainfuck ] with-string-reader ] unit-test 
+
+! Uppercase
+
+[ "A" ] [ "a\n" [ ",----------[----------------------.,----------]"
+          get-brainfuck ] with-string-reader ] unit-test 
+
+! cat
+
+[ "ABC" ] [ "ABC\0" [ ",[.,]" get-brainfuck ] with-string-reader ] unit-test
+
+! Squares of numbers from 0 to 100
+
+100 [0,b] [ dup * number>string ] map "\n" join "\n" append 1quotation
+[ <" ++++[>+++++<-]>[<+++++>-]+<+[
+     >[>+>+<<-]++>>[<<+>>-]>>>[-]++>[-]+
+     >>>+[[-]++++++>>>]<<<[[<++++++++<++>>-]+<.<[>----<-]<]
+     <<[>>>>>[>>>[-]+++++++++<[>-<-]+++++++++>
+     [-[<->-]+[<<<]]<[>+<-]>]<<-]<<-] ">
+  get-brainfuck ] unit-test
+
+
diff --git a/extra/brainfuck/brainfuck.factor b/extra/brainfuck/brainfuck.factor
new file mode 100644
index 0000000000..f29e7dc8ae
--- /dev/null
+++ b/extra/brainfuck/brainfuck.factor
@@ -0,0 +1,77 @@
+! Copyright (C) 2009 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors assocs fry io io.streams.string kernel macros math 
+peg.ebnf prettyprint quotations sequences strings ;
+
+IN: brainfuck
+
+<PRIVATE
+
+TUPLE: brainfuck pointer memory ;
+
+: <brainfuck> ( -- brainfuck ) 
+    0 H{ } clone brainfuck boa ;
+
+: get-memory ( brainfuck -- brainfuck value )
+    dup [ pointer>> ] [ memory>> ] bi at 0 or ;
+
+: set-memory ( brainfuck value -- brainfuck )
+    over [ pointer>> ] [ memory>> ] bi set-at ;
+
+: (+) ( brainfuck n -- brainfuck )
+    [ get-memory ] dip + 255 bitand set-memory ;
+
+: (-) ( brainfuck n -- brainfuck )
+    [ get-memory ] dip - 255 bitand set-memory ;
+
+: (?) ( brainfuck -- brainfuck t/f )
+    get-memory 0 = not ;
+
+: (.) ( brainfuck -- brainfuck )
+    get-memory 1string write ;
+
+: (,) ( brainfuck -- brainfuck )
+    read1 set-memory ;
+
+: (>) ( brainfuck n -- brainfuck )
+    [ dup pointer>> ] dip + >>pointer ;
+
+: (<) ( brainfuck n -- brainfuck ) 
+    [ dup pointer>> ] dip - >>pointer ;
+
+: (#) ( brainfuck -- brainfuck ) 
+    dup 
+    [ "ptr=" write pointer>> pprint ] 
+    [ ",mem=" write memory>> pprint nl ] bi ;
+
+: compose-all ( seq -- quot ) 
+    [ ] [ compose ] reduce ;
+
+EBNF: parse-brainfuck
+
+inc-ptr  = (">")+  => [[ length 1quotation [ (>) ] append ]]
+dec-ptr  = ("<")+  => [[ length 1quotation [ (<) ] append ]]
+inc-mem  = ("+")+  => [[ length 1quotation [ (+) ] append ]]
+dec-mem  = ("-")+  => [[ length 1quotation [ (-) ] append ]]
+output   = "."  => [[ [ (.) ] ]]
+input    = ","  => [[ [ (,) ] ]]
+debug    = "#"  => [[ [ (#) ] ]]
+space    = (" "|"\t"|"\r\n"|"\n")+ => [[ [ ] ]] 
+unknown  = (.)  => [[ "Invalid input" throw ]]
+
+ops   = inc-ptr|dec-ptr|inc-mem|dec-mem|output|input|debug|space
+loop  = "[" {loop|ops}+ "]" => [[ second compose-all 1quotation [ [ (?) ] ] prepend [ while ] append ]]
+
+code  = (loop|ops|unknown)*  => [[ compose-all ]]
+
+;EBNF
+
+PRIVATE>
+
+MACRO: run-brainfuck ( code -- )
+    [ <brainfuck> ] swap parse-brainfuck [ drop flush ] 3append ;
+
+: get-brainfuck ( code -- result ) 
+    [ run-brainfuck ] with-string-writer ; inline 
+
diff --git a/extra/brainfuck/summary.txt b/extra/brainfuck/summary.txt
new file mode 100644
index 0000000000..792dbbae08
--- /dev/null
+++ b/extra/brainfuck/summary.txt
@@ -0,0 +1 @@
+Brainfuck programming language.
diff --git a/extra/constructors/authors.txt b/extra/constructors/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/constructors/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/constructors/constructors-tests.factor b/extra/constructors/constructors-tests.factor
new file mode 100644
index 0000000000..59ecb8ff77
--- /dev/null
+++ b/extra/constructors/constructors-tests.factor
@@ -0,0 +1,86 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test constructors calendar kernel accessors
+combinators.short-circuit initializers math ;
+IN: constructors.tests
+
+TUPLE: stock-spread stock spread timestamp ;
+
+CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
+   now >>timestamp ;
+
+SYMBOL: AAPL
+
+[ t ] [
+    AAPL 1234 <stock-spread>
+    {
+        [ stock>> AAPL eq? ]
+        [ spread>> 1234 = ]
+        [ timestamp>> timestamp? ]
+    } 1&&
+] unit-test
+
+TUPLE: ct1 a ;
+TUPLE: ct2 < ct1 b ;
+TUPLE: ct3 < ct2 c ;
+TUPLE: ct4 < ct3 d ;
+
+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
diff --git a/extra/constructors/constructors.factor b/extra/constructors/constructors.factor
new file mode 100644
index 0000000000..b8fe598f84
--- /dev/null
+++ b/extra/constructors/constructors.factor
@@ -0,0 +1,68 @@
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs classes classes.tuple effects.parser
+fry generalizations generic.standard kernel lexer locals macros
+parser sequences slots vocabs words arrays ;
+IN: constructors
+
+! An experiment
+
+: initializer-name ( class -- word )
+    name>> "initialize-" prepend ;
+
+: lookup-initializer ( class -- word/f )
+    initializer-name "initializers" lookup ;
+
+: initializer-word ( class -- word )
+    initializer-name
+    "initializers" create-vocab create
+    [ t "initializer" set-word-prop ] [ ] bi ;
+
+: define-initializer-generic ( name -- )
+    initializer-word (( object -- object )) define-simple-generic ;
+
+: define-initializer ( class def -- )
+    [ drop define-initializer-generic ]
+    [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
+
+: all-slots-assoc ( class -- slots )
+    superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ;
+
+MACRO:: slots>constructor ( class slots -- quot )
+    class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
+    class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
+    slots length
+    default-params length
+    '[
+        _ narray slot-assoc swap zip 
+        default-params swap assoc-union values _ firstn class boa
+    ] ;
+
+:: (define-constructor) ( constructor-word class effect def -- word quot )
+    constructor-word
+    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? -- )
+    constructor-word class effect def (define-constructor)
+    class superclasses [ lookup-initializer ] map sift
+    reverse? [ reverse ] when
+    '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
+
+: scan-constructor ( -- class word )
+    scan-word [ name>> "<" ">" surround create-in ] keep ;
+
+: 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 ;
+
+"initializers" create-vocab drop
diff --git a/basis/constructors/summary.txt b/extra/constructors/summary.txt
similarity index 100%
rename from basis/constructors/summary.txt
rename to extra/constructors/summary.txt
diff --git a/basis/constructors/tags.txt b/extra/constructors/tags.txt
similarity index 100%
rename from basis/constructors/tags.txt
rename to extra/constructors/tags.txt
diff --git a/extra/cursors/authors.txt b/extra/cursors/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/extra/cursors/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/extra/cursors/cursors-tests.factor b/extra/cursors/cursors-tests.factor
new file mode 100644
index 0000000000..8294eb05e8
--- /dev/null
+++ b/extra/cursors/cursors-tests.factor
@@ -0,0 +1,39 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cursors math tools.test make ;
+IN: cursors.tests
+
+[ 2 t ] [ { 2 3 } [ even? ] find ] unit-test
+[ 3 t ] [ { 2 3 } [ odd? ] find ] unit-test
+[ f f ] [ { 2 4 } [ odd? ] find ] unit-test
+
+[ { 2 3 } ] [ { 1 2 } [ 1 + ] map ] unit-test
+[ { 2 3 } ] [ { 1 2 } [ [ 1 + , ] each ] { 2 3 } make ] unit-test
+
+[ t ] [ { } [ odd? ] all? ] unit-test
+[ t ] [ { 1 3 5 } [ odd? ] all? ] unit-test
+[ f ] [ { 1 3 5 6 } [ odd? ] all? ] unit-test
+
+[ t ] [ { } [ odd? ] all? ] unit-test
+[ t ] [ { 1 3 5 } [ odd? ] any? ] unit-test
+[ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test
+
+[ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test
+
+[ { } ]
+[ { 1 2 } { } [ + ] 2map ] unit-test
+
+[ { 11 } ]
+[ { 1 2 } { 10 } [ + ] 2map ] unit-test
+
+[ { 11 22 } ]
+[ { 1 2 } { 10 20 } [ + ] 2map ] unit-test
+
+[ { } ]
+[ { 1 2 } { } { } [ + + ] 3map ] unit-test
+
+[ { 111 } ]
+[ { 1 2 } { 10 } { 100 200 } [ + + ] 3map ] unit-test
+
+[ { 111 222 } ]
+[ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test
diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor
new file mode 100644
index 0000000000..14cc1fdf7f
--- /dev/null
+++ b/extra/cursors/cursors.factor
@@ -0,0 +1,152 @@
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays generalizations kernel math sequences
+sequences.private ;
+IN: cursors
+
+GENERIC: cursor-done? ( cursor -- ? )
+GENERIC: cursor-get-unsafe ( cursor -- obj )
+GENERIC: cursor-advance ( cursor -- )
+GENERIC: cursor-valid? ( cursor -- ? )
+GENERIC: cursor-write ( obj cursor -- )
+
+ERROR: cursor-ended cursor ;
+
+: cursor-get ( cursor -- obj )
+    dup cursor-done?
+    [ cursor-ended ] [ cursor-get-unsafe ] if ; inline
+
+: find-done? ( cursor quot -- ? )
+    over cursor-done?
+    [ 2drop t ] [ [ cursor-get-unsafe ] dip call ] if ; inline
+
+: cursor-until ( cursor quot -- )
+    [ find-done? not ]
+    [ drop cursor-advance ] bi-curry bi-curry while ; inline
+ 
+: cursor-each ( cursor quot -- )
+    [ f ] compose cursor-until ; inline
+
+: cursor-find ( cursor quot -- obj ? )
+    [ cursor-until ] [ drop ] 2bi
+    dup cursor-done? [ drop f f ] [ cursor-get t ] if ; inline
+
+: cursor-any? ( cursor quot -- ? )
+    cursor-find nip ; inline
+
+: cursor-all? ( cursor quot -- ? )
+    [ not ] compose cursor-any? not ; inline
+
+: cursor-map-quot ( quot to -- quot' )
+    [ [ call ] dip cursor-write ] 2curry ; inline
+
+: cursor-map ( from to quot -- )
+    swap cursor-map-quot cursor-each ; inline
+
+: cursor-write-if ( obj quot to -- )
+    [ over [ call ] dip ] dip
+    [ cursor-write ] 2curry when ; inline
+
+: cursor-filter-quot ( quot to -- quot' )
+    [ cursor-write-if ] 2curry ; inline
+
+: cursor-filter ( from to quot -- )
+    swap cursor-filter-quot cursor-each ; inline
+
+TUPLE: from-sequence { seq sequence } { n integer } ;
+
+: >from-sequence< ( from-sequence -- n seq )
+    [ n>> ] [ seq>> ] bi ; inline
+
+M: from-sequence cursor-done? ( cursor -- ? )
+    >from-sequence< length >= ;
+
+M: from-sequence cursor-valid?
+    >from-sequence< bounds-check? not ;
+
+M: from-sequence cursor-get-unsafe
+    >from-sequence< nth-unsafe ;
+
+M: from-sequence cursor-advance
+    [ 1+ ] change-n drop ;
+
+: >input ( seq -- cursor )
+    0 from-sequence boa ; inline
+
+: iterate ( seq quot iterator -- )
+    [ >input ] 2dip call ; inline
+
+: each ( seq quot -- ) [ cursor-each ] iterate ; inline
+: find ( seq quot -- ? ) [ cursor-find ] iterate ; inline
+: any? ( seq quot -- ? ) [ cursor-any? ] iterate ; inline
+: all? ( seq quot -- ? ) [ cursor-all? ] iterate ; inline
+
+TUPLE: to-sequence { seq sequence } { exemplar sequence } ;
+
+M: to-sequence cursor-write
+    seq>> push ;
+
+: freeze ( cursor -- seq )
+    [ seq>> ] [ exemplar>> ] bi like ; inline
+
+: >output ( seq -- cursor )
+    [ [ length ] keep new-resizable ] keep
+    to-sequence boa ; inline
+
+: transform ( seq quot transformer -- newseq )
+    [ [ >input ] [ >output ] bi ] 2dip
+    [ call ]
+    [ 2drop freeze ] 3bi ; inline
+
+: map ( seq quot -- ) [ cursor-map ] transform ; inline
+: filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline
+
+: find-done2? ( cursor cursor quot -- ? )
+    2over [ cursor-done? ] either?
+    [ 3drop t ] [ [ [ cursor-get-unsafe ] bi@ ] dip call ] if ; inline
+
+: cursor-until2 ( cursor cursor quot -- )
+    [ find-done2? not ]
+    [ drop [ cursor-advance ] bi@ ] bi-curry bi-curry bi-curry while ; inline
+
+: cursor-each2 ( cursor cursor quot -- )
+    [ f ] compose cursor-until2 ; inline
+
+: cursor-map2 ( from to quot -- )
+    swap cursor-map-quot cursor-each2 ; inline
+
+: iterate2 ( seq1 seq2 quot iterator -- )
+    [ [ >input ] bi@ ] 2dip call ; inline
+
+: transform2 ( seq1 seq2 quot transformer -- newseq )
+    [ over >output [ [ >input ] [ >input ] bi* ] dip ] 2dip
+    [ call ]
+    [ 2drop nip freeze ] 4 nbi ; inline
+
+: 2each ( seq1 seq2 quot -- ) [ cursor-each2 ] iterate2 ; inline
+: 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
+
+: find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
+    3 nover 3array [ cursor-done? ] any?
+    [ 4 ndrop t ] [ [ [ cursor-get-unsafe ] tri@ ] dip call ] if ; inline
+
+: cursor-until3 ( cursor cursor quot -- )
+    [ find-done3? not ]
+    [ drop [ cursor-advance ] tri@ ] bi-curry bi-curry bi-curry bi-curry while ; inline
+
+: cursor-each3 ( cursor cursor quot -- )
+    [ f ] compose cursor-until3 ; inline
+
+: cursor-map3 ( from to quot -- )
+    swap cursor-map-quot cursor-each3 ; inline
+
+: iterate3 ( seq1 seq2 seq3 quot iterator -- )
+    [ [ >input ] tri@ ] 2dip call ; inline
+
+: transform3 ( seq1 seq2 seq3 quot transformer -- newseq )
+    [ pick >output [ [ >input ] [ >input ] [ >input ] tri* ] dip ] 2dip
+    [ call ]
+    [ 2drop 2nip freeze ] 5 nbi ; inline
+
+: 3each ( seq1 seq2 seq3 quot -- ) [ cursor-each3 ] iterate3 ; inline
+: 3map ( seq1 seq2 seq3 quot -- ) [ cursor-map3 ] transform3 ; inline
diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor
index 5d4149867b..ded10b66cb 100644
--- a/extra/fuel/fuel.factor
+++ b/extra/fuel/fuel.factor
@@ -134,14 +134,16 @@ PRIVATE>
 
 ! Scaffold support
 
+: fuel-scaffold-name ( devname -- )
+    [ developer-name set ] when* ;
+
 : fuel-scaffold-vocab ( root name devname -- )
-    developer-name set dup [ scaffold-vocab ] dip
+    [ fuel-scaffold-name dup [ scaffold-vocab ] dip ] with-scope
     dup require vocab-source-path (normalize-path) fuel-eval-set-result ;
 
 : fuel-scaffold-help ( name devname -- )
-    developer-name set
-    dup require dup scaffold-help vocab-docs-path
-    (normalize-path) fuel-eval-set-result ;
+    [ fuel-scaffold-name dup require dup scaffold-help ] with-scope
+    vocab-docs-path (normalize-path) fuel-eval-set-result ;
 
 : fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
 
diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor
index 6c43e646df..f20e67f9bc 100644
--- a/extra/fuel/help/help.factor
+++ b/extra/fuel/help/help.factor
@@ -4,7 +4,8 @@
 USING: accessors arrays assocs combinators help help.crossref
 help.markup help.topics io io.streams.string kernel make namespaces
 parser prettyprint sequences summary help.vocabs
-vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see ;
+vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see
+listener ;
 
 IN: fuel.help
 
diff --git a/extra/fuel/remote/remote.factor b/extra/fuel/remote/remote.factor
index d13aff800a..d3b48efac6 100644
--- a/extra/fuel/remote/remote.factor
+++ b/extra/fuel/remote/remote.factor
@@ -11,9 +11,8 @@ IN: fuel.remote
     [ [ print-error-and-restarts ] error-hook set listener ] with-scope ;
 
 : server ( port -- server )
-    <threaded-server>
+    utf8 <threaded-server>
         "tty-server" >>name
-        utf8 >>encoding
         swap local-server >>insecure
         [ start-listener ] >>handler
         f >>timeout ;
diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor
index 3e3279ece7..608667bae7 100644
--- a/extra/fuel/xref/xref.factor
+++ b/extra/fuel/xref/xref.factor
@@ -23,13 +23,13 @@ IN: fuel.xref
     dup dup >vocab-link where normalize-loc 4array ;
 
 : sort-xrefs ( seq -- seq' )
-    [ [ first ] dip first <=> ] sort ; inline
+    [ [ first ] dip first <=> ] sort ;
 
 : format-xrefs ( seq -- seq' )
-    [ word? ] filter [ word>xref ] map ; inline
+    [ word? ] filter [ word>xref ] map ;
 
 : filter-prefix ( seq prefix -- seq )
-    [ drop-prefix nip length 0 = ] curry filter prune ; inline
+    [ drop-prefix nip length 0 = ] curry filter prune ;
 
 MEMO: (vocab-words) ( name -- seq )
     >vocab-link words [ name>> ] map ;
@@ -37,10 +37,10 @@ MEMO: (vocab-words) ( name -- seq )
 : current-words ( -- seq )
     manifest get
     [ search-vocabs>> ] [ qualified-vocabs>> ] bi [ words>> ] bi@
-    assoc-union keys ; inline
+    assoc-union keys ;
 
 : vocabs-words ( names -- seq )
-    prune [ (vocab-words) ] map concat ; inline
+    prune [ (vocab-words) ] map concat ;
 
 PRIVATE>
 
diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor
index 8abbe6ba25..982319541b 100644
--- a/extra/game-loop/game-loop.factor
+++ b/extra/game-loop/game-loop.factor
@@ -1,5 +1,5 @@
-USING: accessors calendar destructors kernel math math.order namespaces
-system threads ;
+USING: accessors calendar continuations destructors kernel math
+math.order namespaces system threads ui ui.gadgets.worlds ;
 IN: game-loop
 
 TUPLE: game-loop
@@ -27,6 +27,16 @@ SYMBOL: game-loop
 
 CONSTANT: MAX-FRAMES-TO-SKIP 5
 
+DEFER: stop-loop
+
+TUPLE: game-loop-error game-loop error ;
+
+: ?ui-error ( error -- )
+    ui-running? [ ui-error ] [ rethrow ] if ;
+
+: game-loop-error ( game-loop error -- )
+    [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
+
 <PRIVATE
 
 : redraw ( loop -- )
@@ -54,7 +64,9 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
     [ drop ] if ;
 
 : run-loop ( loop -- )
-    dup game-loop [ (run-loop) ] with-variable ;
+    dup game-loop
+    [ [ (run-loop) ] [ game-loop-error ] recover ]
+    with-variable ;
 
 : benchmark-millis ( loop -- millis )
     millis swap benchmark-time>> - ;
@@ -91,3 +103,6 @@ PRIVATE>
 M: game-loop dispose
     stop-loop ;
 
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "game-loop.prettyprint" require ] when
diff --git a/extra/game-loop/prettyprint/prettyprint.factor b/extra/game-loop/prettyprint/prettyprint.factor
new file mode 100644
index 0000000000..8b20dd4c9d
--- /dev/null
+++ b/extra/game-loop/prettyprint/prettyprint.factor
@@ -0,0 +1,9 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors debugger game-loop io ;
+IN: game-loop.prettyprint
+
+M: game-loop-error error.
+    "An error occurred inside a game loop." print
+    "The game loop has been stopped to prevent runaway errors." print
+    "The error was:" print nl
+    error>> error. ;
diff --git a/extra/half-floats/authors.txt b/extra/half-floats/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/half-floats/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/half-floats/half-floats-tests.factor b/extra/half-floats/half-floats-tests.factor
new file mode 100644
index 0000000000..d026ca2933
--- /dev/null
+++ b/extra/half-floats/half-floats-tests.factor
@@ -0,0 +1,46 @@
+USING: alien.c-types alien.syntax half-floats kernel math tools.test ;
+IN: half-floats.tests
+
+[ HEX: 0000 ] [  0.0  half>bits ] unit-test
+[ HEX: 8000 ] [ -0.0  half>bits ] unit-test
+[ HEX: 3e00 ] [  1.5  half>bits ] unit-test
+[ HEX: be00 ] [ -1.5  half>bits ] unit-test
+[ HEX: 7c00 ] [  1/0. half>bits ] unit-test
+[ HEX: fc00 ] [ -1/0. half>bits ] unit-test
+[ HEX: 7eaa ] [ HEX: aaaaaaaaaaaaa <fp-nan> half>bits ] unit-test
+
+! too-big floats overflow to infinity
+[ HEX: 7c00 ] [   65536.0 half>bits ] unit-test
+[ HEX: fc00 ] [  -65536.0 half>bits ] unit-test
+[ HEX: 7c00 ] [  131072.0 half>bits ] unit-test
+[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test
+
+! too-small floats flush to zero
+[ HEX: 0000 ] [  1.0e-9 half>bits ] unit-test
+[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test
+
+[  0.0  ] [ HEX: 0000 bits>half ] unit-test
+[ -0.0  ] [ HEX: 8000 bits>half ] unit-test
+[  1.5  ] [ HEX: 3e00 bits>half ] unit-test
+[ -1.5  ] [ HEX: be00 bits>half ] unit-test
+[  1/0. ] [ HEX: 7c00 bits>half ] unit-test
+[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
+[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
+
+C-STRUCT: halves
+    { "half" "tom" }
+    { "half" "dick" }
+    { "half" "harry" }
+    { "half" "harry-jr" } ;
+
+[ 8 ] [ "halves" heap-size ] unit-test
+
+[ 3.0 ] [
+    "halves" <c-object>
+    3.0 over set-halves-dick
+    halves-dick
+] unit-test
+
+[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ]
+[ { 1.0 2.0 3.0 1/0. -1/0. } >half-array ] unit-test
+
diff --git a/extra/half-floats/half-floats.factor b/extra/half-floats/half-floats.factor
new file mode 100644
index 0000000000..53f6c6cfb1
--- /dev/null
+++ b/extra/half-floats/half-floats.factor
@@ -0,0 +1,42 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.c-types alien.syntax kernel math math.order
+specialized-arrays.direct.functor specialized-arrays.functor ;
+IN: half-floats
+
+: half>bits ( float -- bits )
+    float>bits
+    [ -31 shift 15 shift ] [
+        HEX: 7fffffff bitand
+        dup zero? [
+            dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [
+                -13 shift
+                112 10 shift -
+                0 HEX: 7c00 clamp
+            ] if
+        ] unless
+    ] bi bitor ;
+
+: bits>half ( bits -- float )
+    [ -15 shift 31 shift ] [
+        HEX: 7fff bitand
+        dup zero? [
+            dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [
+                13 shift
+                112 23 shift + 
+            ] if
+        ] unless
+    ] bi bitor bits>float ;
+
+C-STRUCT: half { "ushort" "(bits)" } ;
+
+<<
+
+"half" c-type
+    [ half>bits <ushort> ] >>unboxer-quot
+    [ *ushort bits>half ] >>boxer-quot
+    drop
+
+"half" define-array
+"half" define-direct-array
+
+>>
diff --git a/extra/half-floats/summary.txt b/extra/half-floats/summary.txt
new file mode 100644
index 0000000000..b22448f69b
--- /dev/null
+++ b/extra/half-floats/summary.txt
@@ -0,0 +1 @@
+Half-precision float support for FFI
diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor
index 2c26188e04..a591fe9ce0 100644
--- a/extra/irc/client/internals/internals-tests.factor
+++ b/extra/irc/client/internals/internals-tests.factor
@@ -85,6 +85,18 @@ M: mb-writer dispose drop ;
     ] with-irc
 ] unit-test
 
+! Test connect with password
+{ V{ "PASS password" "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
+    "someserver" irc-port "factorbot" "password" <irc-profile> <irc-client>
+    [ 2drop <test-stream> ] >>connect
+    [
+        (connect-irc)
+        (do-login)
+        irc> stream>> out>> lines>>
+        (terminate-irc)
+    ] with-irc
+] unit-test
+
 ! Test join
 [ { "JOIN #factortest" } [
       "#factortest" %join %pop-output-line
diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor
index 0a4fe11830..1b4a4550dc 100644
--- a/extra/irc/client/internals/internals.factor
+++ b/extra/irc/client/internals/internals.factor
@@ -16,6 +16,7 @@ IN: irc.client.internals
 
 : /NICK ( nick -- ) "NICK " prepend irc-print ;
 : /PONG ( text -- ) "PONG " prepend irc-print ;
+: /PASS ( password -- ) "PASS " prepend irc-print ;
 
 : /LOGIN ( nick -- )
     dup /NICK
@@ -44,7 +45,11 @@ IN: irc.client.internals
         in-messages>> [ irc-connected ] dip mailbox-put
     ] [ (terminate-irc) ] if* ;
 
-: (do-login) ( -- ) irc> nick>> /LOGIN ;
+: (do-login) ( -- )
+     irc>
+     [ profile>> password>> [ /PASS ] when* ]
+     [ nick>> /LOGIN ]
+     bi ;
 
 GENERIC: initialize-chat ( chat -- )
 M: irc-chat         initialize-chat drop ;
diff --git a/extra/managed-server/authors.txt b/extra/managed-server/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/extra/managed-server/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/extra/managed-server/chat/authors.txt b/extra/managed-server/chat/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/extra/managed-server/chat/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor
new file mode 100644
index 0000000000..f60445c48f
--- /dev/null
+++ b/extra/managed-server/chat/chat.factor
@@ -0,0 +1,136 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators combinators.smart
+destructors fry io io.encodings.utf8 kernel managed-server
+namespaces parser sequences sorting splitting strings.parser
+unicode.case unicode.categories calendar calendar.format
+locals multiline io.encodings.binary io.encodings.string
+prettyprint ;
+IN: managed-server.chat
+
+TUPLE: chat-server < managed-server ;
+
+SYMBOL: commands
+commands [ H{ } clone ] initialize
+
+SYMBOL: chat-docs
+chat-docs [ H{ } clone ] initialize
+
+CONSTANT: line-beginning "-!- "
+
+: send-line ( string -- )
+    write "\r\n" write flush ;
+
+: handle-me ( string -- )
+    [
+        [ "* " username " " ] dip
+    ] "" append-outputs-as send-everyone ;
+
+: handle-quit ( string -- )
+    client [ (>>object) ] [ t >>quit? drop ] bi ;
+
+: handle-help ( string -- )
+    [
+        "Commands: "
+        commands get keys natural-sort ", " join append send-line
+    ] [
+        chat-docs get ?at
+        [ send-line ]
+        [ "Unknown command: " prepend send-line ] if
+    ] if-empty ;
+
+: usage ( string -- )
+    chat-docs get at send-line ;
+
+: username-taken-string ( username -- string )
+    "The username ``" "'' is already in use; try again." surround ;
+
+: warn-name-changed ( old new -- )
+    [
+        [ line-beginning "``" ] 2dip
+        [ "'' is now known as ``" ] dip "''"
+    ] "" append-outputs-as send-everyone ;
+
+: handle-nick ( string -- )
+    [
+        "nick" usage
+    ] [
+        dup clients key? [
+            username-taken-string send-line
+        ] [
+            [ username swap warn-name-changed ]
+            [ username clients rename-at ]
+            [ client (>>username) ] tri
+        ] if
+    ] if-empty ;
+
+:: add-command ( quot docs key -- )
+    quot key commands get set-at
+    docs key chat-docs get set-at ;
+
+[ handle-help ]
+<" Syntax: /help [command]
+Displays the documentation for a command.">
+"help" add-command
+
+[ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
+<" Syntax: /who
+Shows the list of connected users.">
+"who" add-command
+
+[ drop gmt timestamp>rfc822 send-line ]
+<" Syntax: /time
+Returns the current GMT time."> "time" add-command
+
+[ handle-nick ]
+<" Syntax: /nick nickname
+Changes your nickname.">
+"nick" add-command
+
+[ handle-me ]
+<" Syntax: /me action">
+"me" add-command
+
+[ handle-quit ]
+<" Syntax: /quit [message]
+Disconnects a user from the chat server."> "quit" add-command
+
+: handle-command ( string -- )
+    dup " " split1 swap >lower commands get at* [
+        call( string -- ) drop
+    ] [
+        2drop "Unknown command: " prepend send-line
+    ] if ;
+
+: <chat-server> ( port -- managed-server )
+    "chat-server" utf8 chat-server new-managed-server ;
+
+: handle-chat ( string -- )
+    [
+        [ username ": " ] dip
+    ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-login
+    "Username: " write flush
+    readln ;
+
+M: chat-server handle-client-join
+    [
+        line-beginning username " has joined"
+    ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-client-disconnect
+    [
+        line-beginning username " has quit  "
+        client object>> dup [ "\"" dup surround ] when
+    ] "" append-outputs-as send-everyone ;
+
+M: chat-server handle-already-logged-in
+    username username-taken-string send-line
+    t client (>>quit?) ;
+
+M: chat-server handle-managed-client*
+    readln dup f = [ t client (>>quit?) ] when
+    [
+        "/" ?head [ handle-command ] [ handle-chat ] if
+    ] unless-empty ;
diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor
new file mode 100644
index 0000000000..6f9bdf25f1
--- /dev/null
+++ b/extra/managed-server/managed-server.factor
@@ -0,0 +1,105 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar continuations destructors io
+io.encodings.binary io.servers.connection io.sockets
+io.streams.duplex fry kernel locals math math.ranges multiline
+namespaces prettyprint random sequences sets splitting threads
+tools.continuations ;
+IN: managed-server
+
+TUPLE: managed-server < threaded-server clients ;
+
+TUPLE: managed-client
+input-stream output-stream local-address remote-address
+username object quit? logged-in? ;
+
+HOOK: handle-login threaded-server ( -- username )
+HOOK: handle-managed-client* managed-server ( -- )
+HOOK: handle-already-logged-in managed-server ( -- )
+HOOK: handle-client-join managed-server ( -- )
+HOOK: handle-client-disconnect managed-server ( -- )
+
+ERROR: already-logged-in username ;
+
+M: managed-server handle-already-logged-in already-logged-in ;
+M: managed-server handle-client-join ;
+M: managed-server handle-client-disconnect ;
+
+: server ( -- managed-client ) managed-server get ;
+: client ( -- managed-client ) managed-client get ;
+: clients ( -- assoc ) server clients>> ;
+: client-streams ( -- assoc ) clients values ;
+: username ( -- string ) client username>> ;
+: everyone-else ( -- assoc )
+    clients [ drop username = not ] assoc-filter ;
+: everyone-else-streams ( -- assoc ) everyone-else values ;
+
+ERROR: no-such-client username ;
+
+<PRIVATE
+
+: (send-client) ( managed-client seq -- )
+    [ output-stream>> ] dip '[ _ print flush ] with-output-stream* ;
+
+PRIVATE>
+
+: send-client ( seq username -- )
+    clients ?at [ no-such-client ] [ (send-client) ] if ;
+
+: send-everyone ( seq -- )
+    [ client-streams ] dip '[ _ (send-client) ] each ;
+
+: send-everyone-else ( seq -- )
+    [ everyone-else-streams ] dip '[ _ (send-client) ] each ;
+
+<PRIVATE
+
+: <managed-client> ( username -- managed-client )
+    managed-client new
+        swap >>username
+        input-stream get >>input-stream
+        output-stream get >>output-stream
+        local-address get >>local-address
+        remote-address get >>remote-address ;
+
+: maybe-login-client ( -- )
+    username clients key? [
+        handle-already-logged-in
+    ] [
+        t client (>>logged-in?)
+        client username clients set-at
+    ] if ;
+
+: when-logged-in ( quot -- )
+    client logged-in?>> [ call ] [ drop ] if ; inline
+
+: delete-managed-client ( -- )
+    [ username server clients>> delete-at ] when-logged-in ;
+
+: handle-managed-client ( -- )
+    handle-login <managed-client> managed-client set
+    maybe-login-client [
+        handle-client-join
+        [ handle-managed-client* client quit?>> not ] loop
+    ] when-logged-in ;
+
+: cleanup-client ( -- )
+    [
+        delete-managed-client
+        handle-client-disconnect
+    ] when-logged-in ;
+
+PRIVATE>
+
+M: managed-server handle-client*
+    managed-server set
+    [ handle-managed-client ]
+    [ cleanup-client ]
+    [ ] cleanup ;
+
+: new-managed-server ( port name encoding class -- server )
+    new-threaded-server
+        swap >>name
+        swap >>insecure
+        f >>timeout
+        H{ } clone >>clients ; inline
diff --git a/extra/mongodb/mmm/mmm.factor b/extra/mongodb/mmm/mmm.factor
index 25c4c88203..8e56143664 100644
--- a/extra/mongodb/mmm/mmm.factor
+++ b/extra/mongodb/mmm/mmm.factor
@@ -89,9 +89,8 @@ M: mdb-msg dump-message ( message -- )
 
 : start-mmm-server ( -- )
     output-stream get mmm-dump-output set
-    <threaded-server> [ mmm-t-srv set ] keep 
+    binary <threaded-server> [ mmm-t-srv set ] keep 
     "127.0.0.1" mmm-port get <inet4> >>insecure
-    binary >>encoding
     [ handle-mmm-connection ] >>handler
     start-server* ;
 
@@ -99,4 +98,4 @@ M: mdb-msg dump-message ( message -- )
     check-options
     start-mmm-server ;
     
-MAIN: run-mmm
\ No newline at end of file
+MAIN: run-mmm
diff --git a/extra/nested-comments/nested-comments.factor b/extra/nested-comments/nested-comments.factor
new file mode 100644
index 0000000000..94daffec2d
--- /dev/null
+++ b/extra/nested-comments/nested-comments.factor
@@ -0,0 +1,20 @@
+! by blei on #concatenative
+USING: kernel sequences math locals make multiline ;
+IN: nested-comments
+
+:: (subsequences-at) ( sseq seq n -- )
+    sseq seq n start*
+    [ dup , sseq length + [ sseq seq ] dip (subsequences-at) ]
+    when* ;
+
+: subsequences-at ( sseq seq -- indices )
+    [ 0 (subsequences-at) ] { } make ;
+
+: count-subsequences ( sseq seq -- i )
+    subsequences-at length ;
+
+: parse-all-(* ( parsed-vector left-to-parse -- parsed-vector )
+    1 - "*)" parse-multiline-string [ "(*" ] dip
+    count-subsequences + dup 0 > [ parse-all-(* ] [ drop ] if ;
+
+SYNTAX: (* 1 parse-all-(* ;
\ No newline at end of file
diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor
index 46704eed36..3de4147835 100644
--- a/extra/noise/noise.factor
+++ b/extra/noise/noise.factor
@@ -1,8 +1,9 @@
-USING: byte-arrays combinators fry images kernel locals math
+USING: accessors arrays byte-arrays combinators
+combinators.short-circuit fry hints images kernel locals math
 math.affine-transforms math.functions math.order
-math.polynomials math.vectors random random.mersenne-twister
-sequences sequences.product hints arrays sequences.private
-combinators.short-circuit math.private ;
+math.polynomials math.private math.vectors random
+random.mersenne-twister sequences sequences.private
+sequences.product ;
 IN: noise
 
 : <perlin-noise-table> ( -- table )
@@ -60,7 +61,10 @@ HINTS: hashes { byte-array fixnum fixnum fixnum } ;
     [ 255.0 * >fixnum ] B{ } map-as ;
 
 : >image ( bytes dim -- image )
-    swap [ L f ] dip image boa ;
+    image new
+        swap >>dim
+        swap >>bitmap
+        L >>component-order ;
 
 :: perlin-noise-unsafe ( table point -- value )
     point unit-cube :> cube
diff --git a/extra/nurbs/nurbs-tests.factor b/extra/nurbs/nurbs-tests.factor
index db606f9c5c..191c2af7ca 100644
--- a/extra/nurbs/nurbs-tests.factor
+++ b/extra/nurbs/nurbs-tests.factor
@@ -11,13 +11,13 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ]
 ! unit circle as NURBS
 3 {
     { 1.0 0.0 1.0 }
-    { $ √2/2 $ √2/2 $ √2/2 }
+    ${ √2/2 √2/2 √2/2 }
     { 0.0 1.0 1.0 }
-    { $ -√2/2 $ √2/2 $ √2/2 }
+    ${ -√2/2 √2/2 √2/2 }
     { -1.0 0.0 1.0 }
-    { $ -√2/2 $ -√2/2 $ √2/2 }
+    ${ -√2/2 -√2/2 √2/2 }
     { 0.0 -1.0 1.0 }
-    { $ √2/2 $ -√2/2 $ √2/2 }
+    ${ √2/2 -√2/2 √2/2 }
     { 1.0 0.0 1.0 }
 } { 0.0 0.0 0.0 0.25 0.25 0.5 0.5 0.75 0.75 1.0 1.0 1.0 } <nurbs-curve> test-nurbs set
 
@@ -26,7 +26,7 @@ CONSTANT: -√2/2 $[ 0.5 sqrt neg ]
 [ t ] [ test-nurbs get 0.5   eval-nurbs {  -1.0   0.0 } 0.00001 v~ ] unit-test
 [ t ] [ test-nurbs get 0.75  eval-nurbs {   0.0  -1.0 } 0.00001 v~ ] unit-test
 
-[ t ] [ test-nurbs get 0.125 eval-nurbs { $  √2/2 $  √2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.375 eval-nurbs { $ -√2/2 $  √2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.625 eval-nurbs { $ -√2/2 $ -√2/2 } 0.00001 v~ ] unit-test
-[ t ] [ test-nurbs get 0.875 eval-nurbs { $  √2/2 $ -√2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.125 eval-nurbs ${ √2/2 √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.375 eval-nurbs ${ -√2/2 √2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.625 eval-nurbs ${ -√2/2 -√2/2 } 0.00001 v~ ] unit-test
+[ t ] [ test-nurbs get 0.875 eval-nurbs ${ √2/2 -√2/2 } 0.00001 v~ ] unit-test
diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor
index da097f4c00..259fb9f259 100644
--- a/extra/sequence-parser/sequence-parser-tests.factor
+++ b/extra/sequence-parser/sequence-parser-tests.factor
@@ -118,10 +118,10 @@ IN: sequence-parser.tests
 [ "abcd e \\\"f g" ]
 [ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
 
-[ "" ]
+[ f ]
 [ "" <sequence-parser> take-rest ] unit-test
 
-[ "" ]
+[ f ]
 [ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
 
 [ f ]
diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor
index 4cc10fd5fd..e46abe8090 100644
--- a/extra/sequence-parser/sequence-parser.factor
+++ b/extra/sequence-parser/sequence-parser.factor
@@ -35,6 +35,8 @@ TUPLE: sequence-parser sequence n ;
 : advance* ( sequence-parser -- )
     advance drop ; inline
 
+: next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ;
+
 : get+increment ( sequence-parser -- char/f )
     [ current ] [ advance drop ] bi ; inline
 
@@ -148,7 +150,7 @@ TUPLE: sequence-parser sequence n ;
     2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
 
 : take-rest ( sequence-parser -- sequence )
-    [ take-rest-slice ] [ sequence>> like ] bi ;
+    [ take-rest-slice ] [ sequence>> like ] bi f like ;
 
 : take-until-object ( sequence-parser obj -- sequence )
     '[ current _ = ] take-until ;
@@ -190,7 +192,7 @@ TUPLE: sequence-parser sequence n ;
 
 :: take-n ( sequence-parser n -- seq/f )
     n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
-        f
+        sequence-parser take-rest
     ] [
         sequence-parser n>> dup n + sequence-parser sequence>> subseq
         sequence-parser [ n + ] change-n drop
diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor
index b7dcaa626e..add5ac8418 100644
--- a/extra/sequences/product/product-docs.factor
+++ b/extra/sequences/product/product-docs.factor
@@ -1,6 +1,6 @@
 ! (c)2009 Joe Groff bsd license
-USING: help.markup help.syntax multiline quotations sequences sequences.product ;
-IN: sequences
+USING: help.markup help.syntax multiline quotations sequences ;
+IN: sequences.product
 
 HELP: product-sequence
 { $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
diff --git a/extra/terrain/generation/generation.factor b/extra/terrain/generation/generation.factor
index 18f73e8e8b..72221d7b0e 100644
--- a/extra/terrain/generation/generation.factor
+++ b/extra/terrain/generation/generation.factor
@@ -1,6 +1,7 @@
-USING: accessors arrays byte-arrays combinators fry grouping
-images kernel math math.affine-transforms math.order
-math.vectors noise random sequences ;
+USING: accessors arrays byte-arrays combinators
+combinators.smart fry grouping images kernel math
+math.affine-transforms math.order math.vectors noise random
+sequences ;
 IN: terrain.generation
 
 CONSTANT: terrain-segment-size { 512 512 }
@@ -31,15 +32,21 @@ TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ;
 
 TUPLE: segment image ;
 
+: <terrain-image> ( bytes -- image )
+    <image>
+        swap >>bitmap
+        RGBA >>component-order
+        terrain-segment-size >>dim ;
+
 : terrain-segment ( terrain at -- image )
-    {
-        [ big-noise-segment ]
-        [ small-noise-segment ]
-        [ tiny-noise-segment ]
-        [ padding ]
-    } 2cleave
-    4array flip concat >byte-array
-    [ terrain-segment-size RGBA f ] dip image boa ;
+    [
+        {
+            [ big-noise-segment ]
+            [ small-noise-segment ]
+            [ tiny-noise-segment ]
+            [ padding ]
+        } 2cleave
+    ] output>array flip B{ } concat-as <terrain-image> ;
 
 : 4max ( a b c d -- max )
     max max max ; inline
diff --git a/extra/time-server/time-server.factor b/extra/time-server/time-server.factor
index 28debf17cd..500f0276d7 100644
--- a/extra/time-server/time-server.factor
+++ b/extra/time-server/time-server.factor
@@ -1,14 +1,14 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.servers.connection accessors threads
-calendar calendar.format ;
+USING: accessors calendar calendar.format io io.encodings.ascii
+io.servers.connection threads ;
 IN: time-server
 
 : handle-time-client ( -- )
     now timestamp>rfc822 print ;
 
 : <time-server> ( -- threaded-server )
-    <threaded-server>
+    ascii <threaded-server>
         "time-server" >>name
         1234 >>insecure
         [ handle-time-client ] >>handler ;
diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor
index 4ba38ad06a..0c7395f7f0 100644
--- a/extra/tty-server/tty-server.factor
+++ b/extra/tty-server/tty-server.factor
@@ -3,9 +3,8 @@ accessors kernel ;
 IN: tty-server
 
 : <tty-server> ( port -- )
-    <threaded-server>
+    utf8 <threaded-server>
         "tty-server" >>name
-        utf8 >>encoding
         swap local-server >>insecure
         [ listener ] >>handler
     start-server ;
diff --git a/extra/ui/gadgets/worlds/null/null.factor b/extra/ui/gadgets/worlds/null/null.factor
new file mode 100644
index 0000000000..26fc3e8a94
--- /dev/null
+++ b/extra/ui/gadgets/worlds/null/null.factor
@@ -0,0 +1,27 @@
+USING: accessors kernel ui ui.backend ui.gadgets
+ui.gadgets.worlds ui.pixel-formats ;
+IN: ui.gadgets.worlds.null
+
+TUPLE: null-world < world ;
+M: null-world begin-world drop ;
+M: null-world end-world drop ;
+M: null-world draw-world* drop ;
+M: null-world resize-world drop ;
+M: null-world pref-dim* drop { 512 512 } ;
+
+: null-window ( title -- world )
+    <world-attributes>
+        swap >>title
+        null-world >>world-class
+        {
+            windowed
+            double-buffered
+            backing-store
+            T{ depth-bits f 24 }
+        } >>pixel-format-attributes
+    f swap open-window* ;
+
+: into-window ( world quot -- world )
+    [ dup handle>> ] dip with-gl-context ; inline
+
+
diff --git a/misc/bash/cdfactor.sh b/misc/bash/cdfactor.sh
new file mode 100755
index 0000000000..cee2d3ac77
--- /dev/null
+++ b/misc/bash/cdfactor.sh
@@ -0,0 +1,18 @@
+#!/bin/bash 
+
+# change directories to a factor module
+function cdfactor { 
+    code=$(printf "USING: io io.pathnames vocabs vocabs.loader ; "
+           printf "\"%s\" <vocab> vocab-source-path (normalize-path) print" $1)
+    echo $code > $HOME/.cdfactor
+    fn=$(factor $HOME/.cdfactor)
+    dn=$(dirname $fn)
+    echo $dn
+    if [ -z "$dn" ]; then
+        echo "Warning: directory '$1' not found" 1>&2
+    else
+        cd $dn
+    fi
+}
+
+
diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el
index b302fb6b8f..cc8ebe35fb 100644
--- a/misc/fuel/factor-mode.el
+++ b/misc/fuel/factor-mode.el
@@ -125,7 +125,8 @@ code in the buffer."
 (defun factor-mode--indent-setter-line ()
   (when (fuel-syntax--at-setter-line)
     (save-excursion
-      (let ((indent (and (fuel-syntax--at-constructor-line) (current-indentation))))
+      (let ((indent (and (fuel-syntax--at-constructor-line)
+                         (current-indentation))))
         (while (not (or indent
                         (bobp)
                         (fuel-syntax--at-begin-of-def)
@@ -225,6 +226,19 @@ code in the buffer."
 (defsubst factor-mode--cycling-setup ()
   (setq factor-mode--cycling-no-ask nil))
 
+(defun factor-mode--code-file (kind &optional file)
+  (let* ((file (or file (buffer-file-name)))
+         (bn (file-name-nondirectory file)))
+    (and (string-match (format "\\(.+\\)-%s\\.factor$" kind) bn)
+         (expand-file-name (concat (match-string 1 bn) ".factor")
+                           (file-name-directory file)))))
+
+(defsubst factor-mode--in-docs (&optional file)
+  (factor-mode--code-file "docs"))
+
+(defsubst factor-mode--in-tests (&optional file)
+  (factor-mode--code-file "tests"))
+
 (defun factor-mode-visit-other-file (&optional skip)
   "Cycle between code, tests and docs factor files.
 With prefix, non-existing files will be skipped."
diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el
index 80fe8e830b..cc788fe5dc 100644
--- a/misc/fuel/fuel-markup.el
+++ b/misc/fuel/fuel-markup.el
@@ -382,7 +382,7 @@
         (when (looking-at "Word *\\(Stack effect\\|Syntax\\)$")
           (push (list "Word" (match-string-no-properties 1)) rows)
           (forward-line))
-        (while (looking-at "\\(.+?\\)\\( +\\(.+\\)\\)?$")
+        (while (looking-at " ?\\(.+?\\)\\( +\\(.+\\)\\)?$")
           (let ((word `($link ,(match-string-no-properties 1)
                               ,(match-string-no-properties 1)
                               word))
diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el
index 0186392f34..282ef3240f 100644
--- a/misc/fuel/fuel-mode.el
+++ b/misc/fuel/fuel-mode.el
@@ -172,7 +172,10 @@ interacting with a factor listener is at your disposal.
   (when fuel-mode-autodoc-p (fuel-autodoc-mode fuel-mode))
 
   (setq fuel-stack-mode-string "/S")
-  (when fuel-mode-stack-p (fuel-stack-mode fuel-mode)))
+  (when fuel-mode-stack-p (fuel-stack-mode fuel-mode))
+
+  (when (and fuel-mode (not (file-exists-p (buffer-file-name))))
+    (fuel-scaffold--maybe-insert)))
 
 
 ;;; Keys:
diff --git a/misc/fuel/fuel-scaffold.el b/misc/fuel/fuel-scaffold.el
index ac400c5622..9b7d9861c7 100644
--- a/misc/fuel/fuel-scaffold.el
+++ b/misc/fuel/fuel-scaffold.el
@@ -26,9 +26,10 @@
   "Options for FUEL's scaffolding."
   :group 'fuel)
 
-(defcustom fuel-scaffold-developer-name user-full-name
+(defcustom fuel-scaffold-developer-name nil
   "The name to be inserted as yours in scaffold templates."
-  :type 'string
+  :type '(choice string
+                 (const :tag "Factor's value for developer-name" nil))
   :group 'fuel-scaffold)
 
 
@@ -38,6 +39,64 @@
   (let ((cmd '(:fuel* (vocab-roots get :get) "fuel")))
     (fuel-eval--retort-result (fuel-eval--send/wait cmd))))
 
+(defun fuel-scaffold--dev-name ()
+  (or fuel-scaffold-developer-name
+      (let ((cmd '(:fuel* (developer-name get :get) "fuel")))
+        (fuel-eval--retort-result (fuel-eval--send/wait cmd)))
+      "Your name"))
+
+(defun fuel-scaffold--first-vocab ()
+  (goto-char (point-min))
+  (re-search-forward fuel-syntax--current-vocab-regex nil t))
+
+(defsubst fuel-scaffold--vocab (file)
+  (save-excursion
+    (set-buffer (find-file-noselect file))
+    (fuel-scaffold--first-vocab)
+    (fuel-syntax--current-vocab)))
+
+(defconst fuel-scaffold--tests-header-format
+  "! Copyright (C) %s %s
+! See http://factorcode.org/license.txt for BSD license.
+USING: %s tools.test ;
+IN: %s
+")
+
+(defsubst fuel-scaffold--check-auto (var)
+  (and var (or (eq var 'always) (y-or-n-p "Insert template? "))))
+
+(defun fuel-scaffold--tests (parent)
+  (when (and parent (fuel-scaffold--check-auto fuel-scaffold-test-autoinsert-p))
+    (let ((year (format-time-string "%Y"))
+          (name (fuel-scaffold--dev-name))
+          (vocab (fuel-scaffold--vocab parent)))
+      (insert (format fuel-scaffold--tests-header-format
+                      year name vocab vocab))
+      t)))
+
+(defsubst fuel-scaffold--create-docs (vocab)
+  (let ((cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
+                      "fuel")))
+    (fuel-eval--send/wait cmd)))
+
+(defun fuel-scaffold--help (parent)
+  (when (and parent (fuel-scaffold--check-auto fuel-scaffold-help-autoinsert-p))
+    (let* ((ret (fuel-scaffold--create-docs (fuel-scaffold--vocab parent)))
+           (file (fuel-eval--retort-result ret)))
+      (when file
+        (revert-buffer t t t)
+        (when (and fuel-scaffold-help-header-only-p
+                   (fuel-scaffold--first-vocab))
+          (delete-region (1+ (point)) (point-max))
+          (save-buffer))
+        (message "Inserting template ... done."))
+      (goto-char (point-min)))))
+
+(defun fuel-scaffold--maybe-insert ()
+  (ignore-errors
+    (or (fuel-scaffold--tests (factor-mode--in-tests))
+        (fuel-scaffold--help (factor-mode--in-docs)))))
+
 
 ;;; User interface:
 
@@ -72,9 +131,7 @@ You can configure `fuel-scaffold-developer-name' (set by default to
   (interactive "P")
   (let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
                     (fuel-completion--read-vocab nil)))
-         (cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
-                       "fuel"))
-         (ret (fuel-eval--send/wait cmd))
+         (ret (fuel-scaffold--create-docs vocab))
          (file (fuel-eval--retort-result ret)))
         (unless file
           (error "Error creating help file" (car (fuel-eval--retort-error ret))))
diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el
index 61aa2b7cdd..3fc16e7af6 100644
--- a/misc/fuel/fuel-syntax.el
+++ b/misc/fuel/fuel-syntax.el
@@ -59,7 +59,7 @@
     "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
     "QUALIFIED-WITH:" "QUALIFIED:"
     "read-only" "RENAME:" "REQUIRE:"  "REQUIRES:"
-    "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:"
+    "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
     "TUPLE:" "t" "t?" "TYPEDEF:"
     "UNION:" "USE:" "USING:"
     "VARS:"))
@@ -109,7 +109,7 @@
   (format "\\_<\\(%s\\)?: +\\_<\\(\\w+\\)\\_>"
           (regexp-opt
            '(":" "GENERIC" "DEFER" "HOOK" "MAIN" "MATH" "POSTPONE"
-             "SYMBOL" "RENAME"))))
+             "SYMBOL" "SYNTAX" "RENAME"))))
 
 (defconst fuel-syntax--alias-definition-regex
   "^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
@@ -156,6 +156,7 @@
                                            "INTERSECTION:"
                                            "M" "MACRO" "MACRO:"
                                            "MEMO" "MEMO:" "METHOD"
+                                           "SYNTAX"
                                            "PREDICATE" "PRIMITIVE"
                                            "UNION"))
 
diff --git a/misc/fuel/fuel-table.el b/misc/fuel/fuel-table.el
index a00b21bf2f..1af2e25712 100644
--- a/misc/fuel/fuel-table.el
+++ b/misc/fuel/fuel-table.el
@@ -72,21 +72,67 @@
         (push (fuel-table--pad-row (reverse frow)) frows)))
     (reverse frows)))
 
+(defvar fuel-table-corner-lt "┌")
+(defvar fuel-table-corner-lb "└")
+(defvar fuel-table-corner-rt "┐")
+(defvar fuel-table-corner-rb "┘")
+(defvar fuel-table-line "─")
+(defvar fuel-table-tee-t "┬")
+(defvar fuel-table-tee-b "┴")
+(defvar fuel-table-tee-l "├")
+(defvar fuel-table-tee-r "┤")
+(defvar fuel-table-crux "┼")
+(defvar fuel-table-sep "│")
+
+(defun fuel-table--insert-line (widths first last sep)
+  (insert first fuel-table-line)
+  (dolist (w widths)
+    (while (> w 0)
+      (insert fuel-table-line)
+      (setq w (1- w)))
+    (insert fuel-table-line sep fuel-table-line))
+  (delete-char -2)
+  (insert fuel-table-line last)
+  (newline))
+
+(defun fuel-table--insert-first-line (widths)
+  (fuel-table--insert-line widths
+                           fuel-table-corner-lt
+                           fuel-table-corner-rt
+                           fuel-table-tee-t))
+
+(defun fuel-table--insert-middle-line (widths)
+  (fuel-table--insert-line widths
+                           fuel-table-tee-l
+                           fuel-table-tee-r
+                           fuel-table-crux))
+
+(defun fuel-table--insert-last-line (widths)
+  (fuel-table--insert-line widths
+                           fuel-table-corner-lb
+                           fuel-table-corner-rb
+                           fuel-table-tee-b))
+
+(defun fuel-table--insert-row (r)
+  (let ((ln (length (car r)))
+        (l 0))
+    (while (< l ln)
+      (insert (concat fuel-table-sep " "
+                      (mapconcat 'identity
+                                 (mapcar `(lambda (x) (nth ,l x)) r)
+                                 (concat " " fuel-table-sep " "))
+                      "  " fuel-table-sep "\n"))
+      (setq l (1+ l)))))
+
 (defun fuel-table--insert (rows)
   (let* ((widths (fuel-table--col-widths rows))
-         (rows (fuel-table--format-rows rows widths))
-         (ls (concat "+" (mapconcat (lambda (n) (make-string n ?-)) widths "-+") "-+")))
-    (insert ls "\n")
+         (rows (fuel-table--format-rows rows widths)))
+    (fuel-table--insert-first-line widths)
     (dolist (r rows)
-      (let ((ln (length (car r)))
-            (l 0))
-        (while (< l ln)
-          (insert (concat "|" (mapconcat 'identity
-                                         (mapcar `(lambda (x) (nth ,l x)) r)
-                                         " |")
-                          " |\n"))
-          (setq l (1+ l))))
-      (insert ls "\n"))))
+      (fuel-table--insert-row r)
+      (fuel-table--insert-middle-line widths))
+    (kill-line -1)
+    (fuel-table--insert-last-line widths)))
 
 
 (provide 'fuel-table)
diff --git a/extra/images/processing/rotation/authors.txt b/unmaintained/images/processing/rotation/authors.txt
similarity index 100%
rename from extra/images/processing/rotation/authors.txt
rename to unmaintained/images/processing/rotation/authors.txt
diff --git a/extra/images/processing/rotation/rotation-tests.factor b/unmaintained/images/processing/rotation/rotation-tests.factor
similarity index 73%
rename from extra/images/processing/rotation/rotation-tests.factor
rename to unmaintained/images/processing/rotation/rotation-tests.factor
index 493f09b145..390e6deeff 100755
--- a/extra/images/processing/rotation/rotation-tests.factor
+++ b/unmaintained/images/processing/rotation/rotation-tests.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Kobi Lurie, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors fry images.loader images.normalization
+USING: accessors fry images.loader
 images.processing.rotation kernel literals math sequences
 tools.test images.processing.rotation.private ;
 IN: images.processing.rotation.tests
@@ -21,23 +21,17 @@ IN: images.processing.rotation.tests
 
 >>
 
-CONSTANT: pasted-image
-    $[
-        "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
-        load-image normalize-image clone-image
-    ]
+: pasted-image ( -- image )
+    "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
+    load-image clone-image ;
 
-CONSTANT: pasted-image90
-    $[
-        "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
-        load-image normalize-image clone-image
-    ]
+: pasted-image90 ( -- image )
+    "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
+    load-image clone-image ;
 
-CONSTANT: lake-image
-    $[
-        "vocab:images/processing/rotation/test-bitmaps/lake.bmp"
-        load-image preprocess
-    ]
+: lake-image ( -- image )
+    "vocab:images/processing/rotation/test-bitmaps/lake.bmp"
+    load-image clone-image image>pixel-rows ;
 
 [ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test
 [ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test
@@ -55,7 +49,7 @@ CONSTANT: lake-image
     "vocab:images/processing/rotation/test-bitmaps/small.bmp"
     load-image 90 rotate 
     "vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"
-    load-image normalize-image =
+    load-image =
 ] unit-test
     
 [ t ] [
diff --git a/extra/images/processing/rotation/rotation.factor b/unmaintained/images/processing/rotation/rotation.factor
similarity index 91%
rename from extra/images/processing/rotation/rotation.factor
rename to unmaintained/images/processing/rotation/rotation.factor
index c10bfa0ee0..87cea5f255 100644
--- a/extra/images/processing/rotation/rotation.factor
+++ b/unmaintained/images/processing/rotation/rotation.factor
@@ -40,20 +40,17 @@ ERROR: unsupported-rotation degrees ;
 : flatten-table ( seq^3 -- seq )
     [ concat ] map concat ;
 
-: preprocess ( image -- pixelrows )
-    normalize-image image>pixel-rows ;
-
 : ?reverse-dimensions ( image n -- )
     { 270 90 } member? [ [ reverse ] change-dim ] when drop ;
 
 :  normalize-degree ( n -- n' ) 360 rem ;
 
 : processing-effect ( image quot -- image' )
-    '[ preprocess @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline
+    '[ image>pixel-rows @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline
 
 :: rotate' ( image n -- image )
     n normalize-degree :> n'
-    image preprocess :> pixel-table
+    image image>pixel-rows :> pixel-table
     image n' ?reverse-dimensions
     pixel-table n' (rotate) :> table-rotated
     image table-rotated flatten-table >>bitmap ;
diff --git a/extra/images/processing/rotation/test-bitmaps/PastedImage.bmp b/unmaintained/images/processing/rotation/test-bitmaps/PastedImage.bmp
similarity index 100%
rename from extra/images/processing/rotation/test-bitmaps/PastedImage.bmp
rename to unmaintained/images/processing/rotation/test-bitmaps/PastedImage.bmp
diff --git a/extra/images/processing/rotation/test-bitmaps/PastedImage90.bmp b/unmaintained/images/processing/rotation/test-bitmaps/PastedImage90.bmp
similarity index 100%
rename from extra/images/processing/rotation/test-bitmaps/PastedImage90.bmp
rename to unmaintained/images/processing/rotation/test-bitmaps/PastedImage90.bmp
diff --git a/extra/images/processing/rotation/test-bitmaps/lake.bmp b/unmaintained/images/processing/rotation/test-bitmaps/lake.bmp
similarity index 100%
rename from extra/images/processing/rotation/test-bitmaps/lake.bmp
rename to unmaintained/images/processing/rotation/test-bitmaps/lake.bmp
diff --git a/extra/images/processing/rotation/test-bitmaps/small-rotated.bmp b/unmaintained/images/processing/rotation/test-bitmaps/small-rotated.bmp
similarity index 100%
rename from extra/images/processing/rotation/test-bitmaps/small-rotated.bmp
rename to unmaintained/images/processing/rotation/test-bitmaps/small-rotated.bmp
diff --git a/extra/images/processing/rotation/test-bitmaps/small.bmp b/unmaintained/images/processing/rotation/test-bitmaps/small.bmp
similarity index 100%
rename from extra/images/processing/rotation/test-bitmaps/small.bmp
rename to unmaintained/images/processing/rotation/test-bitmaps/small.bmp
diff --git a/unmaintained/modules/rpc-server/rpc-server.factor b/unmaintained/modules/rpc-server/rpc-server.factor
index d818170372..0c881adef6 100644
--- a/unmaintained/modules/rpc-server/rpc-server.factor
+++ b/unmaintained/modules/rpc-server/rpc-server.factor
@@ -2,36 +2,44 @@ USING: accessors assocs continuations effects io
 io.encodings.binary io.servers.connection kernel
 memoize namespaces parser sets sequences serialize
 threads vocabs vocabs.parser words ;
-
 IN: modules.rpc-server
 
 SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
 
 : do-rpc ( args word -- bytes )
-   [ execute ] curry with-datastack object>bytes ; inline
+    [ execute ] curry with-datastack object>bytes ; inline
 
 MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
 
-: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
-   swap at "executer" get execute( args word -- bytes ) write flush ;
+: process ( vocabspec -- )
+    vocab-words [ deserialize ] dip deserialize
+    swap at "executer" get execute( args word -- bytes ) write flush ;
 
-: (serve) ( -- ) deserialize dup serving-vocabs get-global index
-   [ process ] [ drop ] if ;
+: (serve) ( -- )
+    deserialize dup serving-vocabs get-global index
+    [ process ] [ drop ] if ;
 
-: start-serving-vocabs ( -- ) [
-   <threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
-   start-server ] in-thread ;
+: start-serving-vocabs ( -- )
+    [
+        binary <threaded-server>
+        5000 >>insecure
+        [ (serve) ] >>handler
+        start-server
+    ] in-thread ;
 
-: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
-   current-vocab serving-vocabs get-global adjoin
-   "get-words" create-in
-   current-vocab name>> [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
-   (( -- words )) define-inline ;
+: (service) ( -- )
+    serving-vocabs get-global empty? [ start-serving-vocabs ] when
+    current-vocab serving-vocabs get-global adjoin
+    "get-words" create-in
+    in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
+    (( -- words )) define-inline ;
 
 SYNTAX: service \ do-rpc  "executer" set (service) ;
 SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
 
 load-vocab-hook [
-   [ dup words>> values
-   \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
-append ] change-global
\ No newline at end of file
+    [
+        dup words>> values
+        \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each
+    ] append
+] change-global
diff --git a/vm/code_block.cpp b/vm/code_block.cpp
index 2ce69ebfde..aaf8e25866 100755
--- a/vm/code_block.cpp
+++ b/vm/code_block.cpp
@@ -159,7 +159,10 @@ cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
 	case RT_XT_PIC_TAIL:
 		return (cell)word_xt_pic_tail(untag<word>(ARG));
 	case RT_HERE:
-		return offset + (short)untag_fixnum(ARG);
+	{
+		fixnum arg = untag_fixnum(ARG);
+		return (arg >= 0 ? offset + arg : (cell)(compiled +1) - arg);
+	}
 	case RT_THIS:
 		return (cell)(compiled + 1);
 	case RT_STACK_CHAIN:
diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S
index afda9d31cd..a879712190 100755
--- a/vm/cpu-x86.32.S
+++ b/vm/cpu-x86.32.S
@@ -55,6 +55,10 @@ DEF(bool,check_sse2,(void)):
 	mov %edx,%eax
 	ret
 
+DEF(long long,read_timestamp_counter,(void)):
+	rdtsc
+	ret
+
 DEF(void,primitive_inline_cache_miss,(void)):
 	mov (%esp),%ebx
 DEF(void,primitive_inline_cache_miss_tail,(void)):
@@ -69,4 +73,5 @@ DEF(void,primitive_inline_cache_miss_tail,(void)):
 #ifdef WINDOWS
 	.section .drectve
 	.ascii " -export:check_sse2"
+	.ascii " -export:read_timestamp_counter"
 #endif
diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S
index 8cf7423239..5cc3c98f33 100644
--- a/vm/cpu-x86.64.S
+++ b/vm/cpu-x86.64.S
@@ -72,6 +72,13 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
 	call *ARG3                         /* call memcpy */
 	ret                                /* return _with new stack_ */
 
+DEF(long long,read_timestamp_counter,(void)):
+	mov $0,%rax
+	rdtsc
+	shl $32,%rdx
+	or %rdx,%rax
+	ret
+
 DEF(void,primitive_inline_cache_miss,(void)):
 	mov (%rsp),%rbx
 DEF(void,primitive_inline_cache_miss_tail,(void)):
diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp
index bcf6387639..6631a046ac 100755
--- a/vm/data_gc.cpp
+++ b/vm/data_gc.cpp
@@ -680,9 +680,15 @@ PRIMITIVE(become)
 	compile_all_words();
 }
 
-VM_C_API void minor_gc()
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size)
 {
+	for(cell i = 0; i < gc_roots_size; i++)
+		gc_local_push((cell)&gc_roots_base[i]);
+
 	garbage_collection(data->nursery(),false,0);
+
+	for(cell i = 0; i < gc_roots_size; i++)
+		gc_local_pop();
 }
 
 }
diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp
index 2d6a1ab897..334ad5a2bb 100755
--- a/vm/data_gc.hpp
+++ b/vm/data_gc.hpp
@@ -143,6 +143,6 @@ inline static void check_tagged_pointer(cell tagged)
 #endif
 }
 
-VM_C_API void minor_gc();
+VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size);
 
 }