Reworking inline allocation codegen

unfinished/compiler/backend/backend.factor

@@ -2,8 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 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
+classes alien byte-arrays combinators words ;
-compiler.cfg.registers compiler.cfg.instructions ;
 IN: compiler.backend
 
 ! Labels
@@ -30,7 +29,7 @@ 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 -- )
+GENERIC# load-literal 1 ( obj reg -- )
 
 HOOK: load-indirect cpu ( obj reg -- )
 
@@ -52,10 +51,10 @@ HOOK: %call cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 
 ! Test if vreg is 'f' or not
-HOOK: %jump-f cpu ( label vreg -- )
+HOOK: %jump-f cpu ( label reg -- )
 
 ! Test if vreg is 't' or not
-HOOK: %jump-t cpu ( label vreg -- )
+HOOK: %jump-t cpu ( label reg -- )
 
 HOOK: %dispatch cpu ( -- )
 
@@ -71,10 +70,10 @@ HOOK: %inc-d cpu ( n -- )
 HOOK: %inc-r cpu ( n -- )
 
 ! Load stack into vreg
-HOOK: %peek cpu ( vreg loc -- )
+HOOK: %peek cpu ( reg loc -- )
 
 ! Store vreg to stack
-HOOK: %replace cpu ( vreg loc -- )
+HOOK: %replace cpu ( reg loc -- )
 
 ! Copy values between vregs
 HOOK: %copy cpu ( dst src -- )
@@ -148,21 +147,11 @@ M: stack-params param-reg drop ;
 
 M: stack-params param-regs drop f ;
 
-GENERIC: v>operand ( obj -- operand )
+M: object load-literal load-indirect ;
-
-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? ;
+PREDICATE: small-tagged < integer tag-fixnum small-enough? ;
 
 : if-small-struct ( n size true false -- ? )
     [ over not over struct-small-enough? and ] 2dip
@@ -194,30 +183,10 @@ HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 
 HOOK: %box-alien cpu ( dst src -- )
 
+! Allocation
+HOOK: %allot cpu ( dst size type tag temp -- )
+
+HOOK: %write-barrier cpu ( src temp -- )
+
 ! 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

unfinished/compiler/backend/x86/sse2/sse2.factor

@@ -2,27 +2,24 @@
 ! 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
+words math.floats.private layouts quotations locals cpu.x86
-compiler.cfg.templates compiler.cfg.builder compiler.cfg.registers
+compiler.codegen compiler.cfg.templates compiler.cfg.builder
-compiler.constants compiler.backend compiler.backend.x86 ;
+compiler.cfg.registers compiler.constants compiler.backend
+compiler.backend.x86 ;
 IN: compiler.backend.x86.sse2
 
-M: x86 %box-float ( dst src -- )
+M:: x86 %box-float ( dst src temp -- )
     #! Only called by pentium4 backend, uses SSE2 instruction
-    #! dest is a loc or a vreg
+    dst 16 float float temp %allot
-    float 16 [
+    dst 8 float tag-number - [+] src MOVSD ;
-        8 (object@) swap v>operand MOVSD
-        float %store-tagged
-    ] %allot ;
 
 M: x86 %unbox-float ( dst src -- )
-    [ v>operand ] bi@ float-offset [+] MOVSD ;
+    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 ;
 
 {
@@ -65,7 +62,6 @@ M: x86 %unbox-float ( dst src -- )
     { scratch { { float "out" } } }
     { output { "out" } }
     { clobber { "in" } }
-    { gc t }
 } define-intrinsic
 
 : alien-float-get-template

unfinished/compiler/backend/x86/x86.factor

@@ -4,20 +4,12 @@ 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
+cpu.x86.private locals compiler.backend compiler.codegen.fixup
 compiler.constants compiler.intrinsics compiler.cfg.builder
 compiler.cfg.registers compiler.cfg.stacks
-compiler.cfg.templates ;
+compiler.cfg.templates compiler.codegen ;
 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 )
@@ -27,8 +19,10 @@ HOOK: stack-save-reg cpu ( -- reg )
 
 : reg-stack ( n reg -- op ) swap cells neg [+] ;
 
-M: ds-loc v>operand n>> ds-reg reg-stack ;
+GENERIC: loc>operand ( loc -- operand )
-M: rs-loc v>operand n>> rs-reg reg-stack ;
+
+M: ds-loc loc>operand n>> ds-reg reg-stack ;
+M: rs-loc loc>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 ;
@@ -54,10 +48,10 @@ HOOK: fixnum>slot@ cpu ( op -- )
 HOOK: prepare-division cpu ( -- )
 
 M: f load-literal
-    v>operand \ f tag-number MOV drop ;
+    \ f tag-number MOV drop ;
 
 M: fixnum load-literal
-    v>operand swap tag-fixnum MOV ;
+    swap tag-fixnum MOV ;
 
 M: x86 stack-frame ( n -- i )
     3 cells + 16 align cell - ;
@@ -99,16 +93,16 @@ M: x86 %jump-t ( label vreg -- ) \ f tag-number CMP JNE ;
 : align-code ( n -- )
     0 <repetition> % ;
 
-M: x86 %dispatch ( -- )
+M:: x86 %dispatch ( src temp -- )
     ! 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@
+    src fixnum>slot@
     ! Add jump table base
-    temp-reg-2 HEX: ffffffff MOV rc-absolute-cell rel-here
+    temp HEX: ffffffff MOV rc-absolute-cell rel-here
-    temp-reg-1 temp-reg-2 ADD
+    src temp ADD
-    temp-reg-1 HEX: 7f [+] JMP
+    src HEX: 7f [+] JMP
     ! Fix up the displacement above
     code-alignment dup bootstrap-cell 8 = 15 9 ? +
     building get dup pop* push
@@ -117,9 +111,9 @@ M: x86 %dispatch ( -- )
 M: x86 %dispatch-label ( word -- )
     0 cell, rc-absolute-cell rel-word ;
 
-M: x86 %peek [ v>operand ] bi@ MOV ;
+M: x86 %peek loc>operand MOV ;
 
-M: x86 %replace swap %peek ;
+M: x86 %replace loc>operand swap MOV ;
 
 : (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
@@ -146,13 +140,13 @@ M: x86 %return ( -- ) 0 %unwind ;
 
 ! Alien intrinsics
 M: x86 %unbox-byte-array ( dst src -- )
-    [ v>operand ] bi@ byte-array-offset [+] LEA ;
+    byte-array-offset [+] LEA ;
 
 M: x86 %unbox-alien ( dst src -- )
-    [ v>operand ] bi@ alien-offset [+] MOV ;
+    alien-offset [+] MOV ;
 
 M: x86 %unbox-f ( dst src -- )
-    drop v>operand 0 MOV ;
+    drop 0 MOV ;
 
 M: x86 %unbox-any-c-ptr ( dst src -- )
     { "is-byte-array" "end" "start" } [ define-label ] each
@@ -161,7 +155,7 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
     ds-reg 0 MOV
     ! Object is stored in ds-reg
     rs-reg PUSH
-    rs-reg swap v>operand MOV
+    rs-reg swap MOV
     ! We come back here with displaced aliens
     "start" resolve-label
     ! Is the object f?
@@ -182,34 +176,45 @@ M: x86 %unbox-any-c-ptr ( dst src -- )
     ds-reg byte-array-offset ADD
     "end" resolve-label
     ! Done, store address in destination register
-    v>operand ds-reg MOV
+    ds-reg MOV
     ! Restore rs-reg
     rs-reg POP
     ! Restore ds-reg
     ds-reg POP ;
 
-: allot-reg ( -- reg )
+M:: x86 %write-barrier ( src temp -- )
-    #! We temporarily use the datastack register, since it won't
+    #! Mark the card pointed to by vreg.
-    #! be accessed inside the quotation given to %allot in any
+    ! Mark the card
-    #! case.
+    src card-bits SHR
-    ds-reg ;
+    "cards_offset" f temp %alien-global
+    temp temp [+] card-mark <byte> MOV
 
-: (object@) ( n -- operand ) allot-reg swap [+] ;
+    ! Mark the card deck
-
+    temp deck-bits card-bits - SHR
-: object@ ( n -- operand ) cells (object@) ;
+    "decks_offset" f temp %alien-global
+    temp temp [+] card-mark <byte> MOV ;
 
 : load-zone-ptr ( reg -- )
     #! Load pointer to start of zone array
     0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
 
-: load-allot-ptr ( -- )
+: load-allot-ptr ( temp -- )
-    allot-reg load-zone-ptr
+    [ load-zone-ptr ] [ PUSH ] [ dup cell [+] MOV ] tri ;
-    allot-reg PUSH
-    allot-reg dup cell [+] MOV ;
 
-: inc-allot-ptr ( n -- )
+: inc-allot-ptr ( n temp -- )
-    allot-reg POP
+    [ POP ] [ cell [+] swap 8 align ADD ] bi ;
-    allot-reg cell [+] swap 8 align ADD ;
+
+: store-header ( temp type -- )
+    [ 0 [+] ] [ type-number tag-fixnum ] bi* MOV ;
+
+: store-tagged ( dst temp tag -- )
+    dupd tag-number OR MOV ;
+
+M:: x86 %allot ( dst size type tag temp -- )
+    temp load-allot-ptr
+    temp type store-header
+    temp size inc-allot-ptr
+    dst temp store-tagged ;
 
 M: x86 %gc ( -- )
     "end" define-label
@@ -223,73 +228,53 @@ M: x86 %gc ( -- )
     "minor_gc" f %alien-invoke
     "end" resolve-label ;
 
-: store-header ( header -- )
+: bignum@ ( reg n -- op ) cells bignum tag-number - [+] ;
-    0 object@ swap type-number tag-fixnum MOV ;
 
-: %allot ( header size quot -- )
+:: %allot-bignum-signed-1 ( dst src temp -- )
-    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" }
+        { "end" "nonzero" "positive" "store" } [ define-label ] each
-        [ define-label ] each
+        src 0 CMP ! is it zero?
-        dup v>operand 0 CMP ! is it zero?
         "nonzero" get JNE
-        0 >bignum pick v>operand load-indirect ! this is our result
+        ! Use cached zero value
+        0 >bignum dst load-indirect
         "end" get JMP
         "nonzero" resolve-label
-        bignum 4 cells [
+        ! Allocate a bignum
+        dst 4 cells bignum bignum temp %allot
         ! Write length
-            1 object@ 2 v>operand MOV
+        dst 1 bignum@ 2 MOV
         ! Test sign
-            dup v>operand 0 CMP
+        src 0 CMP
         "positive" get JGE
-            2 object@ 1 MOV ! negative sign
+        dst 2 bignum@ 1 MOV ! negative sign
-            dup v>operand NEG
+        src NEG
         "store" get JMP
         "positive" resolve-label
-            2 object@ 0 MOV ! positive sign
+        dst 2 bignum@ 0 MOV ! positive sign
         "store" resolve-label
-            3 object@ swap v>operand MOV
+        dst 3 bignum@ src MOV
-            ! Store tagged ptr in reg
-            bignum %store-tagged
-        ] %allot
         "end" resolve-label
     ] with-scope ;
 
-M: x86 %box-alien ( dst src -- )
+: alien@ ( reg n -- op ) cells object tag-number - [+] ;
+
+M:: x86 %box-alien ( dst src temp -- )
     [
         { "end" "f" } [ define-label ] each
-        dup v>operand 0 CMP
+        src 0 CMP
         "f" get JE
-        alien 4 cells [
+        dst 4 cells alien object temp %allot
-            1 object@ \ f tag-number MOV
+        dst 1 alien@ \ f tag-number MOV
-            2 object@ \ f tag-number MOV
+        dst 2 alien@ \ f tag-number MOV
         ! Store src in alien-offset slot
-            3 object@ swap v>operand MOV
+        dst 3 alien@ src MOV
-            ! Store tagged ptr in dst
-            dup object %store-tagged
-        ] %allot
         "end" get JMP
         "f" resolve-label
-        f [ v>operand ] bi@ MOV
+        \ f tag-number MOV
         "end" resolve-label
     ] with-scope ;
 
@@ -321,7 +306,7 @@ M: x86 %box-alien ( dst src -- )
     ! 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" } } }
+            { input { { f "obj" known-tag } { small-slot "n" } } }
             { scratch { { f "val" } } }
             { output { "val" } }
         }
@@ -329,7 +314,7 @@ M: x86 %box-alien ( dst src -- )
     ! Slot number is literal
     {
         [ "obj" operand %slot-literal-any-tag MOV ] T{ template
-            { input { { f "obj" } { [ small-slot? ] "n" } } }
+            { input { { f "obj" } { small-slot "n" } } }
             { output { "obj" } }
         }
     }
@@ -343,40 +328,26 @@ M: x86 %box-alien ( dst src -- )
     }
 } define-intrinsics
 
-: generate-write-barrier ( -- )
+\ (set-slot) {
-    #! 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
+        [ %slot-literal-known-tag "val" operand MOV ] T{ template
-            { input { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
+            { 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
+        [ %slot-literal-any-tag "val" operand MOV ] T{ template
-            { input { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
+            { 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
+        [ %slot-any "val" operand MOV ] T{ template
             { input { { f "val" } { f "obj" } { f "n" } } }
             { scratch { { f "scratch" } } }
             { clobber { "obj" "n" } }
@@ -400,7 +371,7 @@ M: x86 %box-alien ( dst src -- )
 
 : fixnum-value-op ( op -- pair )
     T{ template
-        { input { { f "x" } { [ small-tagged? ] "y" } } }
+        { input { { f "x" } { small-tagged "y" } } }
         { output { "x" } }
     } fixnum-op ;
 
@@ -476,7 +447,7 @@ M: x86 %box-alien ( dst src -- )
     ! 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
+    "z" operand "x" operand "y" operand %allot-bignum-signed-1
     "end" resolve-label ; inline
 
 : overflow-template ( word insn -- )
@@ -516,9 +487,10 @@ M: x86 %box-alien ( dst src -- )
 
 \ fixnum>bignum [
     "x" operand %untag-fixnum
-    "x" get dup %allot-bignum-signed-1
+    "x" operand dup "scratch" operand %allot-bignum-signed-1
 ] T{ template
     { input { { f "x" } } }
+    { scratch { { f "scratch" } } }
     { output { "x" } }
     { gc t }
 } define-intrinsic
@@ -531,7 +503,7 @@ M: x86 %box-alien ( dst src -- )
     "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
+    "y" operand 1 tag-fixnum CMP
     "nonzero" get JNE
     "y" operand 0 MOV
     "end" get JMP
@@ -577,90 +549,6 @@ M: x86 %box-alien ( dst src -- )
     { 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

unfinished/compiler/cfg/builder/builder.factor

@@ -1,7 +1,10 @@
  ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators hashtables kernel
-math fry namespaces make sequences words stack-checker.inlining
+math fry namespaces make sequences words byte-arrays
+locals layouts
+stack-checker.inlining
+compiler.intrinsics
 compiler.tree
 compiler.tree.builder
 compiler.tree.combinators
@@ -142,8 +145,7 @@ M: #recursive emit-node
     children>> [ emit-nodes ] emit-branches ;
 
 M: #if emit-node
-    { { f "flag" } } lazy-load first ##branch-t
+    phantom-pop ##branch-t emit-if iterate-next ;
-    emit-if iterate-next ;
 
 ! #dispatch
 : dispatch-branch ( nodes word -- label )
@@ -167,7 +169,9 @@ M: #if emit-node
     ] each ;
 
 : emit-dispatch ( node -- )
-    ##epilogue ##dispatch dispatch-branches init-phantoms ;
+    phantom-pop int-regs next-vreg
+    [ finalize-contents finalize-heights ##epilogue ] 2dip ##dispatch
+    dispatch-branches init-phantoms ;
 
 M: #dispatch emit-node
     tail-call? [
@@ -225,12 +229,45 @@ M: #dispatch emit-node
 : setup-value-classes ( #call -- )
     node-input-infos [ class>> ] map set-value-classes ;
 
+{
+    (tuple) (array) (byte-array)
+    (complex) (ratio) (wrapper)
+    (write-barrier)
+} [ t "intrinsic" set-word-prop ] each
+
+: allot-size ( #call -- n )
+    1 phantom-datastack get phantom-input first value>> ;
+
+:: emit-allot ( size type tag -- )
+    int-regs next-vreg
+    dup fresh-object
+    dup size type tag int-regs next-vreg ##allot
+    type tagged boa phantom-push ;
+
+: emit-write-barrier ( -- )
+    phantom-pop dup >vreg fresh-object? [ drop ] [
+        int-regs next-vreg ##write-barrier
+    ] if ;
+
+: emit-intrinsic ( word -- next )
+    {
+        { \ (tuple) [ allot-size 2 cells + tuple tuple emit-allot ] }
+        { \ (array) [ allot-size 2 cells + array object emit-allot ] }
+        { \ (byte-array) [ allot-size cells 2 + byte-array object emit-allot ] }
+        { \ (complex) [ 3 cells complex complex emit-allot ] }
+        { \ (ratio) [ 3 cells ratio ratio emit-allot ] }
+        { \ (wrapper) [ 2 cells wrapper object emit-allot ] }
+        { \ (write-barrier) [ emit-write-barrier ] }
+    } case
+    iterate-next ;
+
 M: #call emit-node
     dup setup-value-classes
     dup find-if-intrinsic [ do-if-intrinsic ] [
         dup find-boolean-intrinsic [ do-boolean-intrinsic ] [
             dup find-intrinsic [ do-intrinsic ] [
-                word>> emit-call
+                word>> dup "intrinsic" word-prop
+                [ emit-intrinsic ] [ emit-call ] if
             ] ?if
         ] ?if
     ] ?if ;

unfinished/compiler/cfg/instructions/instructions.factor

@@ -27,7 +27,7 @@ INSN: ##intrinsic quot defs-vregs uses-vregs ;
 
 ! Jump tables
 INSN: ##dispatch-label label ;
-INSN: ##dispatch ;
+INSN: ##dispatch src temp ;
 
 ! Boxing and unboxing
 INSN: ##copy < ##unary ;
@@ -37,9 +37,12 @@ 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-float < ##unary temp ;
-INSN: ##box-alien < ##unary ;
+INSN: ##box-alien < ##unary temp ;
 
+! Memory allocation
+INSN: ##allot < ##nullary size type tag temp ;
+INSN: ##write-barrier src temp ;
 INSN: ##gc ;
 
 ! FFI
@@ -52,10 +55,21 @@ GENERIC: uses-vregs ( insn -- seq )
 
 M: ##nullary defs-vregs dst>> >vreg 1array ;
 M: ##unary defs-vregs dst>> >vreg 1array ;
+M: ##write-barrier defs-vregs temp>> >vreg 1array ;
+
+: allot-defs-vregs ( insn -- seq )
+    [ dst>> >vreg ] [ temp>> >vreg ] bi 2array ;
+
+M: ##box-float defs-vregs allot-defs-vregs ;
+M: ##box-alien defs-vregs allot-defs-vregs ;
+M: ##allot defs-vregs allot-defs-vregs ;
+M: ##dispatch defs-vregs temp>> >vreg 1array ;
 M: insn defs-vregs drop f ;
 
 M: ##replace uses-vregs src>> >vreg 1array ;
 M: ##unary uses-vregs src>> >vreg 1array ;
+M: ##write-barrier uses-vregs src>> >vreg 1array ;
+M: ##dispatch uses-vregs src>> >vreg 1array ;
 M: insn uses-vregs drop f ;
 
 : intrinsic-vregs ( assoc -- seq' )

unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -28,6 +28,7 @@ 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 -- )

unfinished/compiler/cfg/stacks/stacks.factor

@@ -3,18 +3,12 @@
 USING: arrays assocs classes classes.private classes.algebra
 combinators hashtables kernel layouts math fry namespaces
 quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order compiler.cfg.instructions
+byte-arrays accessors sets math.order compiler.backend
-compiler.cfg.registers ;
+compiler.cfg.instructions compiler.cfg.registers ;
 IN: compiler.cfg.stacks
 
 ! Converting stack operations into register operations, while
 ! doing a bit of optimization along the way.
-
-USE: qualified
-FROM: compiler.generator.registers => +input+   ;
-FROM: compiler.generator.registers => +output+  ;
-FROM: compiler.generator.registers => +scratch+ ;
-FROM: compiler.generator.registers => +clobber+ ;
 SYMBOL: known-tag
 
 ! Value protocol
@@ -100,6 +94,14 @@ M: constant move-spec class ;
         swap >>class
     %move ;
 
+! Operands holding pointers to freshly-allocated objects which
+! are guaranteed to be in the nursery
+SYMBOL: fresh-objects
+
+: fresh-object ( vreg/t -- ) fresh-objects get push ;
+
+: fresh-object? ( vreg -- ? ) fresh-objects get memq? ;
+
 : %move ( dst src -- )
     2dup [ move-spec ] bi@ 2array {
         { { f f } [ ##copy ] }
@@ -114,8 +116,8 @@ M: constant move-spec class ;
 
         { { f constant } [ value>> ##load-literal ] }
 
-        { { f float } [ ##box-float ] }
+        { { f float } [ int-regs next-vreg ##box-float t fresh-object ] }
-        { { f unboxed-alien } [ ##box-alien ] }
+        { { f unboxed-alien } [ int-regs next-vreg ##box-alien t fresh-object ] }
         { { f loc } [ ##peek ] }
 
         { { float f } [ ##unbox-float ] }
@@ -223,10 +225,6 @@ M: phantom-retainstack finalize-height
 : live-locs ( -- seq )
     [ (live-locs) ] each-phantom append prune ;
 
-! Operands holding pointers to freshly-allocated objects which
-! are guaranteed to be in the nursery
-SYMBOL: fresh-objects
-
 : reg-spec>class ( spec -- class )
     float eq? double-float-regs int-regs ? ;
 
@@ -255,7 +253,7 @@ SYMBOL: fresh-objects
 
 M: value (lazy-load)
     {
-        { [ dup quotation? ] [ drop ] }
+        { [ dup { small-slot small-tagged } memq? ] [ drop ] }
         { [ 2dup compatible? ] [ drop ] }
         [ (eager-load) ]
     } cond ;
@@ -280,23 +278,11 @@ M: loc lazy-store
         dup loc? over cached? or [ 2drop ] [ %move ] if
     ] each-loc ;
 
-: reset-phantom ( phantom -- )
+: clear-phantoms ( -- )
-    #! Kill register assignments but preserve constants and
+    [ stack>> delete-all ] each-phantom ;
-    #! class information.
-    dup phantom-locs*
-    over stack>> [
-        dup constant? [ nip ] [
-            value-class over set-value-class
-        ] if
-    ] 2map
-    over stack>> delete-all
-    swap stack>> push-all ;
-
-: reset-phantoms ( -- )
-    [ reset-phantom ] each-phantom ;
 
 : finalize-contents ( -- )
-    finalize-locs finalize-vregs reset-phantoms ;
+    finalize-locs finalize-vregs clear-phantoms ;
 
 ! Loading stacks to vregs
 : vreg-substitution ( value vreg -- pair )
@@ -312,26 +298,22 @@ M: loc lazy-store
     [ substitute-vreg? ] assoc-filter >hashtable
     '[ stack>> _ substitute-here ] each-phantom ;
 
-: clear-phantoms ( -- )
-    [ stack>> delete-all ] each-phantom ;
-
 : set-value-classes ( classes -- )
     phantom-datastack get
     over length over add-locs
-    stack>> [ set-value-class ] 2reverse-each ;
+    stack>> [
+        [ value-class class-and ] keep set-value-class
+    ] 2reverse-each ;
 
 : finalize-phantoms ( -- )
     #! Commit all deferred stacking shuffling, and ensure the
     #! in-memory data and retain stacks are up to date with
     #! respect to the compiler's current picture.
     finalize-contents
-    clear-phantoms
     finalize-heights
-    fresh-objects get [ empty? [ ##gc ] unless ] [ delete-all ] bi ;
+    fresh-objects get [
-
+        empty? [ 0 ##frame-required ##gc ] unless
-: fresh-object ( obj -- ) fresh-objects get push ;
+    ] [ delete-all ] bi ;
-
-: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
 
 : init-phantoms ( -- )
     V{ } clone fresh-objects set
@@ -364,3 +346,7 @@ M: loc lazy-store
 
 : phantom-rdrop ( n -- )
     phantom-retainstack get phantom-input drop ;
+
+: phantom-pop ( -- vreg )
+    1 phantom-datastack get phantom-input dup first f (lazy-load)
+    [ 1array substitute-vregs ] keep ;

unfinished/compiler/cfg/templates/templates.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors sequences kernel fry namespaces
-quotations combinators classes.algebra compiler.cfg.instructions
+quotations combinators classes.algebra compiler.backend
-compiler.cfg.registers compiler.cfg.stacks ;
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks ;
 IN: compiler.cfg.templates
 
 TUPLE: template input output scratch clobber gc ;
@@ -57,7 +57,9 @@ TUPLE: template input output scratch clobber gc ;
 
 : apply-template ( pair quot -- vregs )
     [
-        first2 dup do-template-inputs
+        first2
+        dup gc>> [ t fresh-object ] when
+        dup do-template-inputs
         [ do-template-outputs ] 2keep
     ] dip call ; inline
 
@@ -67,12 +69,11 @@ TUPLE: template input output scratch clobber gc ;
     #! to the fixnum. Otherwise, the values don't match. If the
     #! spec is not a quotation, its a reg-class, in which case
     #! the value is always good.
-    dup quotation? [
+    {
-        over constant?
+        { [ dup small-slot eq? ] [ drop dup constant? [ value>> small-slot? ] [ drop f ] if ] }
-        [ >r value>> r> 2drop f ] [ 2drop f ] if
+        { [ dup small-tagged eq? ] [ drop dup constant? [ value>> small-tagged? ] [ drop f ] if ] }
-    ] [
+        [ 2drop t ]
-        2drop t
+    } cond ;
-    ] if ;
 
 : class-matches? ( actual expected -- ? )
     {

unfinished/compiler/codegen/codegen.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces make math math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
-threads continuations.private libc combinators
+combinators classes.algebra alien alien.c-types alien.structs
-alien alien.c-types alien.structs alien.strings
+alien.strings sets threads libc continuations.private
 compiler.errors
 compiler.alien
 compiler.backend
@@ -15,6 +15,16 @@ IN: compiler.codegen
 
 GENERIC: generate-insn ( insn -- )
 
+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* ;
+
 : generate-insns ( insns -- code )
     [
         [
@@ -66,11 +76,14 @@ M: _prologue generate-insn
 M: _epilogue generate-insn
     n>> %epilogue ;
 
-M: ##load-literal generate-insn [ obj>> ] [ dst>> ] bi load-literal ;
+M: ##load-literal generate-insn
+    [ obj>> ] [ dst>> v>operand ] bi load-literal ;
 
-M: ##peek generate-insn [ dst>> ] [ loc>> ] bi %peek ;
+M: ##peek generate-insn
+    [ dst>> v>operand ] [ loc>> ] bi %peek ;
 
-M: ##replace generate-insn [ src>> ] [ loc>> ] bi %replace ;
+M: ##replace generate-insn
+    [ src>> ] [ loc>> ] bi %replace ;
 
 M: ##inc-d generate-insn n>> %inc-d ;
 
@@ -82,9 +95,32 @@ M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
 
 M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
 
+SYMBOL: operands
+
+: init-intrinsic ( insn -- )
+    [ defs-vregs>> ] [ uses-vregs>> ] bi append operands set ;
+
 M: ##intrinsic generate-insn
     [ init-intrinsic ] [ quot>> call ] bi ;
 
+: (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 ;
+
+: operand-immediate? ( operand -- ? )
+    operand-class immediate class<= ;
+
+: unique-operands ( operands quot -- )
+    >r [ operand ] map prune r> each ; inline
+
 M: _if-intrinsic generate-insn
     [ init-intrinsic ]
     [ [ label>> lookup-label ] [ quot>> ] bi call ] bi ;
@@ -93,32 +129,48 @@ M: _branch generate-insn
     label>> lookup-label %jump-label ;
 
 M: _branch-f generate-insn
-    [ src>> ] [ label>> lookup-label ] bi %jump-f ;
+    [ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
 
 M: _branch-t generate-insn
-    [ src>> ] [ label>> lookup-label ] bi %jump-t ;
+    [ src>> v>operand ] [ 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 ;
+: dst/src ( insn -- dst src )
+    [ dst>> v>operand ] [ src>> v>operand ] bi ;
 
-M: ##copy-float generate-insn %copy-float ;
+M: ##copy generate-insn dst/src %copy ;
 
-M: ##unbox-float generate-insn [ dst>> ] [ src>> ] bi %unbox-float ;
+M: ##copy-float generate-insn dst/src %copy-float ;
 
-M: ##unbox-f generate-insn [ dst>> ] [ src>> ] bi %unbox-f ;
+M: ##unbox-float generate-insn dst/src %unbox-float ;
 
-M: ##unbox-alien generate-insn [ dst>> ] [ src>> ] bi %unbox-alien ;
+M: ##unbox-f generate-insn dst/src %unbox-f ;
 
-M: ##unbox-byte-array generate-insn [ dst>> ] [ src>> ] bi %unbox-byte-array ;
+M: ##unbox-alien generate-insn dst/src %unbox-alien ;
 
-M: ##unbox-any-c-ptr generate-insn [ dst>> ] [ src>> ] bi %unbox-any-c-ptr ;
+M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
 
-M: ##box-float generate-insn [ dst>> ] [ src>> ] bi %box-float ;
+M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
 
-M: ##box-alien generate-insn [ dst>> ] [ src>> ] bi %box-alien ;
+M: ##box-float generate-insn dst/src %box-float ;
+
+M: ##box-alien generate-insn dst/src %box-alien ;
+
+M: ##allot generate-insn
+    {
+        [ dst>> v>operand ]
+        [ size>> ]
+        [ type>> ]
+        [ tag>> ]
+        [ temp>> v>operand ]
+    } cleave
+    %allot ;
+
+M: ##write-barrier generate-insn
+    [ src>> v>operand ] [ temp>> v>operand ] bi %write-barrier ;
 
 M: ##gc generate-insn drop %gc ;