From 6cad2e02e495b9adde0a094c2f3b743ecefe917e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 17 Sep 2008 00:46:38 -0500
Subject: [PATCH] Updating x86 backend for new codegen

---
 basis/compiler/constants/constants.factor     |  27 +
 unfinished/compiler/backend/backend.factor    | 221 ++++-
 unfinished/compiler/backend/x86/32/32.factor  | 313 +++++++-
 unfinished/compiler/backend/x86/64/64.factor  | 218 ++++-
 .../compiler/backend/x86/sse2/sse2.factor     | 110 +++
 unfinished/compiler/backend/x86/x86.factor    | 755 ++++++++++++++++++
 .../compiler/cfg/builder/builder.factor       | 109 ++-
 unfinished/compiler/cfg/cfg.factor            |   7 +-
 .../compiler/cfg/debugger/debugger.factor     |   5 +-
 .../cfg/instructions/instructions.factor      | 115 ++-
 .../cfg/linear-scan/linear-scan-tests.factor  |   5 +
 .../cfg/linear-scan/linear-scan.factor        |  13 +-
 .../live-intervals/live-intervals.factor      |   1 -
 .../cfg/linearization/linearization.factor    |  42 +-
 .../compiler/cfg/registers/registers.factor   |  22 +-
 unfinished/compiler/cfg/rpo/rpo.factor        |   1 -
 unfinished/compiler/cfg/stacks/stacks.factor  |  91 +--
 .../compiler/cfg/templates/templates.factor   |  31 +-
 .../alien.factor => codegen/codegen.factor}   | 222 +++--
 .../compiler/codegen/fixup/fixup.factor       |  77 +-
 unfinished/compiler/new/new.factor            | 116 +++
 21 files changed, 2134 insertions(+), 367 deletions(-)
 create mode 100644 unfinished/compiler/backend/x86/sse2/sse2.factor
 create mode 100644 unfinished/compiler/backend/x86/x86.factor
 rename unfinished/compiler/{backend/alien/alien.factor => codegen/codegen.factor} (58%)
 create mode 100644 unfinished/compiler/new/new.factor

diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index 80f0b4f515..b5b2be5095 100755
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -23,3 +23,30 @@ IN: compiler.constants
 : word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
 : array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
 : compiled-header-size ( -- n ) 4 bootstrap-cells ;
+
+! Relocation classes
+: rc-absolute-cell    0 ;
+: rc-absolute         1 ;
+: rc-relative         2 ;
+: rc-absolute-ppc-2/2 3 ;
+: rc-relative-ppc-2   4 ;
+: rc-relative-ppc-3   5 ;
+: rc-relative-arm-3   6 ;
+: rc-indirect-arm     7 ;
+: rc-indirect-arm-pc  8 ;
+
+! Relocation types
+: rt-primitive 0 ;
+: rt-dlsym     1 ;
+: rt-literal   2 ;
+: rt-dispatch  3 ;
+: rt-xt        4 ;
+: rt-here      5 ;
+: rt-label     6 ;
+: rt-immediate 7 ;
+
+: rc-absolute? ( n -- ? )
+    [ rc-absolute-ppc-2/2 = ]
+    [ rc-absolute-cell = ]
+    [ rc-absolute = ]
+    tri or or ;
diff --git a/unfinished/compiler/backend/backend.factor b/unfinished/compiler/backend/backend.factor
index c1944eb9a7..ffe8f73ba9 100644
--- a/unfinished/compiler/backend/backend.factor
+++ b/unfinished/compiler/backend/backend.factor
@@ -1,10 +1,223 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system ;
+USING: accessors assocs arrays generic kernel kernel.private
+math memory namespaces make sequences layouts system hashtables
+classes alien byte-arrays combinators words sets classes.algebra
+compiler.cfg.registers compiler.cfg.instructions ;
 IN: compiler.backend
 
-! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? cpu ( size -- ? )
+! Labels
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
 
 ! 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
+
+! Return values of this class go here
+GENERIC: return-reg ( register-class -- reg )
+
+! Sequence of registers used for parameter passing in class
+GENERIC: param-regs ( register-class -- regs )
+
+GENERIC: param-reg ( n register-class -- reg )
+
+M: object param-reg param-regs nth ;
+
+! Load a literal (immediate or indirect)
+GENERIC# load-literal 1 ( obj vreg -- )
+
+HOOK: load-indirect cpu ( obj reg -- )
+
+HOOK: stack-frame cpu ( frame-size -- n )
+
+: stack-frame* ( -- n )
+    \ stack-frame get stack-frame ;
+
+! Set up caller stack frame
+HOOK: %prologue cpu ( n -- )
+
+! Tear down stack frame
+HOOK: %epilogue cpu ( n -- )
+
+! Call another word
+HOOK: %call cpu ( word -- )
+
+! Local jump for branches
+HOOK: %jump-label cpu ( label -- )
+
+! Test if vreg is 'f' or not
+HOOK: %jump-f cpu ( label vreg -- )
+
+! Test if vreg is 't' or not
+HOOK: %jump-t cpu ( label vreg -- )
+
+HOOK: %dispatch cpu ( -- )
+
+HOOK: %dispatch-label cpu ( word -- )
+
+! Return to caller
+HOOK: %return cpu ( -- )
+
+! Change datastack height
+HOOK: %inc-d cpu ( n -- )
+
+! Change callstack height
+HOOK: %inc-r cpu ( n -- )
+
+! Load stack into vreg
+HOOK: %peek cpu ( vreg loc -- )
+
+! Store vreg to stack
+HOOK: %replace cpu ( vreg loc -- )
+
+! Copy values between vregs
+HOOK: %copy cpu ( dst src -- )
+HOOK: %copy-float cpu ( dst src -- )
+
+! Box and unbox floats
+HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-float cpu ( dst src -- )
+
+! FFI stuff
+
+! Is this integer small enough to appear in value template
+! slots?
+HOOK: small-enough? cpu ( n -- ? )
+
+! Is this structure small enough to be returned in registers?
+HOOK: struct-small-enough? cpu ( heap-size -- ? )
+
+! Do we pass explode value structs?
+HOOK: value-structs? cpu ( -- ? )
+
+! If t, fp parameters are shadowed by dummy int parameters
+HOOK: fp-shadows-int? cpu ( -- ? )
+
+HOOK: %prepare-unbox cpu ( -- )
+
+HOOK: %unbox cpu ( n reg-class func -- )
+
+HOOK: %unbox-long-long cpu ( n func -- )
+
+HOOK: %unbox-small-struct cpu ( c-type -- )
+
+HOOK: %unbox-large-struct cpu ( n c-type -- )
+
+HOOK: %box cpu ( n reg-class func -- )
+
+HOOK: %box-long-long cpu ( n func -- )
+
+HOOK: %prepare-box-struct cpu ( size -- )
+
+HOOK: %box-small-struct cpu ( c-type -- )
+
+HOOK: %box-large-struct cpu ( n c-type -- )
+
+GENERIC: %save-param-reg ( stack reg reg-class -- )
+
+GENERIC: %load-param-reg ( stack reg reg-class -- )
+
+HOOK: %prepare-alien-invoke cpu ( -- )
+
+HOOK: %prepare-var-args cpu ( -- )
+
+M: object %prepare-var-args ;
+
+HOOK: %alien-invoke cpu ( function library -- )
+
+HOOK: %cleanup cpu ( alien-node -- )
+
+HOOK: %alien-callback cpu ( quot -- )
+
+HOOK: %callback-value cpu ( ctype -- )
+
+! Return to caller with stdcall unwinding (only for x86)
+HOOK: %unwind cpu ( n -- )
+
+HOOK: %prepare-alien-indirect cpu ( -- )
+
+HOOK: %alien-indirect cpu ( -- )
+
+M: stack-params param-reg drop ;
+
+M: stack-params param-regs drop f ;
+
+GENERIC: v>operand ( obj -- operand )
+
+SYMBOL: registers
+
+M: constant v>operand
+    value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+
+M: value v>operand
+    >vreg [ registers get at ] [ "Bad value" throw ] if* ;
+
+M: object load-literal v>operand load-indirect ;
+
+PREDICATE: small-slot < integer cells small-enough? ;
+
+PREDICATE: small-tagged < integer v>operand small-enough? ;
+
+: if-small-struct ( n size true false -- ? )
+    [ over not over struct-small-enough? and ] 2dip
+    [ [ nip ] prepose ] dip if ;
+    inline
+
+: %unbox-struct ( n c-type -- )
+    [
+        %unbox-small-struct
+    ] [
+        %unbox-large-struct
+    ] if-small-struct ;
+
+: %box-struct ( n c-type -- )
+    [
+        %box-small-struct
+    ] [
+        %box-large-struct
+    ] if-small-struct ;
+
+! Alien accessors
+HOOK: %unbox-byte-array cpu ( dst src -- )
+
+HOOK: %unbox-alien cpu ( dst src -- )
+
+HOOK: %unbox-f cpu ( dst src -- )
+
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
+
+HOOK: %box-alien cpu ( dst src -- )
+
+! GC check
+HOOK: %gc cpu ( -- )
+
+SYMBOL: operands
+
+: init-intrinsic ( insn -- )
+    [ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
+
+: (operand) ( name -- operand )
+    operands get at* [ "Bad operand name" throw ] unless ;
+
+: operand ( name -- operand )
+    (operand) v>operand ;
+
+: operand-class ( var -- class )
+    (operand) value-class ;
+
+: operand-tag ( operand -- tag/f )
+    operand-class dup [ class-tag ] when ;
+
+UNION: immediate fixnum POSTPONE: f ;
+
+: operand-immediate? ( operand -- ? )
+    operand-class immediate class<= ;
+
+: unique-operands ( operands quot -- )
+    >r [ operand ] map prune r> each ; inline
diff --git a/unfinished/compiler/backend/x86/32/32.factor b/unfinished/compiler/backend/x86/32/32.factor
index fabdaa7ff3..73fc81bd00 100644
--- a/unfinished/compiler/backend/x86/32/32.factor
+++ b/unfinished/compiler/backend/x86/32/32.factor
@@ -1,11 +1,318 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system cpu.x86.assembler compiler.cfg.registers
-compiler.backend ;
+USING: alien.c-types arrays kernel kernel.private math
+namespaces sequences stack-checker.known-words system layouts
+combinators command-line io vocabs.loader accessors init
+compiler compiler.units compiler.constants compiler.codegen
+compiler.cfg.builder compiler.alien compiler.codegen.fixup
+cpu.x86 compiler.backend compiler.backend.x86 ;
 IN: compiler.backend.x86.32
 
+! We implement the FFI for Linux, OS X and Windows all at once.
+! OS X requires that the stack be 16-byte aligned, and we do
+! this on all platforms, sacrificing some stack space for
+! code simplicity.
+
 M: x86.32 machine-registers
     {
         { int-regs { EAX ECX EDX EBP EBX } }
         { double-float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
     } ;
+
+M: x86.32 ds-reg ESI ;
+M: x86.32 rs-reg EDI ;
+M: x86.32 stack-reg ESP ;
+M: x86.32 stack-save-reg EDX ;
+M: x86.32 temp-reg-1 EAX ;
+M: x86.32 temp-reg-2 ECX ;
+
+M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
+
+M: x86.32 %alien-invoke (CALL) rel-dlsym ;
+
+M: x86.32 struct-small-enough? ( size -- ? )
+    heap-size { 1 2 4 8 } member?
+    os { linux netbsd solaris } member? not and ;
+
+! On x86, parameters are never passed in registers.
+M: int-regs return-reg drop EAX ;
+M: int-regs param-regs drop { } ;
+M: int-regs push-return-reg return-reg PUSH ;
+: load/store-int-return ( n reg-class -- src dst )
+    return-reg stack-reg rot [+] ;
+M: int-regs load-return-reg load/store-int-return MOV ;
+M: int-regs store-return-reg load/store-int-return swap MOV ;
+
+M: float-regs param-regs drop { } ;
+
+: FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
+
+M: float-regs push-return-reg
+    stack-reg swap reg-size [ SUB  stack-reg [] ] keep FSTP ;
+
+: FLD ( operand size -- ) 4 = [ FLDS ] [ FLDL ] if ;
+
+: load/store-float-return ( n reg-class -- op size )
+    [ stack@ ] [ reg-size ] bi* ;
+M: float-regs load-return-reg load/store-float-return FLD ;
+M: float-regs store-return-reg load/store-float-return FSTP ;
+
+: align-sub ( n -- )
+    dup 16 align swap - ESP swap SUB ;
+
+: align-add ( n -- )
+    16 align ESP swap ADD ;
+
+: with-aligned-stack ( n quot -- )
+    swap dup align-sub slip align-add ; inline
+
+M: x86.32 fixnum>slot@ 1 SHR ;
+
+M: x86.32 prepare-division CDQ ;
+
+M: x86.32 load-indirect
+    0 [] MOV rc-absolute-cell rel-literal ;
+
+M: object %load-param-reg 3drop ;
+
+M: object %save-param-reg 3drop ;
+
+: box@ ( n reg-class -- stack@ )
+    #! Used for callbacks; we want to box the values given to
+    #! us by the C function caller. Computes stack location of
+    #! nth parameter; note that we must go back one more stack
+    #! frame, since %box sets one up to call the one-arg boxer
+    #! function. The size of this stack frame so far depends on
+    #! the reg-class of the boxer's arg.
+    reg-size neg + stack-frame* + 20 + ;
+
+: (%box) ( n reg-class -- )
+    #! If n is f, push the return register onto the stack; we
+    #! are boxing a return value of a C function. If n is an
+    #! integer, push [ESP+n] on the stack; we are boxing a
+    #! parameter being passed to a callback from C.
+    over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
+    push-return-reg ;
+
+M: x86.32 %box ( n reg-class func -- )
+    over reg-size [
+        >r (%box) r> f %alien-invoke
+    ] with-aligned-stack ;
+    
+: (%box-long-long) ( n -- )
+    #! If n is f, push the return registers onto the stack; we
+    #! are boxing a return value of a C function. If n is an
+    #! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
+    #! boxing a parameter being passed to a callback from C.
+    [
+        int-regs box@
+        EDX over stack@ MOV
+        EAX swap cell - stack@ MOV 
+    ] when*
+    EDX PUSH
+    EAX PUSH ;
+
+M: x86.32 %box-long-long ( n func -- )
+    8 [
+        [ (%box-long-long) ] [ f %alien-invoke ] bi*
+    ] with-aligned-stack ;
+
+: struct-return@ ( size n -- n )
+    [ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
+
+M: x86.32 %box-large-struct ( n c-type -- )
+    ! Compute destination address
+    heap-size
+    [ swap struct-return@ ] keep
+    ECX ESP roll [+] LEA
+    8 [
+        ! Push struct size
+        PUSH
+        ! Push destination address
+        ECX PUSH
+        ! Copy the struct from the C stack
+        "box_value_struct" f %alien-invoke
+    ] with-aligned-stack ;
+
+M: x86.32 %prepare-box-struct ( size -- )
+    ! Compute target address for value struct return
+    EAX ESP rot f struct-return@ [+] LEA
+    ! Store it as the first parameter
+    ESP [] EAX MOV ;
+
+M: x86.32 %box-small-struct ( c-type -- )
+    #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
+    12 [
+        heap-size PUSH
+        EDX PUSH
+        EAX PUSH
+        "box_small_struct" f %alien-invoke
+    ] with-aligned-stack ;
+
+M: x86.32 %prepare-unbox ( -- )
+    #! Move top of data stack to EAX.
+    EAX ESI [] MOV
+    ESI 4 SUB ;
+
+: (%unbox) ( func -- )
+    4 [
+        ! Push parameter
+        EAX PUSH
+        ! Call the unboxer
+        f %alien-invoke
+    ] with-aligned-stack ;
+
+M: x86.32 %unbox ( n reg-class func -- )
+    #! The value being unboxed must already be in EAX.
+    #! If n is f, we're unboxing a return value about to be
+    #! returned by the callback. Otherwise, we're unboxing
+    #! a parameter to a C function about to be called.
+    (%unbox)
+    ! Store the return value on the C stack
+    over [ store-return-reg ] [ 2drop ] if ;
+
+M: x86.32 %unbox-long-long ( n func -- )
+    (%unbox)
+    ! Store the return value on the C stack
+    [
+        dup stack@ EAX MOV
+        cell + stack@ EDX MOV
+    ] when* ;
+
+: %unbox-struct-1 ( -- )
+    #! Alien must be in EAX.
+    4 [
+        EAX PUSH
+        "alien_offset" f %alien-invoke
+        ! Load first cell
+        EAX EAX [] MOV
+    ] with-aligned-stack ;
+
+: %unbox-struct-2 ( -- )
+    #! Alien must be in EAX.
+    4 [
+        EAX PUSH
+        "alien_offset" f %alien-invoke
+        ! Load second cell
+        EDX EAX 4 [+] MOV
+        ! Load first cell
+        EAX EAX [] MOV
+    ] with-aligned-stack ;
+
+M: x86 %unbox-small-struct ( size -- )
+    #! Alien must be in EAX.
+    heap-size cell align cell /i {
+        { 1 [ %unbox-struct-1 ] }
+        { 2 [ %unbox-struct-2 ] }
+    } case ;
+
+M: x86.32 %unbox-large-struct ( n c-type -- )
+    #! Alien must be in EAX.
+    heap-size
+    ! Compute destination address
+    ECX ESP roll [+] LEA
+    12 [
+        ! Push struct size
+        PUSH
+        ! Push destination address
+        ECX PUSH
+        ! Push source address
+        EAX PUSH
+        ! Copy the struct to the stack
+        "to_value_struct" f %alien-invoke
+    ] with-aligned-stack ;
+
+M: x86.32 %prepare-alien-indirect ( -- )
+    "unbox_alien" f %alien-invoke
+    cell temp@ EAX MOV ;
+
+M: x86.32 %alien-indirect ( -- )
+    cell temp@ CALL ;
+
+M: x86.32 %alien-callback ( quot -- )
+    4 [
+        EAX load-indirect
+        EAX PUSH
+        "c_to_factor" f %alien-invoke
+    ] with-aligned-stack ;
+
+M: x86.32 %callback-value ( ctype -- )
+    ! Align C stack
+    ESP 12 SUB
+    ! Save top of data stack
+    %prepare-unbox
+    EAX PUSH
+    ! Restore data/call/retain stacks
+    "unnest_stacks" f %alien-invoke
+    ! Place top of data stack in EAX
+    EAX POP
+    ! Restore C stack
+    ESP 12 ADD
+    ! Unbox EAX
+    unbox-return ;
+
+M: x86.32 %cleanup ( alien-node -- )
+    #! a) If we just called an stdcall function in Windows, it
+    #! cleaned up the stack frame for us. But we don't want that
+    #! so we 'undo' the cleanup since we do that in %epilogue.
+    #! b) If we just called a function returning a struct, we
+    #! have to fix ESP.
+    {
+        {
+            [ dup abi>> "stdcall" = ]
+            [ alien-stack-frame ESP swap SUB ]
+        } {
+            [ dup return>> large-struct? ]
+            [ drop EAX PUSH ]
+        }
+        [ drop ]
+    } cond ;
+
+M: x86.32 %unwind ( n -- ) RET ;
+
+os windows? [
+    cell "longlong" c-type (>>align)
+    cell "ulonglong" c-type (>>align)
+    4 "double" c-type (>>align)
+] unless
+
+: (sse2?) ( -- ? ) "Intrinsic" throw ;
+
+<<
+
+\ (sse2?) [
+    { EAX EBX ECX EDX } [ PUSH ] each
+    EAX 1 MOV
+    CPUID
+    EDX 26 SHR
+    EDX 1 AND
+    { EAX EBX ECX EDX } [ POP ] each
+    JE
+] { } define-if-intrinsic
+
+\ (sse2?) { } { object } define-primitive
+
+>>
+
+: sse2? ( -- ? ) (sse2?) ;
+
+"-no-sse2" cli-args member? [
+    "Checking if your CPU supports SSE2..." print flush
+    [ optimized-recompile-hook ] recompile-hook [
+        [ sse2? ] compile-call
+    ] with-variable
+    [
+        " - yes" print
+        "compiler.backend.x86.sse2" require
+        [
+            sse2? [
+                "This image was built to use SSE2, which your CPU does not support." print
+                "You will need to bootstrap Factor again." print
+                flush
+                1 exit
+            ] unless
+        ] "compiler.backend.x86" add-init-hook
+    ] [
+        " - no" print
+    ] if
+] unless
diff --git a/unfinished/compiler/backend/x86/64/64.factor b/unfinished/compiler/backend/x86/64/64.factor
index 9499995068..c8760e51b4 100644
--- a/unfinished/compiler/backend/x86/64/64.factor
+++ b/unfinished/compiler/backend/x86/64/64.factor
@@ -1,7 +1,11 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: system cpu.x86.assembler compiler.cfg.registers
-compiler.backend ;
+USING: accessors alien.c-types arrays kernel kernel.private math
+namespaces make sequences system layouts alien alien.accessors
+alien.structs slots splitting assocs combinators
+cpu.x86 compiler.codegen compiler.constants
+compiler.codegen.fixup compiler.cfg.registers compiler.backend
+compiler.backend.x86 compiler.backend.x86.sse2 ;
 IN: compiler.backend.x86.64
 
 M: x86.64 machine-registers
@@ -12,3 +16,211 @@ M: x86.64 machine-registers
             XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
         } }
     } ;
+
+M: x86.64 ds-reg R14 ;
+M: x86.64 rs-reg R15 ;
+M: x86.64 stack-reg RSP ;
+M: x86.64 stack-save-reg RSI ;
+M: x86.64 temp-reg-1 RAX ;
+M: x86.64 temp-reg-2 RCX ;
+
+M: int-regs return-reg drop RAX ;
+M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
+
+M: float-regs return-reg drop XMM0 ;
+
+M: float-regs param-regs
+    drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+
+M: x86.64 fixnum>slot@ drop ;
+
+M: x86.64 prepare-division CQO ;
+
+M: x86.64 load-indirect ( literal reg -- )
+    0 [] MOV rc-relative rel-literal ;
+
+M: stack-params %load-param-reg
+    drop
+    >r R11 swap stack@ MOV
+    r> stack@ R11 MOV ;
+
+M: stack-params %save-param-reg
+    >r stack-frame* + cell + swap r> %load-param-reg ;
+
+: with-return-regs ( quot -- )
+    [
+        V{ RDX RAX } clone int-regs set
+        V{ XMM1 XMM0 } clone float-regs set
+        call
+    ] with-scope ; inline
+
+! The ABI for passing structs by value is pretty messed up
+<< "void*" c-type clone "__stack_value" define-primitive-type
+stack-params "__stack_value" c-type (>>reg-class) >>
+
+: struct-types&offset ( struct-type -- pairs )
+    fields>> [
+        [ type>> ] [ offset>> ] bi 2array
+    ] map ;
+
+: split-struct ( pairs -- seq )
+    [
+        [ 8 mod zero? [ t , ] when , ] assoc-each
+    ] { } make { t } split harvest ;
+
+: flatten-small-struct ( c-type -- seq )
+    struct-types&offset split-struct [
+        [ c-type c-type-reg-class ] map
+        int-regs swap member? "void*" "double" ? c-type
+    ] map ;
+
+: flatten-large-struct ( c-type -- seq )
+    heap-size cell align
+    cell /i "__stack_value" c-type <repetition> ;
+
+M: struct-type flatten-value-type ( type -- seq )
+    dup heap-size 16 > [
+        flatten-large-struct
+    ] [
+        flatten-small-struct
+    ] if ;
+
+M: x86.64 %prepare-unbox ( -- )
+    ! First parameter is top of stack
+    RDI R14 [] MOV
+    R14 cell SUB ;
+
+M: x86.64 %unbox ( n reg-class func -- )
+    ! Call the unboxer
+    f %alien-invoke
+    ! Store the return value on the C stack
+    over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
+
+M: x86.64 %unbox-long-long ( n func -- )
+    int-regs swap %unbox ;
+
+: %unbox-struct-field ( c-type i -- )
+    ! Alien must be in RDI.
+    RDI swap cells [+] swap reg-class>> {
+        { int-regs [ int-regs get pop swap MOV ] }
+        { double-float-regs [ float-regs get pop swap MOVSD ] }
+    } case ;
+
+M: x86.64 %unbox-small-struct ( c-type -- )
+    ! Alien must be in RDI.
+    "alien_offset" f %alien-invoke
+    ! Move alien_offset() return value to RDI so that we don't
+    ! clobber it.
+    RDI RAX MOV
+    [
+        flatten-small-struct [ %unbox-struct-field ] each-index
+    ] with-return-regs ;
+
+M: x86.64 %unbox-large-struct ( n c-type -- )
+    ! Source is in RDI
+    heap-size
+    ! Load destination address
+    RSI RSP roll [+] LEA
+    ! Load structure size
+    RDX swap MOV
+    ! Copy the struct to the C stack
+    "to_value_struct" f %alien-invoke ;
+
+: load-return-value ( reg-class -- )
+    0 over param-reg swap return-reg
+    2dup eq? [ 2drop ] [ MOV ] if ;
+
+M: x86.64 %box ( n reg-class func -- )
+    rot [
+        rot [ 0 swap param-reg ] keep %load-param-reg
+    ] [
+        swap load-return-value
+    ] if*
+    f %alien-invoke ;
+
+M: x86.64 %box-long-long ( n func -- )
+    int-regs swap %box ;
+
+M: x86.64 struct-small-enough? ( size -- ? )
+    heap-size 2 cells <= ;
+
+: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
+
+: %box-struct-field ( c-type i -- )
+    box-struct-field@ swap reg-class>> {
+        { int-regs [ int-regs get pop MOV ] }
+        { double-float-regs [ float-regs get pop MOVSD ] }
+    } case ;
+
+M: x86.64 %box-small-struct ( c-type -- )
+    #! Box a <= 16-byte struct.
+    [
+        [ flatten-small-struct [ %box-struct-field ] each-index ]
+        [ RDX swap heap-size MOV ] bi
+        RDI 0 box-struct-field@ MOV
+        RSI 1 box-struct-field@ MOV
+        "box_small_struct" f %alien-invoke
+    ] with-return-regs ;
+
+: struct-return@ ( size n -- n )
+    [ ] [ \ stack-frame get swap - ] ?if ;
+
+M: x86.64 %box-large-struct ( n c-type -- )
+    ! Struct size is parameter 2
+    heap-size
+    RSI over MOV
+    ! Compute destination address
+    swap struct-return@ RDI RSP rot [+] LEA
+    ! Copy the struct from the C stack
+    "box_value_struct" f %alien-invoke ;
+
+M: x86.64 %prepare-box-struct ( size -- )
+    ! Compute target address for value struct return
+    RAX RSP rot f struct-return@ [+] LEA
+    RSP 0 [+] RAX MOV ;
+
+M: x86.64 %prepare-var-args RAX RAX XOR ;
+
+M: x86.64 %alien-global
+    [ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
+
+M: x86.64 %alien-invoke
+    R11 0 MOV
+    rc-absolute-cell rel-dlsym
+    R11 CALL ;
+
+M: x86.64 %prepare-alien-indirect ( -- )
+    "unbox_alien" f %alien-invoke
+    cell temp@ RAX MOV ;
+
+M: x86.64 %alien-indirect ( -- )
+    cell temp@ CALL ;
+
+M: x86.64 %alien-callback ( quot -- )
+    RDI load-indirect "c_to_factor" f %alien-invoke ;
+
+M: x86.64 %callback-value ( ctype -- )
+    ! Save top of data stack
+    %prepare-unbox
+    ! Put former top of data stack in RDI
+    cell temp@ RDI MOV
+    ! Restore data/call/retain stacks
+    "unnest_stacks" f %alien-invoke
+    ! Put former top of data stack in RDI
+    RDI cell temp@ MOV
+    ! Unbox former top of data stack to return registers
+    unbox-return ;
+
+M: x86.64 %cleanup ( alien-node -- ) drop ;
+
+M: x86.64 %unwind ( n -- ) drop 0 RET ;
+
+USE: cpu.x86.intrinsics
+
+! On 64-bit systems, the result of reading 4 bytes from memory
+! is a fixnum.
+\ alien-unsigned-4 small-reg-32 define-unsigned-getter
+\ set-alien-unsigned-4 small-reg-32 define-setter
+
+\ alien-signed-4 small-reg-32 define-signed-getter
+\ set-alien-signed-4 small-reg-32 define-setter
diff --git a/unfinished/compiler/backend/x86/sse2/sse2.factor b/unfinished/compiler/backend/x86/sse2/sse2.factor
new file mode 100644
index 0000000000..2d82a7a368
--- /dev/null
+++ b/unfinished/compiler/backend/x86/sse2/sse2.factor
@@ -0,0 +1,110 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors arrays generic kernel system
+kernel.private math math.private memory namespaces sequences
+words math.floats.private layouts quotations cpu.x86
+compiler.cfg.templates compiler.cfg.builder compiler.cfg.registers
+compiler.constants compiler.backend compiler.backend.x86 ;
+IN: compiler.backend.x86.sse2
+
+M: x86 %box-float ( dst src -- )
+    #! Only called by pentium4 backend, uses SSE2 instruction
+    #! dest is a loc or a vreg
+    float 16 [
+        8 (object@) swap v>operand MOVSD
+        float %store-tagged
+    ] %allot ;
+
+M: x86 %unbox-float ( dst src -- )
+    [ v>operand ] bi@ float-offset [+] MOVSD ;
+
+: define-float-op ( word op -- )
+    [ "x" operand "y" operand ] swap suffix T{ template
+        { input { { float "x" } { float "y" } } }
+        { output { "x" } }
+        { gc t }
+    } define-intrinsic ;
+
+{
+    { float+ ADDSD }
+    { float- SUBSD }
+    { float* MULSD }
+    { float/f DIVSD }
+} [
+    first2 define-float-op
+] each
+
+: define-float-jump ( word op -- )
+    [ "x" operand "y" operand UCOMISD ] swap suffix
+    { { float "x" } { float "y" } } define-if-intrinsic ;
+
+{
+    { float< JAE }
+    { float<= JA }
+    { float> JBE }
+    { float>= JB }
+    { float= JNE }
+} [
+    first2 define-float-jump
+] each
+
+\ float>fixnum [
+    "out" operand "in" operand CVTTSD2SI
+    "out" operand tag-bits get SHL
+] T{ template
+    { input { { float "in" } } }
+    { scratch { { f "out" } } }
+    { output { "out" } }
+} define-intrinsic
+
+\ fixnum>float [
+    "in" operand %untag-fixnum
+    "out" operand "in" operand CVTSI2SD
+] T{ template
+    { input { { f "in" } } }
+    { scratch { { float "out" } } }
+    { output { "out" } }
+    { clobber { "in" } }
+    { gc t }
+} define-intrinsic
+
+: alien-float-get-template
+    T{ template
+        { input {
+            { unboxed-c-ptr "alien" c-ptr }
+            { f "offset" fixnum }
+        } }
+        { scratch { { float "value" } } }
+        { output { "value" } }
+        { clobber { "offset" } }
+    } ;
+
+: alien-float-set-template
+    T{ template
+        { input {
+            { float "value" float }
+            { unboxed-c-ptr "alien" c-ptr }
+            { f "offset" fixnum }
+        } }
+        { clobber { "offset" } }
+    } ;
+
+: define-alien-float-intrinsics ( word get-quot word set-quot -- )
+    [ "value" operand swap %alien-accessor ] curry
+    alien-float-set-template
+    define-intrinsic
+    [ "value" operand swap %alien-accessor ] curry
+    alien-float-get-template
+    define-intrinsic ;
+
+\ alien-double
+[ MOVSD ]
+\ set-alien-double
+[ swap MOVSD ]
+define-alien-float-intrinsics
+
+\ alien-float
+[ dupd MOVSS dup CVTSS2SD ]
+\ set-alien-float
+[ swap dup dup CVTSD2SS MOVSS ]
+define-alien-float-intrinsics
diff --git a/unfinished/compiler/backend/x86/x86.factor b/unfinished/compiler/backend/x86/x86.factor
new file mode 100644
index 0000000000..1ef2ebfbc4
--- /dev/null
+++ b/unfinished/compiler/backend/x86/x86.factor
@@ -0,0 +1,755 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays alien.accessors
+compiler.backend kernel kernel.private math memory namespaces
+make sequences words system layouts combinators math.order
+math.private alien alien.c-types slots.private cpu.x86
+cpu.x86.private compiler.backend compiler.codegen.fixup
+compiler.constants compiler.intrinsics compiler.cfg.builder
+compiler.cfg.registers compiler.cfg.stacks
+compiler.cfg.templates ;
+IN: compiler.backend.x86
+
+M: word MOV 0 rot (MOV-I) rc-absolute-cell rel-word ;
+M: word JMP (JMP) rel-word ;
+M: label JMP (JMP) label-fixup ;
+M: word CALL (CALL) rel-word ;
+M: label CALL (CALL) label-fixup ;
+M: word JUMPcc (JUMPcc) rel-word ;
+M: label JUMPcc (JUMPcc) label-fixup ;
+
+HOOK: ds-reg cpu ( -- reg )
+HOOK: rs-reg cpu ( -- reg )
+HOOK: stack-reg cpu ( -- reg )
+HOOK: stack-save-reg cpu ( -- reg )
+
+: stack@ ( n -- op ) stack-reg swap [+] ;
+
+: reg-stack ( n reg -- op ) swap cells neg [+] ;
+
+M: ds-loc v>operand n>> ds-reg reg-stack ;
+M: rs-loc v>operand n>> rs-reg reg-stack ;
+
+M: int-regs %save-param-reg drop >r stack@ r> MOV ;
+M: int-regs %load-param-reg drop swap stack@ MOV ;
+
+GENERIC: MOVSS/D ( dst src reg-class -- )
+
+M: single-float-regs MOVSS/D drop MOVSS ;
+M: double-float-regs MOVSS/D drop MOVSD ;
+
+M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
+M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
+
+GENERIC: push-return-reg ( reg-class -- )
+GENERIC: load-return-reg ( stack@ reg-class -- )
+GENERIC: store-return-reg ( stack@ reg-class -- )
+
+! Only used by inline allocation
+HOOK: temp-reg-1 cpu ( -- reg )
+HOOK: temp-reg-2 cpu ( -- reg )
+
+HOOK: fixnum>slot@ cpu ( op -- )
+
+HOOK: prepare-division cpu ( -- )
+
+M: f load-literal
+    v>operand \ f tag-number MOV drop ;
+
+M: fixnum load-literal
+    v>operand swap tag-fixnum MOV ;
+
+M: x86 stack-frame ( n -- i )
+    3 cells + 16 align cell - ;
+
+: factor-area-size ( -- n ) 4 cells ;
+
+M: x86 %prologue ( n -- )
+    temp-reg-1 0 MOV rc-absolute-cell rel-this
+    dup cell + PUSH
+    temp-reg-1 PUSH
+    stack-reg swap 2 cells - SUB ;
+
+M: x86 %epilogue ( n -- )
+    stack-reg swap ADD ;
+
+HOOK: %alien-global cpu ( symbol dll register -- )
+
+M: x86 %prepare-alien-invoke
+    #! Save Factor stack pointers in case the C code calls a
+    #! callback which does a GC, which must reliably trace
+    #! all roots.
+    "stack_chain" f temp-reg-1 %alien-global
+    temp-reg-1 [] stack-reg MOV
+    temp-reg-1 [] cell SUB
+    temp-reg-1 2 cells [+] ds-reg MOV
+    temp-reg-1 3 cells [+] rs-reg MOV ;
+
+M: x86 %call ( label -- ) CALL ;
+
+M: x86 %jump-label ( label -- ) JMP ;
+
+M: x86 %jump-f ( label vreg -- ) \ f tag-number CMP JE ;
+
+M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
+
+: code-alignment ( -- n )
+    building get length dup cell align swap - ;
+
+: align-code ( n -- )
+    0 <repetition> % ;
+
+M: x86 %dispatch ( -- )
+    ! Load jump table base. We use a temporary register
+    ! since on AMD64 we have to load a 64-bit immediate. On
+    ! x86, this is redundant.
+    ! Untag and multiply to get a jump table offset
+    temp-reg-1 fixnum>slot@
+    ! Add jump table base
+    temp-reg-2 HEX: ffffffff MOV rc-absolute-cell rel-here
+    temp-reg-1 temp-reg-2 ADD
+    temp-reg-1 HEX: 7f [+] JMP
+    ! Fix up the displacement above
+    code-alignment dup bootstrap-cell 8 = 15 9 ? +
+    building get dup pop* push
+    align-code ;
+
+M: x86 %dispatch-label ( word -- )
+    0 cell, rc-absolute-cell rel-word ;
+
+M: x86 %peek [ v>operand ] bi@ MOV ;
+
+M: x86 %replace swap %peek ;
+
+: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
+
+M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
+
+M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
+
+M: x86 fp-shadows-int? ( -- ? ) f ;
+
+M: x86 value-structs? t ;
+
+M: x86 small-enough? ( n -- ? )
+    HEX: -80000000 HEX: 7fffffff between? ;
+
+: %untag ( reg -- ) tag-mask get bitnot AND ;
+
+: %untag-fixnum ( reg -- ) tag-bits get SAR ;
+
+: %tag-fixnum ( reg -- ) tag-bits get SHL ;
+
+: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
+
+M: x86 %return ( -- ) 0 %unwind ;
+
+! Alien intrinsics
+M: x86 %unbox-byte-array ( dst src -- )
+    [ v>operand ] bi@ byte-array-offset [+] LEA ;
+
+M: x86 %unbox-alien ( dst src -- )
+    [ v>operand ] bi@ alien-offset [+] MOV ;
+
+M: x86 %unbox-f ( dst src -- )
+    drop v>operand 0 MOV ;
+
+M: x86 %unbox-any-c-ptr ( dst src -- )
+    { "is-byte-array" "end" "start" } [ define-label ] each
+    ! Address is computed in ds-reg
+    ds-reg PUSH
+    ds-reg 0 MOV
+    ! Object is stored in ds-reg
+    rs-reg PUSH
+    rs-reg swap v>operand MOV
+    ! We come back here with displaced aliens
+    "start" resolve-label
+    ! Is the object f?
+    rs-reg \ f tag-number CMP
+    "end" get JE
+    ! Is the object an alien?
+    rs-reg header-offset [+] alien type-number tag-fixnum CMP
+    "is-byte-array" get JNE
+    ! If so, load the offset and add it to the address
+    ds-reg rs-reg alien-offset [+] ADD
+    ! Now recurse on the underlying alien
+    rs-reg rs-reg underlying-alien-offset [+] MOV
+    "start" get JMP
+    "is-byte-array" resolve-label
+    ! Add byte array address to address being computed
+    ds-reg rs-reg ADD
+    ! Add an offset to start of byte array's data
+    ds-reg byte-array-offset ADD
+    "end" resolve-label
+    ! Done, store address in destination register
+    v>operand ds-reg MOV
+    ! Restore rs-reg
+    rs-reg POP
+    ! Restore ds-reg
+    ds-reg POP ;
+
+: allot-reg ( -- reg )
+    #! We temporarily use the datastack register, since it won't
+    #! be accessed inside the quotation given to %allot in any
+    #! case.
+    ds-reg ;
+
+: (object@) ( n -- operand ) allot-reg swap [+] ;
+
+: object@ ( n -- operand ) cells (object@) ;
+
+: load-zone-ptr ( reg -- )
+    #! Load pointer to start of zone array
+    0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+
+: load-allot-ptr ( -- )
+    allot-reg load-zone-ptr
+    allot-reg PUSH
+    allot-reg dup cell [+] MOV ;
+
+: inc-allot-ptr ( n -- )
+    allot-reg POP
+    allot-reg cell [+] swap 8 align ADD ;
+
+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
+    %prepare-alien-invoke
+    "minor_gc" f %alien-invoke
+    "end" resolve-label ;
+
+: store-header ( header -- )
+    0 object@ swap type-number tag-fixnum MOV ;
+
+: %allot ( header size quot -- )
+    allot-reg PUSH
+    swap >r >r
+    load-allot-ptr
+    store-header
+    r> call
+    r> inc-allot-ptr
+    allot-reg POP ; inline
+
+: fresh-object drop ;
+
+: %store-tagged ( reg tag -- )
+    >r dup fresh-object v>operand r>
+    allot-reg swap tag-number OR
+    allot-reg MOV ;
+
+: %allot-bignum-signed-1 ( outreg inreg -- )
+    #! on entry, inreg is a signed 32-bit quantity
+    #! exits with tagged ptr to bignum in outreg
+    #! 1 cell header, 1 cell length, 1 cell sign, + digits
+    #! length is the # of digits + sign
+    [
+        { "end" "nonzero" "positive" "store" }
+        [ define-label ] each
+        dup v>operand 0 CMP ! is it zero?
+        "nonzero" get JNE
+        0 >bignum pick v>operand load-indirect ! this is our result
+        "end" get JMP
+        "nonzero" resolve-label
+        bignum 4 cells [
+            ! Write length
+            1 object@ 2 v>operand MOV
+            ! Test sign
+            dup v>operand 0 CMP
+            "positive" get JGE
+            2 object@ 1 MOV ! negative sign
+            dup v>operand NEG
+            "store" get JMP
+            "positive" resolve-label
+            2 object@ 0 MOV ! positive sign
+            "store" resolve-label
+            3 object@ swap v>operand MOV
+            ! Store tagged ptr in reg
+            bignum %store-tagged
+        ] %allot
+        "end" resolve-label
+    ] with-scope ;
+
+M: x86 %box-alien ( dst src -- )
+    [
+        { "end" "f" } [ define-label ] each
+        dup v>operand 0 CMP
+        "f" get JE
+        alien 4 cells [
+            1 object@ \ f tag-number MOV
+            2 object@ \ f tag-number MOV
+            ! Store src in alien-offset slot
+            3 object@ swap v>operand MOV
+            ! Store tagged ptr in dst
+            dup object %store-tagged
+        ] %allot
+        "end" get JMP
+        "f" resolve-label
+        f [ v>operand ] bi@ MOV
+        "end" resolve-label
+    ] with-scope ;
+
+! Type checks
+\ tag [
+    "in" operand tag-mask get AND
+    "in" operand %tag-fixnum
+] T{ template
+    { input { { f "in" } } }
+    { output { "in" } }
+} define-intrinsic
+
+! Slots
+: %slot-literal-known-tag ( -- op )
+    "obj" operand
+    "n" get cells
+    "obj" operand-tag - [+] ;
+
+: %slot-literal-any-tag ( -- op )
+    "obj" operand %untag
+    "obj" operand "n" get cells [+] ;
+
+: %slot-any ( -- op )
+    "obj" operand %untag
+    "n" operand fixnum>slot@
+    "obj" operand "n" operand [+] ;
+
+\ slot {
+    ! Slot number is literal and the tag is known
+    {
+        [ "val" operand %slot-literal-known-tag MOV ] T{ template
+            { input { { f "obj" known-tag } { [ small-slot? ] "n" } } }
+            { scratch { { f "val" } } }
+            { output { "val" } }
+        }
+    }
+    ! Slot number is literal
+    {
+        [ "obj" operand %slot-literal-any-tag MOV ] T{ template
+            { input { { f "obj" } { [ small-slot? ] "n" } } }
+            { output { "obj" } }
+        }
+    }
+    ! Slot number in a register
+    {
+        [ "obj" operand %slot-any MOV ] T{ template
+            { input { { f "obj" } { f "n" } } }
+            { output { "obj" } }
+            { clobber { "n" } }
+        }
+    }
+} define-intrinsics
+
+: generate-write-barrier ( -- )
+    #! Mark the card pointed to by vreg.
+    "val" operand-immediate? "obj" fresh-object? or [
+        ! Mark the card
+        "obj" operand card-bits SHR
+        "cards_offset" f "scratch" operand %alien-global
+        "scratch" operand "obj" operand [+] card-mark <byte> MOV
+
+        ! Mark the card deck
+        "obj" operand deck-bits card-bits - SHR
+        "decks_offset" f "scratch" operand %alien-global
+        "scratch" operand "obj" operand [+] card-mark <byte> MOV
+    ] unless ;
+
+\ set-slot {
+    ! Slot number is literal and the tag is known
+    {
+        [ %slot-literal-known-tag "val" operand MOV generate-write-barrier ] T{ template
+            { input { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
+            { scratch { { f "scratch" } } }
+            { clobber { "obj" } }
+        }
+    }
+    ! Slot number is literal
+    {
+        [ %slot-literal-any-tag "val" operand MOV generate-write-barrier ] T{ template
+            { input { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
+            { scratch { { f "scratch" } } }
+            { clobber { "obj" } }
+        }
+    }
+    ! Slot number in a register
+    {
+        [ %slot-any "val" operand MOV generate-write-barrier ] T{ template
+            { input { { f "val" } { f "obj" } { f "n" } } }
+            { scratch { { f "scratch" } } }
+            { clobber { "obj" "n" } }
+        }
+    }
+} define-intrinsics
+
+! Sometimes, we need to do stuff with operands which are
+! less than the word size. Instead of teaching the register
+! allocator about the different sized registers, with all
+! the complexity this entails, we just push/pop a register
+! which is guaranteed to be unused (the tempreg)
+: small-reg cell 8 = RBX EBX ? ; inline
+: small-reg-8 BL ; inline
+: small-reg-16 BX ; inline
+: small-reg-32 EBX ; inline
+
+! Fixnums
+: fixnum-op ( op hash -- pair )
+    >r [ "x" operand "y" operand ] swap suffix r> 2array ;
+
+: fixnum-value-op ( op -- pair )
+    T{ template
+        { input { { f "x" } { [ small-tagged? ] "y" } } }
+        { output { "x" } }
+    } fixnum-op ;
+
+: fixnum-register-op ( op -- pair )
+    T{ template
+        { input { { f "x" } { f "y" } } }
+        { output { "x" } }
+    } fixnum-op ;
+
+: define-fixnum-op ( word op -- )
+    [ fixnum-value-op ] keep fixnum-register-op
+    2array define-intrinsics ;
+
+{
+    { fixnum+fast ADD }
+    { fixnum-fast SUB }
+    { fixnum-bitand AND }
+    { fixnum-bitor OR }
+    { fixnum-bitxor XOR }
+} [
+    first2 define-fixnum-op
+] each
+
+\ fixnum-bitnot [
+    "x" operand NOT
+    "x" operand tag-mask get XOR
+] T{ template
+    { input { { f "x" } } }
+    { output { "x" } }
+} define-intrinsic
+
+\ fixnum*fast {
+    {
+        [
+            "x" operand "y" get IMUL2
+        ] T{ template
+            { input { { f "x" } { [ small-tagged? ] "y" } } }
+            { output { "x" } }
+        }
+    } {
+        [
+            "out" operand "x" operand MOV
+            "out" operand %untag-fixnum
+            "y" operand "out" operand IMUL2
+        ] T{ template
+            { input { { f "x" } { f "y" } } }
+            { scratch { { f "out" } } }
+            { output { "out" } }
+        }
+    }
+} define-intrinsics
+
+: %untag-fixnums ( seq -- )
+    [ %untag-fixnum ] unique-operands ;
+
+\ fixnum-shift-fast [
+    "x" operand "y" get
+    dup 0 < [ neg SAR ] [ SHL ] if
+    ! Mask off low bits
+    "x" operand %untag
+] T{ template
+    { input { { f "x" } { [ ] "y" } } }
+    { output { "x" } }
+} define-intrinsic
+
+: overflow-check ( word -- )
+    "end" define-label
+    "z" operand "x" operand MOV
+    "z" operand "y" operand pick execute
+    ! If the previous arithmetic operation overflowed, then we
+    ! turn the result into a bignum and leave it in EAX.
+    "end" get JNO
+    ! There was an overflow. Recompute the original operand.
+    { "y" "x" } %untag-fixnums
+    "x" operand "y" operand rot execute
+    "z" get "x" get %allot-bignum-signed-1
+    "end" resolve-label ; inline
+
+: overflow-template ( word insn -- )
+    [ overflow-check ] curry T{ template
+        { input { { f "x" } { f "y" } } }
+        { scratch { { f "z" } } }
+        { output { "z" } }
+        { clobber { "x" "y" } }
+        { gc t }
+    } define-intrinsic ;
+
+\ fixnum+ \ ADD overflow-template
+\ fixnum- \ SUB overflow-template
+
+: fixnum-jump ( op inputs -- pair )
+    >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
+
+: fixnum-value-jump ( op -- pair )
+    { { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
+
+: fixnum-register-jump ( op -- pair )
+    { { f "x" } { f "y" } } fixnum-jump ;
+
+: define-fixnum-jump ( word op -- )
+    [ fixnum-value-jump ] keep fixnum-register-jump
+    2array define-if-intrinsics ;
+
+{
+    { fixnum< JL }
+    { fixnum<= JLE }
+    { fixnum> JG }
+    { fixnum>= JGE }
+    { eq? JE }
+} [
+    first2 define-fixnum-jump
+] each
+
+\ fixnum>bignum [
+    "x" operand %untag-fixnum
+    "x" get dup %allot-bignum-signed-1
+] T{ template
+    { input { { f "x" } } }
+    { output { "x" } }
+    { gc t }
+} define-intrinsic
+
+\ bignum>fixnum [
+    "nonzero" define-label
+    "positive" define-label
+    "end" define-label
+    "x" operand %untag
+    "y" operand "x" operand cell [+] MOV
+     ! if the length is 1, its just the sign and nothing else,
+     ! so output 0
+    "y" operand 1 v>operand CMP
+    "nonzero" get JNE
+    "y" operand 0 MOV
+    "end" get JMP
+    "nonzero" resolve-label
+    ! load the value
+    "y" operand "x" operand 3 cells [+] MOV
+    ! load the sign
+    "x" operand "x" operand 2 cells [+] MOV
+    ! is the sign negative?
+    "x" operand 0 CMP
+    "positive" get JE
+    "y" operand -1 IMUL2
+    "positive" resolve-label
+    "y" operand 3 SHL
+    "end" resolve-label
+] T{ template
+    { input { { f "x" } } }
+    { scratch { { f "y" } } }
+    { clobber { "x" } }
+    { output { "y" } }
+} define-intrinsic
+
+! User environment
+: %userenv ( -- )
+    "x" operand 0 MOV
+    "userenv" f rc-absolute-cell rel-dlsym
+    "n" operand fixnum>slot@
+    "n" operand "x" operand ADD ;
+
+\ getenv [
+    %userenv  "n" operand dup [] MOV
+] T{ template
+    { input { { f "n" } } }
+    { scratch { { f "x" } } }
+    { output { "n" } }
+} define-intrinsic
+
+\ setenv [
+    %userenv  "n" operand [] "val" operand MOV
+] T{ template
+    { input { { f "val" } { f "n" } } }
+    { scratch { { f "x" } } }
+    { clobber { "n" } }
+} define-intrinsic
+
+\ (tuple) [
+    tuple "layout" get size>> 2 + cells [
+        ! Store layout
+        "layout" get "scratch" operand load-indirect
+        1 object@ "scratch" operand MOV
+        ! Store tagged ptr in reg
+        "tuple" get tuple %store-tagged
+    ] %allot
+] T{ template
+    { input { { [ ] "layout" } } }
+    { scratch { { f "tuple" } { f "scratch" } } }
+    { output { "tuple" } }
+    { gc t }
+} define-intrinsic
+
+\ (array) [
+    array "n" get 2 + cells [
+        ! Store length
+        1 object@ "n" operand MOV
+        ! Store tagged ptr in reg
+        "array" get object %store-tagged
+    ] %allot
+] T{ template
+    { input { { [ ] "n" } } }
+    { scratch { { f "array" } } }
+    { output { "array" } }
+    { gc t }
+} define-intrinsic
+
+\ (byte-array) [
+    byte-array "n" get 2 cells + [
+        ! Store length
+        1 object@ "n" operand MOV
+        ! Store tagged ptr in reg
+        "array" get object %store-tagged
+    ] %allot
+] T{ template
+    { input { { [ ] "n" } } }
+    { scratch { { f "array" } } }
+    { output { "array" } }
+    { gc t }
+} define-intrinsic
+
+\ <ratio> [
+    ratio 3 cells [
+        1 object@ "numerator" operand MOV
+        2 object@ "denominator" operand MOV
+        ! Store tagged ptr in reg
+        "ratio" get ratio %store-tagged
+    ] %allot
+] T{ template
+    { input { { f "numerator" } { f "denominator" } } }
+    { scratch { { f "ratio" } } }
+    { output { "ratio" } }
+    { gc t }
+} define-intrinsic
+
+\ <complex> [
+    complex 3 cells [
+        1 object@ "real" operand MOV
+        2 object@ "imaginary" operand MOV
+        ! Store tagged ptr in reg
+        "complex" get complex %store-tagged
+    ] %allot
+] T{ template
+    { input { { f "real" } { f "imaginary" } } }
+    { scratch { { f "complex" } } }
+    { output { "complex" } }
+    { gc t }
+} define-intrinsic
+
+\ <wrapper> [
+    wrapper 2 cells [
+        1 object@ "obj" operand MOV
+        ! Store tagged ptr in reg
+        "wrapper" get object %store-tagged
+    ] %allot
+] T{ template
+    { input { { f "obj" } } }
+    { scratch { { f "wrapper" } } }
+    { output { "wrapper" } }
+    { gc t }
+} define-intrinsic
+
+! Alien intrinsics
+: %alien-accessor ( quot -- )
+    "offset" operand %untag-fixnum
+    "offset" operand "alien" operand ADD
+    "offset" operand [] swap call ; inline
+
+: %alien-integer-get ( quot reg -- )
+    small-reg PUSH
+    swap %alien-accessor
+    "value" operand small-reg MOV
+    "value" operand %tag-fixnum
+    small-reg POP ; inline
+
+: alien-integer-get-template
+    T{ template
+        { input {
+            { unboxed-c-ptr "alien" c-ptr }
+            { f "offset" fixnum }
+        } }
+        { scratch { { f "value" } } }
+        { output { "value" } }
+        { clobber { "offset" } }
+    } ;
+
+: define-getter ( word quot reg -- )
+    [ %alien-integer-get ] 2curry
+    alien-integer-get-template
+    define-intrinsic ;
+
+: define-unsigned-getter ( word reg -- )
+    [ small-reg dup XOR MOV ] swap define-getter ;
+
+: define-signed-getter ( word reg -- )
+    [ [ >r MOV small-reg r> MOVSX ] curry ] keep define-getter ;
+
+: %alien-integer-set ( quot reg -- )
+    small-reg PUSH
+    small-reg "value" operand MOV
+    small-reg %untag-fixnum
+    swap %alien-accessor
+    small-reg POP ; inline
+
+: alien-integer-set-template
+    T{ template
+        { input {
+            { f "value" fixnum }
+            { unboxed-c-ptr "alien" c-ptr }
+            { f "offset" fixnum }
+        } }
+        { clobber { "value" "offset" } }
+    } ;
+
+: define-setter ( word reg -- )
+    [ swap MOV ] swap
+    [ %alien-integer-set ] 2curry
+    alien-integer-set-template
+    define-intrinsic ;
+
+\ alien-unsigned-1 small-reg-8 define-unsigned-getter
+\ set-alien-unsigned-1 small-reg-8 define-setter
+
+\ alien-signed-1 small-reg-8 define-signed-getter
+\ set-alien-signed-1 small-reg-8 define-setter
+
+\ alien-unsigned-2 small-reg-16 define-unsigned-getter
+\ set-alien-unsigned-2 small-reg-16 define-setter
+
+\ alien-signed-2 small-reg-16 define-signed-getter
+\ set-alien-signed-2 small-reg-16 define-setter
+
+\ alien-cell [
+    "value" operand [ MOV ] %alien-accessor
+] T{ template
+    { input {
+        { unboxed-c-ptr "alien" c-ptr }
+        { f "offset" fixnum }
+    } }
+    { scratch { { unboxed-alien "value" } } }
+    { output { "value" } }
+    { clobber { "offset" } }
+} define-intrinsic
+
+\ set-alien-cell [
+    "value" operand [ swap MOV ] %alien-accessor
+] T{ template
+    { input {
+        { unboxed-c-ptr "value" pinned-c-ptr }
+        { unboxed-c-ptr "alien" c-ptr }
+        { f "offset" fixnum }
+    } }
+    { clobber { "offset" } }
+} define-intrinsic
diff --git a/unfinished/compiler/cfg/builder/builder.factor b/unfinished/compiler/cfg/builder/builder.factor
index f1199183d0..60dc5efdd9 100755
--- a/unfinished/compiler/cfg/builder/builder.factor
+++ b/unfinished/compiler/cfg/builder/builder.factor
@@ -32,18 +32,9 @@ IN: compiler.cfg.builder
 
 : stop-iterating ( -- next ) end-basic-block f ;
 
-USE: qualified
-FROM: compiler.generator.registers => +input+   ;
-FROM: compiler.generator.registers => +output+  ;
-FROM: compiler.generator.registers => +scratch+ ;
-FROM: compiler.generator.registers => +clobber+ ;
-
 SYMBOL: procedures
-
 SYMBOL: current-word
-
 SYMBOL: current-label
-
 SYMBOL: loops
 
 ! Basic block after prologue, makes recursion faster
@@ -81,8 +72,8 @@ GENERIC: emit-node ( node -- next )
     #! labelled by the current word, so that self-recursive
     #! calls can skip an epilogue/prologue.
     init-phantoms
-    %prologue
-    %branch
+    ##prologue
+    ##branch
     begin-basic-block
     current-label get remember-loop ;
 
@@ -92,27 +83,30 @@ GENERIC: emit-node ( node -- next )
         [ emit-nodes ] with-node-iterator
     ] with-cfg-builder ;
 
-: build-cfg ( nodes word label -- procedures )
+: build-cfg ( nodes word -- procedures )
     V{ } clone [
         procedures [
-            (build-cfg)
+            dup (build-cfg)
         ] with-variable
     ] keep ;
 
+SYMBOL: +intrinsics+
+SYMBOL: +if-intrinsics+
+
 : if-intrinsics ( #call -- quot )
-    word>> "if-intrinsics" word-prop ;
+    word>> +if-intrinsics+ word-prop ;
 
 : local-recursive-call ( basic-block -- next )
-    %branch
+    ##branch
     basic-block get successors>> push
     stop-iterating ;
 
 : emit-call ( word -- next )
     finalize-phantoms
     {
-        { [ tail-call? not ] [ 0 %frame-required %call iterate-next ] }
+        { [ tail-call? not ] [ 0 ##frame-required ##call iterate-next ] }
         { [ dup loops get key? ] [ loops get at local-recursive-call ] }
-        [ %epilogue %jump stop-iterating ]
+        [ ##epilogue ##jump stop-iterating ]
     } cond ;
 
 ! #recursive
@@ -130,50 +124,52 @@ M: #recursive emit-node
     dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
 
 ! #if
-: emit-branch ( nodes -- final-bb )
-    [
+: emit-branch ( obj quot -- final-bb )
+    '[
         begin-basic-block copy-phantoms
-        emit-nodes
-        basic-block get dup [ %branch ] when
+        @
+        basic-block get dup [ ##branch ] when
     ] with-scope ;
 
-: emit-if ( node -- next )
-    children>> [ emit-branch ] map
+: emit-branches ( seq quot -- )
+    '[ _ emit-branch ] map
     end-basic-block
     begin-basic-block
     basic-block get '[ [ _ swap successors>> push ] when* ] each
-    init-phantoms
-    iterate-next ;
+    init-phantoms ;
+
+: emit-if ( node -- next )
+    children>> [ emit-nodes ] emit-branches ;
 
 M: #if emit-node
-    { { f "flag" } } lazy-load first %branch-t
-    emit-if ;
+    { { f "flag" } } lazy-load first ##branch-t
+    emit-if iterate-next ;
 
 ! #dispatch
 : dispatch-branch ( nodes word -- label )
+    #! The order here is important, dispatch-branches must
+    #! run after ##dispatch, so that each branch gets the
+    #! correct register state
     gensym [
         [
             copy-phantoms
-            %prologue
+            ##prologue
             [ emit-nodes ] with-node-iterator
-            %epilogue
-            %return
+            ##epilogue
+            ##return
         ] with-cfg-builder
     ] keep ;
 
 : dispatch-branches ( node -- )
     children>> [
         current-word get dispatch-branch
-        %dispatch-label
+        ##dispatch-label
     ] each ;
 
 : emit-dispatch ( node -- )
-    %dispatch dispatch-branches init-phantoms ;
+    ##epilogue ##dispatch dispatch-branches init-phantoms ;
 
 M: #dispatch emit-node
-    #! The order here is important, dispatch-branches must
-    #! run after %dispatch, so that each branch gets the
-    #! correct register state
     tail-call? [
         emit-dispatch iterate-next
     ] [
@@ -187,23 +183,23 @@ M: #dispatch emit-node
 
 ! #call
 : define-intrinsics ( word intrinsics -- )
-    "intrinsics" set-word-prop ;
+    +intrinsics+ set-word-prop ;
 
 : define-intrinsic ( word quot assoc -- )
     2array 1array define-intrinsics ;
 
 : define-if-intrinsics ( word intrinsics -- )
-    [ +input+ associate ] assoc-map
-    "if-intrinsics" set-word-prop ;
+    [ template new swap >>input ] assoc-map
+    +if-intrinsics+ set-word-prop ;
 
 : define-if-intrinsic ( word quot inputs -- )
     2array 1array define-if-intrinsics ;
 
 : find-intrinsic ( #call -- pair/f )
-    word>> "intrinsics" word-prop find-template ;
+    word>> +intrinsics+ word-prop find-template ;
 
 : find-boolean-intrinsic ( #call -- pair/f )
-    word>> "if-intrinsics" word-prop find-template ;
+    word>> +if-intrinsics+ word-prop find-template ;
 
 : find-if-intrinsic ( #call -- pair/f )
     node@ {
@@ -213,21 +209,24 @@ M: #dispatch emit-node
     } cond ;
 
 : do-if-intrinsic ( pair -- next )
-    [ %if-intrinsic ] apply-template skip-next emit-if ;
+    [ ##if-intrinsic ] apply-template skip-next emit-if
+    iterate-next ;
 
 : do-boolean-intrinsic ( pair -- next )
-    [
-        f alloc-vreg [ %boolean-intrinsic ] keep phantom-push
-    ] apply-template iterate-next ;
+    [ ##if-intrinsic ] apply-template
+    { t f } [
+        <constant> phantom-push finalize-phantoms
+    ] emit-branches
+    iterate-next ;
 
 : do-intrinsic ( pair -- next )
-    [ %intrinsic ] apply-template iterate-next ;
+    [ ##intrinsic ] apply-template iterate-next ;
 
-: setup-operand-classes ( #call -- )
-    node-input-infos [ class>> ] map set-operand-classes ;
+: setup-value-classes ( #call -- )
+    node-input-infos [ class>> ] map set-value-classes ;
 
 M: #call emit-node
-    dup setup-operand-classes
+    dup setup-value-classes
     dup find-if-intrinsic [ do-if-intrinsic ] [
         dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
             dup find-intrinsic [ do-intrinsic ] [
@@ -259,12 +258,12 @@ M: #r> emit-node
 
 ! #return
 M: #return emit-node
-    drop finalize-phantoms %epilogue %return f ;
+    drop finalize-phantoms ##epilogue ##return f ;
 
 M: #return-recursive emit-node
     finalize-phantoms
     label>> id>> loops get key?
-    [ %epilogue %return ] unless f ;
+    [ ##epilogue ##return ] unless f ;
 
 ! #terminate
 M: #terminate emit-node drop stop-iterating ;
@@ -272,19 +271,19 @@ M: #terminate emit-node drop stop-iterating ;
 ! FFI
 M: #alien-invoke emit-node
     params>>
-    [ alien-invoke-frame %frame-required ]
-    [ %alien-invoke iterate-next ]
+    [ alien-invoke-frame ##frame-required ]
+    [ ##alien-invoke iterate-next ]
     bi ;
 
 M: #alien-indirect emit-node
     params>>
-    [ alien-invoke-frame %frame-required ]
-    [ %alien-indirect iterate-next ]
+    [ alien-invoke-frame ##frame-required ]
+    [ ##alien-indirect iterate-next ]
     bi ;
 
 M: #alien-callback emit-node
     params>> dup xt>> dup
-    [ init-phantoms %alien-callback ] with-cfg-builder
+    [ init-phantoms ##alien-callback ] with-cfg-builder
     iterate-next ;
 
 ! No-op nodes
diff --git a/unfinished/compiler/cfg/cfg.factor b/unfinished/compiler/cfg/cfg.factor
index 9acf0897b9..54b991bff1 100644
--- a/unfinished/compiler/cfg/cfg.factor
+++ b/unfinished/compiler/cfg/cfg.factor
@@ -11,16 +11,13 @@ C: <cfg> cfg
 TUPLE: basic-block < identity-tuple
 visited
 number
-label
 instructions
-successors
-predecessors ;
+successors ;
 
 : <basic-block> ( -- basic-block )
     basic-block new
         V{ } clone >>instructions
-        V{ } clone >>successors
-        V{ } clone >>predecessors ;
+        V{ } clone >>successors ;
 
 TUPLE: mr instructions word label ;
 
diff --git a/unfinished/compiler/cfg/debugger/debugger.factor b/unfinished/compiler/cfg/debugger/debugger.factor
index 65b0b97476..1da954c22e 100644
--- a/unfinished/compiler/cfg/debugger/debugger.factor
+++ b/unfinished/compiler/cfg/debugger/debugger.factor
@@ -9,11 +9,10 @@ IN: compiler.cfg.debugger
 GENERIC: test-cfg ( quot -- cfgs )
 
 M: callable test-cfg
-    build-tree optimize-tree gensym gensym build-cfg ;
+    build-tree optimize-tree gensym build-cfg ;
 
 M: word test-cfg
-    [ build-tree-from-word nip optimize-tree ] keep dup
-    build-cfg ;
+    [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
 
 : test-mr ( quot -- mrs ) test-cfg [ build-mr ] map ;
 
diff --git a/unfinished/compiler/cfg/instructions/instructions.factor b/unfinished/compiler/cfg/instructions/instructions.factor
index 5fd7608a4c..185dc1196a 100644
--- a/unfinished/compiler/cfg/instructions/instructions.factor
+++ b/unfinished/compiler/cfg/instructions/instructions.factor
@@ -6,103 +6,102 @@ IN: compiler.cfg.instructions
 
 ! Virtual CPU instructions, used by CFG and machine IRs
 
-TUPLE: %cond-branch < insn src ;
-TUPLE: %unary < insn dst src ;
-TUPLE: %nullary < insn dst ;
+TUPLE: ##cond-branch < insn src ;
+TUPLE: ##unary < insn dst src ;
+TUPLE: ##nullary < insn dst ;
 
 ! Stack operations
-INSN: %load-literal < %nullary obj ;
-INSN: %peek < %nullary loc ;
-INSN: %replace src loc ;
-INSN: %inc-d n ;
-INSN: %inc-r n ;
+INSN: ##load-literal < ##nullary obj ;
+INSN: ##peek < ##nullary loc ;
+INSN: ##replace src loc ;
+INSN: ##inc-d n ;
+INSN: ##inc-r n ;
 
 ! Calling convention
-INSN: %return ;
+INSN: ##return ;
 
 ! Subroutine calls
-INSN: %call word ;
-INSN: %jump word ;
-INSN: %intrinsic quot regs ;
+INSN: ##call word ;
+INSN: ##jump word ;
+INSN: ##intrinsic quot defs-vregs uses-vregs ;
 
 ! Jump tables
-INSN: %dispatch-label label ;
-INSN: %dispatch ;
+INSN: ##dispatch-label label ;
+INSN: ##dispatch ;
 
 ! Boxing and unboxing
-INSN: %copy < %unary ;
-INSN: %copy-float < %unary ;
-INSN: %unbox-float < %unary ;
-INSN: %unbox-f < %unary ;
-INSN: %unbox-alien < %unary ;
-INSN: %unbox-byte-array < %unary ;
-INSN: %unbox-any-c-ptr < %unary ;
-INSN: %box-float < %unary ;
-INSN: %box-alien < %unary ;
+INSN: ##copy < ##unary ;
+INSN: ##copy-float < ##unary ;
+INSN: ##unbox-float < ##unary ;
+INSN: ##unbox-f < ##unary ;
+INSN: ##unbox-alien < ##unary ;
+INSN: ##unbox-byte-array < ##unary ;
+INSN: ##unbox-any-c-ptr < ##unary ;
+INSN: ##box-float < ##unary ;
+INSN: ##box-alien < ##unary ;
 
-INSN: %gc ;
+INSN: ##gc ;
 
 ! FFI
-INSN: %alien-invoke params ;
-INSN: %alien-indirect params ;
-INSN: %alien-callback params ;
+INSN: ##alien-invoke params ;
+INSN: ##alien-indirect params ;
+INSN: ##alien-callback params ;
 
 GENERIC: defs-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
-M: %nullary defs-vregs dst>> >vreg 1array ;
-M: %unary defs-vregs dst>> >vreg 1array ;
+M: ##nullary defs-vregs dst>> >vreg 1array ;
+M: ##unary defs-vregs dst>> >vreg 1array ;
 M: insn defs-vregs drop f ;
 
-M: %replace uses-vregs src>> >vreg 1array ;
-M: %unary uses-vregs src>> >vreg 1array ;
+M: ##replace uses-vregs src>> >vreg 1array ;
+M: ##unary uses-vregs src>> >vreg 1array ;
 M: insn uses-vregs drop f ;
 
-! M: %intrinsic uses-vregs vregs>> values ;
+: intrinsic-vregs ( assoc -- seq' )
+    [ nip >vreg ] { } assoc>map sift ;
+
+: intrinsic-defs-vregs ( insn -- seq )
+    defs-vregs>> intrinsic-vregs ;
+
+: intrinsic-uses-vregs ( insn -- seq )
+    uses-vregs>> intrinsic-vregs ;
+
+M: ##intrinsic defs-vregs intrinsic-defs-vregs ;
+M: ##intrinsic uses-vregs intrinsic-uses-vregs ;
 
 ! Instructions used by CFG IR only.
-INSN: %prologue ;
-INSN: %epilogue ;
-INSN: %frame-required n ;
+INSN: ##prologue ;
+INSN: ##epilogue ;
+INSN: ##frame-required n ;
 
-INSN: %branch ;
-INSN: %branch-f < %cond-branch ;
-INSN: %branch-t < %cond-branch ;
-INSN: %if-intrinsic quot vregs ;
-INSN: %boolean-intrinsic quot vregs dst ;
+INSN: ##branch ;
+INSN: ##branch-f < ##cond-branch ;
+INSN: ##branch-t < ##cond-branch ;
+INSN: ##if-intrinsic quot defs-vregs uses-vregs ;
 
-M: %cond-branch uses-vregs src>> 1array ;
+M: ##cond-branch uses-vregs src>> >vreg 1array ;
 
-! M: %if-intrinsic uses-vregs vregs>> values ;
-
-M: %boolean-intrinsic defs-vregs dst>> 1array ;
-
-! M: %boolean-intrinsic uses-vregs
-!     [ vregs>> values ] [ out>> ] bi suffix ;
+M: ##if-intrinsic defs-vregs intrinsic-defs-vregs ;
+M: ##if-intrinsic uses-vregs intrinsic-uses-vregs ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue n ;
 INSN: _epilogue n ;
 
-TUPLE: label id ;
-
-INSN: _label label ;
-
-: <label> ( -- label ) \ <label> counter label boa ;
-: define-label ( name -- ) <label> swap set ;
-
-: resolve-label ( label/name -- )
-    dup label? [ get ] unless _label ;
+INSN: _label id ;
 
 TUPLE: _cond-branch < insn src label ;
 
 INSN: _branch label ;
 INSN: _branch-f < _cond-branch ;
 INSN: _branch-t < _cond-branch ;
-INSN: _if-intrinsic label quot vregs ;
+INSN: _if-intrinsic label quot defs-vregs uses-vregs ;
 
 M: _cond-branch uses-vregs src>> >vreg 1array ;
-! M: _if-intrinsic uses-vregs vregs>> values ;
+
+M: _if-intrinsic defs-vregs intrinsic-defs-vregs ;
+M: _if-intrinsic uses-vregs intrinsic-uses-vregs ;
 
 INSN: _spill src n ;
 INSN: _reload dst n ;
diff --git a/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor b/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor
index 00252e0c23..8f1378755d 100644
--- a/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/unfinished/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -3,6 +3,7 @@ USING: tools.test random sorting sequences sets hashtables assocs
 kernel fry arrays splitting namespaces math accessors vectors
 math.order
 compiler.cfg.registers
+compiler.cfg.linear-scan
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.debugger ;
 
@@ -98,3 +99,7 @@ SYMBOL: max-uses
 [ ] [ 10 4 2 60 random-test ] unit-test
 [ ] [ 10 20 2 400 random-test ] unit-test
 [ ] [ 10 20 4 300 random-test ] unit-test
+
+USING: math.private compiler.cfg.debugger ;
+
+[ ] [ [ float+ float>fixnum 3 fixnum*fast ] test-mr first linear-scan drop ] unit-test
diff --git a/unfinished/compiler/cfg/linear-scan/linear-scan.factor b/unfinished/compiler/cfg/linear-scan/linear-scan.factor
index cbbb33b6c9..80737badc3 100644
--- a/unfinished/compiler/cfg/linear-scan/linear-scan.factor
+++ b/unfinished/compiler/cfg/linear-scan/linear-scan.factor
@@ -8,9 +8,20 @@ compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.assignment ;
 IN: compiler.cfg.linear-scan
 
-! See http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
+! References:
+
+! Linear Scan Register Allocation
+! by Massimiliano Poletto and Vivek Sarkar
+! http://www.cs.ucla.edu/~palsberg/course/cs132/linearscan.pdf
+
+! Linear Scan Register Allocation for the Java HotSpot Client Compiler
+! by Christian Wimmer
 ! and http://www.ssw.uni-linz.ac.at/Research/Papers/Wimmer04Master/
 
+! Quality and Speed in Linear-scan Register Allocation
+! by Omri Traub, Glenn Holloway, Michael D. Smith
+! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
+
 : linear-scan ( mr -- mr' )
     [
         dup compute-live-intervals
diff --git a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
index d6ee979fe5..41b9895af2 100644
--- a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
+++ b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
@@ -28,7 +28,6 @@ SYMBOL: live-intervals
     at [ (>>end) ] [ uses>> push ] 2bi ;
 
 : new-live-interval ( n vreg live-intervals -- )
-    2dup key? [ "Multiple defs" throw ] when
     [ [ <live-interval> ] keep ] dip set-at ;
 
 : compute-live-intervals* ( insn n -- )
diff --git a/unfinished/compiler/cfg/linearization/linearization.factor b/unfinished/compiler/cfg/linearization/linearization.factor
index b1288fb301..fd21b5d3b6 100644
--- a/unfinished/compiler/cfg/linearization/linearization.factor
+++ b/unfinished/compiler/cfg/linearization/linearization.factor
@@ -12,7 +12,7 @@ IN: compiler.cfg.linearization
 SYMBOL: frame-size
 
 : compute-frame-size ( rpo -- )
-    [ instructions>> [ %frame-required? ] filter ] map concat
+    [ instructions>> [ ##frame-required? ] filter ] map concat
     [ f ] [ [ n>> ] map supremum ] if-empty
     frame-size set ;
 
@@ -23,12 +23,12 @@ GENERIC: linearize-insn ( basic-block insn -- )
 
 M: insn linearize-insn , drop ;
 
-M: %frame-required linearize-insn 2drop ;
+M: ##frame-required linearize-insn 2drop ;
 
-M: %prologue linearize-insn
+M: ##prologue linearize-insn
     2drop frame-size get [ _prologue ] when* ;
 
-M: %epilogue linearize-insn
+M: ##epilogue linearize-insn
     2drop frame-size get [ _epilogue ] when* ;
 
 : useless-branch? ( basic-block successor -- ? )
@@ -39,50 +39,40 @@ M: %epilogue linearize-insn
 : branch-to-return? ( successor -- ? )
     #! A branch to a block containing just a return is cloned.
     instructions>> dup length 2 = [
-        [ first %epilogue? ] [ second %return? ] bi and
+        [ first ##epilogue? ] [ second ##return? ] bi and
     ] [ drop f ] if ;
 
 : emit-branch ( basic-block successor -- )
     {
         { [ 2dup useless-branch? ] [ 2drop ] }
         { [ dup branch-to-return? ] [ nip linearize-insns ] }
-        [ nip label>> _branch ]
+        [ nip number>> _branch ]
     } cond ;
 
-M: %branch linearize-insn
+M: ##branch linearize-insn
     drop dup successors>> first emit-branch ;
 
 : conditional ( basic-block -- basic-block successor1 label2 )
-    dup successors>> first2 swap label>> ; inline
+    dup successors>> first2 swap number>> ; inline
 
 : boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
     [ conditional ] [ src>> ] bi* swap ; inline
 
-M: %branch-f linearize-insn
+M: ##branch-f linearize-insn
     boolean-conditional _branch-f emit-branch ;
 
-M: %branch-t linearize-insn
+M: ##branch-t linearize-insn
     boolean-conditional _branch-t emit-branch ;
 
-M: %if-intrinsic linearize-insn
-    [ conditional ] [ [ quot>> ] [ vregs>> ] bi ] bi*
+: >intrinsic< ( insn -- quot defs uses )
+    [ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
+
+M: ##if-intrinsic linearize-insn
+    [ conditional ] [ >intrinsic< ] bi*
     _if-intrinsic emit-branch ;
 
-M: %boolean-intrinsic linearize-insn
-    [
-        "false" define-label
-        "end" define-label
-        "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
-        dup dst>> t %load-literal
-        "end" get _branch
-        "false" resolve-label
-        dup dst>> f %load-literal
-        "end" resolve-label
-    ] with-scope
-    2drop ;
-
 : linearize-basic-block ( bb -- )
-    [ label>> _label ] [ linearize-insns ] bi ;
+    [ number>> _label ] [ linearize-insns ] bi ;
 
 : linearize-basic-blocks ( rpo -- insns )
     [ [ linearize-basic-block ] each ] { } make ;
diff --git a/unfinished/compiler/cfg/registers/registers.factor b/unfinished/compiler/cfg/registers/registers.factor
index 5eaed92072..ebc8382f0f 100644
--- a/unfinished/compiler/cfg/registers/registers.factor
+++ b/unfinished/compiler/cfg/registers/registers.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces math kernel ;
+USING: accessors namespaces math kernel alien classes ;
 IN: compiler.cfg.registers
 
 ! Virtual CPU registers, used by CFG and machine IRs
@@ -8,8 +8,14 @@ IN: compiler.cfg.registers
 MIXIN: value
 
 GENERIC: >vreg ( obj -- vreg )
+GENERIC: set-value-class ( class obj -- )
+GENERIC: value-class* ( operand -- class )
+
+: value-class ( operand -- class ) value-class* object or ;
 
 M: value >vreg drop f ;
+M: value set-value-class 2drop ;
+M: value value-class* drop f ;
 
 ! Register classes
 SINGLETON: int-regs
@@ -47,6 +53,8 @@ INSTANCE: loc value
 TUPLE: cached loc vreg ;
 C: <cached> cached
 
+M: cached set-value-class vreg>> set-value-class ;
+M: cached value-class* vreg>> value-class* ;
 M: cached >vreg vreg>> >vreg ;
 
 INSTANCE: cached value
@@ -55,6 +63,8 @@ INSTANCE: cached value
 TUPLE: tagged vreg class ;
 : <tagged> ( vreg -- tagged ) f tagged boa ;
 
+M: tagged set-value-class (>>class) ;
+M: tagged value-class* class>> ;
 M: tagged >vreg vreg>> ;
 
 INSTANCE: tagged value
@@ -71,20 +81,30 @@ INSTANCE: unboxed value
 TUPLE: unboxed-alien < unboxed ;
 C: <unboxed-alien> unboxed-alien
 
+M: unboxed-alien value-class* drop simple-alien ;
+
 ! Untagged byte array pointer
 TUPLE: unboxed-byte-array < unboxed ;
 C: <unboxed-byte-array> unboxed-byte-array
 
+M: unboxed-byte-array value-class* drop c-ptr ;
+
 ! A register set to f
 TUPLE: unboxed-f < unboxed ;
 C: <unboxed-f> unboxed-f
 
+M: unboxed-f value-class* drop \ f ;
+
 ! An alien, byte array or f
 TUPLE: unboxed-c-ptr < unboxed ;
 C: <unboxed-c-ptr> unboxed-c-ptr
 
+M: unboxed-c-ptr value-class* drop c-ptr ;
+
 ! A constant value
 TUPLE: constant value ;
 C: <constant> constant
 
+M: constant value-class* value>> class ;
+
 INSTANCE: constant value
diff --git a/unfinished/compiler/cfg/rpo/rpo.factor b/unfinished/compiler/cfg/rpo/rpo.factor
index 658bd5a29b..9fe6d3c90a 100644
--- a/unfinished/compiler/cfg/rpo/rpo.factor
+++ b/unfinished/compiler/cfg/rpo/rpo.factor
@@ -7,7 +7,6 @@ IN: compiler.cfg.rpo
 : post-order-traversal ( basic-block -- )
     dup visited>> [ drop ] [
         t >>visited
-        <label> >>label
         [ successors>> [ post-order-traversal ] each ] [ , ] bi
     ] if ;
 
diff --git a/unfinished/compiler/cfg/stacks/stacks.factor b/unfinished/compiler/cfg/stacks/stacks.factor
index 3cff5da37e..811ec5842f 100755
--- a/unfinished/compiler/cfg/stacks/stacks.factor
+++ b/unfinished/compiler/cfg/stacks/stacks.factor
@@ -18,8 +18,6 @@ FROM: compiler.generator.registers => +clobber+ ;
 SYMBOL: known-tag
 
 ! Value protocol
-GENERIC: set-operand-class ( class obj -- )
-GENERIC: operand-class* ( operand -- class )
 GENERIC: move-spec ( obj -- spec )
 GENERIC: live-loc? ( actual current -- ? )
 GENERIC# (lazy-load) 1 ( value spec -- value )
@@ -32,23 +30,19 @@ DEFER: %move
 
 PRIVATE>
 
-: operand-class ( operand -- class )
-    operand-class* object or ;
-
 ! Default implementation
-M: value set-operand-class 2drop ;
-M: value operand-class* drop f ;
 M: value live-loc? 2drop f ;
 M: value minimal-ds-loc* drop ;
 M: value lazy-store 2drop ;
 
 M: vreg move-spec reg-class>> move-spec ;
+M: vreg value-class* reg-class>> value-class* ;
 
 M: int-regs move-spec drop f ;
-M: int-regs operand-class* drop object ;
+M: int-regs value-class* drop object ;
 
 M: float-regs move-spec drop float ;
-M: float-regs operand-class* drop float ;
+M: float-regs value-class* drop float ;
 
 M: ds-loc minimal-ds-loc* n>> min ;
 M: ds-loc live-loc?
@@ -57,15 +51,13 @@ M: ds-loc live-loc?
 M: rs-loc live-loc?
     over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
 
-M: loc operand-class* class>> ;
-M: loc set-operand-class (>>class) ;
+M: loc value-class* class>> ;
+M: loc set-value-class (>>class) ;
 M: loc move-spec drop loc ;
 
 M: f move-spec drop loc ;
-M: f operand-class* ;
+M: f value-class* ;
 
-M: cached set-operand-class vreg>> set-operand-class ;
-M: cached operand-class* vreg>> operand-class* ;
 M: cached move-spec drop cached ;
 M: cached live-loc? loc>> live-loc? ;
 M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
@@ -75,41 +67,34 @@ M: cached lazy-store
     [ "live-locs" get at %move ] [ 2drop ] if ;
 M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
 
-M: tagged set-operand-class (>>class) ;
-M: tagged operand-class* class>> ;
 M: tagged move-spec drop f ;
 
-M: unboxed-alien operand-class* drop simple-alien ;
 M: unboxed-alien move-spec class ;
 
-M: unboxed-byte-array operand-class* drop c-ptr ;
 M: unboxed-byte-array move-spec class ;
 
-M: unboxed-f operand-class* drop \ f ;
 M: unboxed-f move-spec class ;
 
-M: unboxed-c-ptr operand-class* drop c-ptr ;
 M: unboxed-c-ptr move-spec class ;
 
-M: constant operand-class* value>> class ;
 M: constant move-spec class ;
 
 ! Moving values between locations and registers
 : %move-bug ( -- * ) "Bug in generator.registers" throw ;
 
 : %unbox-c-ptr ( dst src -- )
-    dup operand-class {
-        { [ dup \ f class<= ] [ drop %unbox-f ] }
-        { [ dup simple-alien class<= ] [ drop %unbox-alien ] }
-        { [ dup byte-array class<= ] [ drop %unbox-byte-array ] }
-        [ drop %unbox-any-c-ptr ]
+    dup value-class {
+        { [ dup \ f class<= ] [ drop ##unbox-f ] }
+        { [ dup simple-alien class<= ] [ drop ##unbox-alien ] }
+        { [ dup byte-array class<= ] [ drop ##unbox-byte-array ] }
+        [ drop ##unbox-any-c-ptr ]
     } cond ; inline
 
 : %move-via-temp ( dst src -- )
     #! For many transfers, such as loc to unboxed-alien, we
     #! don't have an intrinsic, so we transfer the source to
     #! temp then temp to the destination.
-    int-regs next-vreg [ over %move operand-class ] keep
+    int-regs next-vreg [ over %move value-class ] keep
     tagged new
         swap >>vreg
         swap >>class
@@ -117,28 +102,28 @@ M: constant move-spec class ;
 
 : %move ( dst src -- )
     2dup [ move-spec ] bi@ 2array {
-        { { f f } [ %copy ] }
-        { { unboxed-alien unboxed-alien } [ %copy ] }
-        { { unboxed-byte-array unboxed-byte-array } [ %copy ] }
-        { { unboxed-f unboxed-f } [ %copy ] }
-        { { unboxed-c-ptr unboxed-c-ptr } [ %copy ] }
-        { { float float } [ %copy-float ] }
+        { { f f } [ ##copy ] }
+        { { unboxed-alien unboxed-alien } [ ##copy ] }
+        { { unboxed-byte-array unboxed-byte-array } [ ##copy ] }
+        { { unboxed-f unboxed-f } [ ##copy ] }
+        { { unboxed-c-ptr unboxed-c-ptr } [ ##copy ] }
+        { { float float } [ ##copy-float ] }
 
         { { f unboxed-c-ptr } [ %move-bug ] }
         { { f unboxed-byte-array } [ %move-bug ] }
 
-        { { f constant } [ value>> %load-literal ] }
+        { { f constant } [ value>> ##load-literal ] }
 
-        { { f float } [ %box-float ] }
-        { { f unboxed-alien } [ %box-alien ] }
-        { { f loc } [ %peek ] }
+        { { f float } [ ##box-float ] }
+        { { f unboxed-alien } [ ##box-alien ] }
+        { { f loc } [ ##peek ] }
 
-        { { float f } [ %unbox-float ] }
-        { { unboxed-alien f } [ %unbox-alien ] }
-        { { unboxed-byte-array f } [ %unbox-byte-array ] }
-        { { unboxed-f f } [ %unbox-f ] }
+        { { float f } [ ##unbox-float ] }
+        { { unboxed-alien f } [ ##unbox-alien ] }
+        { { unboxed-byte-array f } [ ##unbox-byte-array ] }
+        { { unboxed-f f } [ ##unbox-f ] }
         { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
-        { { loc f } [ swap %replace ] }
+        { { loc f } [ swap ##replace ] }
 
         [ drop %move-via-temp ]
     } case ;
@@ -174,7 +159,7 @@ TUPLE: phantom-datastack < phantom-stack ;
 M: phantom-datastack <loc> (loc) <ds-loc> ;
 
 M: phantom-datastack finalize-height
-    \ %inc-d (finalize-height) ;
+    \ ##inc-d (finalize-height) ;
 
 TUPLE: phantom-retainstack < phantom-stack ;
 
@@ -184,7 +169,7 @@ TUPLE: phantom-retainstack < phantom-stack ;
 M: phantom-retainstack <loc> (loc) <rs-loc> ;
 
 M: phantom-retainstack finalize-height
-    \ %inc-r (finalize-height) ;
+    \ ##inc-r (finalize-height) ;
 
 : phantom-locs ( n phantom -- locs )
     #! A sequence of n ds-locs or rs-locs indexing the stack.
@@ -265,7 +250,7 @@ SYMBOL: fresh-objects
     } cond 2nip ;
 
 : alloc-vreg-for ( value spec -- vreg )
-    alloc-vreg swap operand-class
+    alloc-vreg swap value-class
     over tagged? [ >>class ] [ drop ] if ;
 
 M: value (lazy-load)
@@ -301,7 +286,7 @@ M: loc lazy-store
     dup phantom-locs*
     over stack>> [
         dup constant? [ nip ] [
-            operand-class over set-operand-class
+            value-class over set-value-class
         ] if
     ] 2map
     over stack>> delete-all
@@ -330,10 +315,10 @@ M: loc lazy-store
 : clear-phantoms ( -- )
     [ stack>> delete-all ] each-phantom ;
 
-: set-operand-classes ( classes -- )
+: set-value-classes ( classes -- )
     phantom-datastack get
     over length over add-locs
-    stack>> [ set-operand-class ] 2reverse-each ;
+    stack>> [ set-value-class ] 2reverse-each ;
 
 : finalize-phantoms ( -- )
     #! Commit all deferred stacking shuffling, and ensure the
@@ -342,7 +327,7 @@ M: loc lazy-store
     finalize-contents
     clear-phantoms
     finalize-heights
-    fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
+    fresh-objects get [ empty? [ ##gc ] unless ] [ delete-all ] bi ;
 
 : fresh-object ( obj -- ) fresh-objects get push ;
 
@@ -358,14 +343,6 @@ M: loc lazy-store
     phantom-datastack [ clone ] change
     phantom-retainstack [ clone ] change ;
 
-: operand-tag ( operand -- tag/f )
-    operand-class dup [ class-tag ] when ;
-
-UNION: immediate fixnum POSTPONE: f ;
-
-: operand-immediate? ( operand -- ? )
-    operand-class immediate class<= ;
-
 : phantom-push ( obj -- )
     1 phantom-datastack get adjust-phantom
     phantom-datastack get stack>> push ;
diff --git a/unfinished/compiler/cfg/templates/templates.factor b/unfinished/compiler/cfg/templates/templates.factor
index 1be714afa5..a99102a9bb 100644
--- a/unfinished/compiler/cfg/templates/templates.factor
+++ b/unfinished/compiler/cfg/templates/templates.factor
@@ -5,16 +5,7 @@ quotations combinators classes.algebra compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.stacks ;
 IN: compiler.cfg.templates
 
-USE: qualified
-FROM: compiler.generator.registers => +input+   ;
-FROM: compiler.generator.registers => +output+  ;
-FROM: compiler.generator.registers => +scratch+ ;
-FROM: compiler.generator.registers => +clobber+ ;
-
-: template-input +input+ swap at ; inline
-: template-output +output+ swap at ; inline
-: template-scratch +scratch+ swap at ; inline
-: template-clobber +clobber+ swap at ; inline
+TUPLE: template input output scratch clobber gc ;
 
 : phantom&spec ( phantom specs -- phantom' specs' )
     >r stack>> r>
@@ -28,7 +19,7 @@ FROM: compiler.generator.registers => +clobber+ ;
     [ stack>> [ >vreg ] map sift ] each-phantom append ;
 
 : clobbered ( template -- seq )
-    [ template-output ] [ template-clobber ] bi append ;
+    [ output>> ] [ clobber>> ] bi append ;
 
 : clobbered? ( value name -- ? )
     \ clobbered get member? [
@@ -49,25 +40,25 @@ FROM: compiler.generator.registers => +clobber+ ;
     [
         live-vregs \ live-vregs set
         dup clobbered \ clobbered set
-        template-input [ values ] [ lazy-load ] bi zip
+        input>> [ values ] [ lazy-load ] bi zip
     ] with-scope ;
 
 : alloc-scratch ( template -- assoc )
-    template-scratch [ swap alloc-vreg ] assoc-map ;
+    scratch>> [ swap alloc-vreg ] assoc-map ;
 
-: do-template-inputs ( template -- inputs )
+: do-template-inputs ( template -- defs uses )
     #! Load input values into registers and allocates scratch
     #! registers.
-    [ load-inputs ] [ alloc-scratch ] bi assoc-union ;
+    [ alloc-scratch ] [ load-inputs ] bi ;
 
-: do-template-outputs ( template inputs -- )
-    [ template-output ] dip '[ _ at ] map
+: do-template-outputs ( template defs uses -- )
+    [ output>> ] 2dip assoc-union '[ _ at ] map
     phantom-datastack get phantom-append ;
 
 : apply-template ( pair quot -- vregs )
     [
         first2 dup do-template-inputs
-        [ do-template-outputs ] keep
+        [ do-template-outputs ] 2keep
     ] dip call ; inline
 
 : value-matches? ( value spec -- ? )
@@ -92,10 +83,10 @@ FROM: compiler.generator.registers => +clobber+ ;
 
 : spec-matches? ( value spec -- ? )
     2dup first value-matches?
-    >r >r operand-class 2 r> ?nth class-matches? r> and ;
+    >r >r value-class 2 r> ?nth class-matches? r> and ;
 
 : template-matches? ( template -- ? )
-    template-input phantom-datastack get swap
+    input>> phantom-datastack get swap
     [ spec-matches? ] phantom&spec-agree? ;
 
 : find-template ( templates -- pair/f )
diff --git a/unfinished/compiler/backend/alien/alien.factor b/unfinished/compiler/codegen/codegen.factor
similarity index 58%
rename from unfinished/compiler/backend/alien/alien.factor
rename to unfinished/compiler/codegen/codegen.factor
index 0c5a6afb75..ce2aa93fe6 100644
--- a/unfinished/compiler/backend/alien/alien.factor
+++ b/unfinished/compiler/codegen/codegen.factor
@@ -1,16 +1,128 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.backend.alien
+USING: namespaces make math math.parser sequences accessors
+kernel kernel.private layouts assocs words summary arrays
+threads continuations.private libc combinators
+alien alien.c-types alien.structs alien.strings
+compiler.errors
+compiler.alien
+compiler.backend
+compiler.codegen.fixup
+compiler.cfg
+compiler.cfg.instructions
+compiler.cfg.registers ;
+IN: compiler.codegen
+
+GENERIC: generate-insn ( insn -- )
+
+: generate-insns ( insns -- code )
+    [
+        [
+            dup regs>> registers set
+            generate-insn
+        ] each
+    ] { } make fixup ;
+
+TUPLE: asm label code calls ;
+
+SYMBOL: calls
+
+: add-call ( word -- )
+    #! Compile this word later.
+    calls get push ;
+
+SYMBOL: compiling-word
+
+: compiled-stack-traces? ( -- ? ) 59 getenv ;
+
+! Mapping _label IDs to label instances
+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 f ? add-literal drop ;
+
+: generate ( mr -- asm )
+    [
+        [ label>> ]
+        [ word>> init-generator ]
+        [ instructions>> generate-insns ] tri
+        calls get
+        asm boa
+    ] with-scope ;
+
+: lookup-label ( id -- label )
+    labels get [ drop <label> ] cache ;
+
+M: _label generate-insn
+    id>> lookup-label , ;
+
+M: _prologue generate-insn
+    n>> %prologue ;
+
+M: _epilogue generate-insn
+    n>> %epilogue ;
+
+M: ##load-literal generate-insn [ obj>> ] [ dst>> ] bi load-literal ;
+
+M: ##peek generate-insn [ dst>> ] [ loc>> ] bi %peek ;
+
+M: ##replace generate-insn [ src>> ] [ loc>> ] bi %replace ;
+
+M: ##inc-d generate-insn n>> %inc-d ;
+
+M: ##inc-r generate-insn n>> %inc-r ;
+
+M: ##return generate-insn drop %return ;
+
+M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
+
+M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
+
+M: ##intrinsic generate-insn
+    [ init-intrinsic ] [ quot>> call ] bi ;
+
+M: _if-intrinsic generate-insn
+    [ init-intrinsic ]
+    [ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
+
+M: _branch generate-insn
+    label>> lookup-label %jump-label ;
+
+M: _branch-f generate-insn
+    [ src>> ] [ label>> lookup-label ] bi %jump-f ;
+
+M: _branch-t generate-insn
+    [ src>> ] [ label>> lookup-label ] bi %jump-t ;
+
+M: ##dispatch-label generate-insn label>> %dispatch-label ;
+
+M: ##dispatch generate-insn drop %dispatch ;
+
+M: ##copy generate-insn %copy ;
+
+M: ##copy-float generate-insn %copy-float ;
+
+M: ##unbox-float generate-insn [ dst>> ] [ src>> ] bi %unbox-float ;
+
+M: ##unbox-f generate-insn [ dst>> ] [ src>> ] bi %unbox-f ;
+
+M: ##unbox-alien generate-insn [ dst>> ] [ src>> ] bi %unbox-alien ;
+
+M: ##unbox-byte-array generate-insn [ dst>> ] [ src>> ] bi %unbox-byte-array ;
+
+M: ##unbox-any-c-ptr generate-insn [ dst>> ] [ src>> ] bi %unbox-any-c-ptr ;
+
+M: ##box-float generate-insn [ dst>> ] [ src>> ] bi %box-float ;
+
+M: ##box-alien generate-insn [ dst>> ] [ src>> ] bi %box-alien ;
+
+M: ##gc generate-insn drop %gc ;
 
 ! #alien-invoke
-: set-stack-frame ( n -- )
-    dup [ frame-required ] when* \ stack-frame set ;
-
-: with-stack-frame ( n quot -- )
-    swap set-stack-frame
-    call
-    f set-stack-frame ; inline
-
 GENERIC: reg-size ( register-class -- n )
 
 M: int-regs reg-size drop cell ;
@@ -55,17 +167,17 @@ M: object reg-class-full?
     [ spill-param ] [ fastcall-param ] if
     [ param-reg ] keep ;
 
-: (flatten-int-type) ( size -- )
-    cell /i "void*" c-type <repetition> % ;
+: (flatten-int-type) ( size -- seq )
+    cell /i "void*" c-type <repetition> ;
 
-GENERIC: flatten-value-type ( type -- )
+GENERIC: flatten-value-type ( type -- types )
 
-M: object flatten-value-type , ;
+M: object flatten-value-type 1array ;
 
-M: struct-type flatten-value-type ( type -- )
+M: struct-type flatten-value-type ( type -- types )
     stack-size cell align (flatten-int-type) ;
 
-M: long-long-type flatten-value-type ( type -- )
+M: long-long-type flatten-value-type ( type -- types )
     stack-size cell align (flatten-int-type) ;
 
 : flatten-value-types ( params -- params )
@@ -73,9 +185,9 @@ M: long-long-type flatten-value-type ( type -- )
     [
         0 [
             c-type
-            [ parameter-align (flatten-int-type) ] keep
+            [ parameter-align (flatten-int-type) % ] keep
             [ stack-size cell align + ] keep
-            flatten-value-type
+            flatten-value-type %
         ] reduce drop
     ] { } make ;
 
@@ -170,39 +282,36 @@ M: no-such-symbol compiler-error-type
     swap library>> library dup [ dll>> ] when
     2dup check-dlsym ;
 
-M: #alien-invoke generate-node
+M: ##alien-invoke generate-insn
     params>>
-    dup alien-invoke-frame [
-        end-basic-block
-        %prepare-alien-invoke
-        dup objects>registers
-        %prepare-var-args
-        dup alien-invoke-dlsym %alien-invoke
-        dup %cleanup
-        box-return*
-        iterate-next
-    ] with-stack-frame ;
+    ! Save registers for GC
+    %prepare-alien-invoke
+    ! Unbox parameters
+    dup objects>registers
+    %prepare-var-args
+    ! Call function
+    dup alien-invoke-dlsym %alien-invoke
+    ! Box return value
+    dup %cleanup
+    box-return* ;
 
-! #alien-indirect
-M: #alien-indirect generate-node
+! ##alien-indirect
+M: ##alien-indirect generate-insn
     params>>
-    dup alien-invoke-frame [
-        ! Flush registers
-        end-basic-block
-        ! Save registers for GC
-        %prepare-alien-invoke
-        ! Save alien at top of stack to temporary storage
-        %prepare-alien-indirect
-        dup objects>registers
-        %prepare-var-args
-        ! Call alien in temporary storage
-        %alien-indirect
-        dup %cleanup
-        box-return*
-        iterate-next
-    ] with-stack-frame ;
+    ! Save registers for GC
+    %prepare-alien-invoke
+    ! Save alien at top of stack to temporary storage
+    %prepare-alien-indirect
+    ! Unbox parameters
+    dup objects>registers
+    %prepare-var-args
+    ! Call alien in temporary storage
+    %alien-indirect
+    ! Box return value
+    dup %cleanup
+    box-return* ;
 
-! #alien-callback
+! ##alien-callback
 : box-parameters ( params -- )
     alien-parameters [ box-parameter ] each-parameter ;
 
@@ -264,18 +373,9 @@ TUPLE: callback-context ;
     [ %unnest-stacks ] [ %callback-value ] if-void
     callback-unwind %unwind ;
 
-: generate-callback ( params -- )
-    dup xt>> dup [
-        init-templates
-        %prologue
-        dup alien-stack-frame [
-            [ registers>objects ]
-            [ wrap-callback-quot %alien-callback ]
-            [ %callback-return ]
-            tri
-        ] with-stack-frame
-    ] with-cfg-builder ;
-
-M: #alien-callback generate-node
-    end-basic-block
-    params>> generate-callback iterate-next ;
+M: ##alien-callback generate-insn
+    params>>
+    [ registers>objects ]
+    [ wrap-callback-quot %alien-callback ]
+    [ %callback-return ]
+    tri ;
diff --git a/unfinished/compiler/codegen/fixup/fixup.factor b/unfinished/compiler/codegen/fixup/fixup.factor
index 1f1cf81cb9..5e8c1809a5 100755
--- a/unfinished/compiler/codegen/fixup/fixup.factor
+++ b/unfinished/compiler/codegen/fixup/fixup.factor
@@ -3,76 +3,20 @@
 USING: arrays byte-arrays generic assocs hashtables io.binary
 kernel kernel.private math namespaces make sequences words
 quotations strings alien.accessors alien.strings layouts system
-combinators math.bitwise words.private cpu.architecture
-math.order accessors growable ;
-IN: compiler.cfg.fixup
+combinators math.bitwise words.private math.order accessors
+growable compiler.constants compiler.backend ;
+IN: compiler.codegen.fixup
 
-: no-stack-frame -1 ; inline
-
-TUPLE: frame-required n ;
-
-: frame-required ( n -- ) \ frame-required boa , ;
-
-: stack-frame-size ( code -- n )
-    no-stack-frame [
-        dup frame-required? [ n>> max ] [ drop ] if
-    ] reduce ;
-
-GENERIC: fixup* ( frame-size obj -- frame-size )
+GENERIC: fixup* ( obj -- )
 
 : code-format 22 getenv ;
 
 : compiled-offset ( -- n ) building get length code-format * ;
 
-TUPLE: label offset ;
-
-: <label> ( -- label ) label new ;
-
-M: label fixup*
-    compiled-offset >>offset drop ;
-
-: define-label ( name -- ) <label> swap set ;
-
-: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
-
-: if-stack-frame ( frame-size quot -- )
-    swap dup no-stack-frame =
-    [ 2drop ] [ stack-frame swap call ] if ; inline
-
-M: word fixup*
-    {
-        { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
-        { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
-    } case ;
-
 SYMBOL: relocation-table
 SYMBOL: label-table
 
-! Relocation classes
-: rc-absolute-cell     0 ;
-: rc-absolute          1 ;
-: rc-relative          2 ;
-: rc-absolute-ppc-2/2  3 ;
-: rc-relative-ppc-2    4 ;
-: rc-relative-ppc-3    5 ;
-: rc-relative-arm-3    6 ;
-: rc-indirect-arm      7 ;
-: rc-indirect-arm-pc   8 ;
-
-: rc-absolute? ( n -- ? )
-    dup rc-absolute-cell =
-    over rc-absolute =
-    rot rc-absolute-ppc-2/2 = or or ;
-
-! Relocation types
-: rt-primitive 0 ;
-: rt-dlsym     1 ;
-: rt-literal   2 ;
-: rt-dispatch  3 ;
-: rt-xt        4 ;
-: rt-here      5 ;
-: rt-label     6 ;
-: rt-immediate 7 ;
+M: label fixup* compiled-offset >>offset drop ;
 
 TUPLE: label-fixup label class ;
 
@@ -81,7 +25,7 @@ TUPLE: label-fixup label class ;
 M: label-fixup fixup*
     dup class>> rc-absolute?
     [ "Absolute labels not supported" throw ] when
-    dup label>> swap class>> compiled-offset 4 - rot
+    [ label>> ] [ class>> ] bi compiled-offset 4 - rot
     3array label-table get push ;
 
 TUPLE: rel-fixup arg class type ;
@@ -97,8 +41,6 @@ M: rel-fixup fixup*
     [ class>> rc-absolute-cell = cell 4 ? compiled-offset swap - ] bi
     [ relocation-table get push-4 ] bi@ ;
 
-M: frame-required fixup* drop ;
-
 M: integer fixup* , ;
 
 : adjoin* ( obj table -- n )
@@ -143,12 +85,11 @@ SYMBOL: literal-table
         3array
     ] map concat ;
 
-: fixup ( code -- literals relocation labels code )
+: fixup ( fixup-directives -- code )
     [
         init-fixup
-        dup stack-frame-size swap [ fixup* ] each drop
-
+        [ fixup* ] each
         literal-table get >array
         relocation-table get >byte-array
         label-table get resolve-labels
-    ] { } make ;
+    ] { } make 4array ;
diff --git a/unfinished/compiler/new/new.factor b/unfinished/compiler/new/new.factor
new file mode 100644
index 0000000000..9b640b8d84
--- /dev/null
+++ b/unfinished/compiler/new/new.factor
@@ -0,0 +1,116 @@
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces arrays sequences io debugger
+words fry continuations vocabs assocs dlists definitions math
+threads graphs generic combinators deques search-deques
+stack-checker stack-checker.state stack-checker.inlining
+compiler.errors compiler.units compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder
+compiler.cfg.linearization compiler.cfg.linear-scan
+compiler.codegen ;
+IN: compiler.new
+
+SYMBOL: compile-queue
+SYMBOL: compiled
+
+: queue-compile ( word -- )
+    {
+        { [ dup "forgotten" word-prop ] [ ] }
+        { [ dup compiled get key? ] [ ] }
+        { [ dup inlined-block? ] [ ] }
+        { [ dup primitive? ] [ ] }
+        [ dup compile-queue get push-front ]
+    } cond drop ;
+
+: maybe-compile ( word -- )
+    dup compiled>> [ drop ] [ queue-compile ] if ;
+
+SYMBOL: +failed+
+
+: ripple-up ( words -- )
+    dup "compiled-effect" word-prop +failed+ eq?
+    [ usage [ word? ] filter ] [ compiled-usage keys ] if
+    [ queue-compile ] each ;
+
+: ripple-up? ( word effect -- ? )
+    #! If the word has previously been compiled and had a
+    #! different stack effect, we have to recompile any callers.
+    swap "compiled-effect" word-prop [ = not ] keep and ;
+
+: save-effect ( word effect -- )
+    [ dupd ripple-up? [ ripple-up ] [ drop ] if ]
+    [ "compiled-effect" set-word-prop ]
+    2bi ;
+
+: start ( word -- )
+    H{ } clone dependencies set
+    H{ } clone generic-dependencies set
+    f swap compiler-error ;
+
+: fail ( word error -- )
+    [ swap compiler-error ]
+    [
+        drop
+        [ compiled-unxref ]
+        [ f swap compiled get set-at ]
+        [ +failed+ save-effect ]
+        tri
+    ] 2bi
+    return ;
+
+: frontend ( word -- effect nodes )
+    [ build-tree-from-word ] [ fail ] recover optimize-tree ;
+
+: finish ( effect word -- )
+    [ swap save-effect ]
+    [ compiled-unxref ]
+    [
+        dup crossref?
+        [
+            dependencies get >alist
+            generic-dependencies get >alist
+            compiled-xref
+        ] [ drop ] if
+    ] tri ;
+
+: save-asm ( asm -- )
+    [ [ code>> ] [ label>> ] bi compiled get set-at ]
+    [ calls>> [ queue-compile ] each ]
+    bi ;
+
+: backend ( nodes word -- )
+    build-cfg [ build-mr linear-scan generate save-asm ] each ;
+
+: (compile) ( word -- )
+    '[
+        _ {
+            [ start ]
+            [ frontend ]
+            [ backend ]
+            [ finish ]
+        } cleave
+    ] with-return ;
+
+: compile-loop ( deque -- )
+    [ (compile) yield ] slurp-deque ;
+
+: decompile ( word -- )
+    f 2array 1array t modify-code-heap ;
+
+: optimized-recompile-hook ( words -- alist )
+    [
+        <hashed-dlist> compile-queue set
+        H{ } clone compiled set
+        [ queue-compile ] each
+        compile-queue get compile-loop
+        compiled get >alist
+    ] with-scope ;
+
+: enable-compiler ( -- )
+    [ optimized-recompile-hook ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+    [ default-recompile-hook ] recompile-hook set-global ;
+
+: recompile-all ( -- )
+    forget-errors all-words compile ;