Merge branch 'master' of git://factorcode.org/git/factor

basis/bootstrap/compiler/compiler.factor

@@ -7,7 +7,7 @@ hashtables.private sequences.private math classes.tuple.private
 growable namespaces.private assocs words command-line vocabs io
 io.encodings.string prettyprint libc splitting math.parser
 compiler.units math.order compiler.tree.builder
-compiler.tree.optimizer ;
+compiler.tree.optimizer compiler.cfg.optimizer ;
 IN: bootstrap.compiler
 
 ! Don't bring this in when deploying, since it will store a
@@ -93,6 +93,10 @@ nl
 
 { optimize-tree } compile-uncompiled
 
+{ optimize-cfg } compile-uncompiled
+
+{ (compile) } compile-uncompiled
+
 vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush

basis/bootstrap/image/image.factor

@@ -8,7 +8,8 @@ grouping growable classes classes.builtin classes.tuple
 classes.tuple.private words.private io.binary io.files vocabs
 vocabs.loader source-files definitions debugger
 quotations.private sequences.private combinators
-io.encodings.binary math.order math.private accessors slots.private ;
+io.encodings.binary math.order math.private accessors
+slots.private compiler.units ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
@@ -458,6 +459,8 @@ M: quotation '
     800000 <vector> image set
     20000 <hashtable> objects set
     emit-header t, 0, 1, -1,
+    "Building generic words..." print flush
+    call-remake-generics-hook
     "Serializing words..." print flush
     emit-words
     "Serializing JIT data..." print flush

basis/cocoa/messages/messages.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.strings arrays assocs
-combinators compiler kernel math namespaces make parser
+combinators compiler compiler.alien kernel math namespaces make
-prettyprint prettyprint.sections quotations sequences strings
+parser prettyprint prettyprint.sections quotations sequences
-words cocoa.runtime io macros memoize debugger fry
+strings words cocoa.runtime io macros memoize debugger
-io.encodings.ascii effects compiler.generator libc libc.private ;
+io.encodings.ascii effects libc libc.private parser lexer init
+core-foundation fry ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )

basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor

@@ -0,0 +1,56 @@
+USING: compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.alias-analysis cpu.architecture tools.test
+kernel ;
+IN: compiler.cfg.alias-analysis.tests
+
+[ ] [
+    {
+        T{ ##peek f V int-regs 2 D 1 f }
+        T{ ##box-alien f V int-regs 1 V int-regs 2 }
+        T{ ##slot-imm f V int-regs 3 V int-regs 1 0 3 }
+    } alias-analysis drop
+] unit-test
+
+[ ] [
+    {
+        T{ ##load-indirect f V int-regs 1 "hello" }
+        T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
+    } alias-analysis drop
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##peek f V int-regs 2 D 2 f }
+        T{ ##replace f V int-regs 1 D 0 f }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##peek f V int-regs 2 D 2 f }
+        T{ ##replace f V int-regs 2 D 0 f }
+        T{ ##replace f V int-regs 1 D 0 f }
+    } alias-analysis
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##peek f V int-regs 2 D 0 f }
+        T{ ##copy f V int-regs 3 V int-regs 2 f }
+        T{ ##copy f V int-regs 4 V int-regs 1 f }
+        T{ ##replace f V int-regs 3 D 0 f }
+        T{ ##replace f V int-regs 4 D 1 f }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 1 f }
+        T{ ##peek f V int-regs 2 D 0 f }
+        T{ ##replace f V int-regs 1 D 0 f }
+        T{ ##replace f V int-regs 2 D 1 f }
+        T{ ##peek f V int-regs 3 D 1 f }
+        T{ ##peek f V int-regs 4 D 0 f }
+        T{ ##replace f V int-regs 3 D 0 f }
+        T{ ##replace f V int-regs 4 D 1 f }
+    } alias-analysis
+] unit-test

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -1,10 +1,12 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math namespaces assocs hashtables sequences
-accessors vectors combinators sets compiler.vops compiler.cfg ;
+accessors vectors combinators sets classes compiler.cfg
-IN: compiler.cfg.alias
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.copy-prop ;
+IN: compiler.cfg.alias-analysis
 
-! Alias analysis -- must be run after compiler.cfg.stack.
+! Alias analysis -- assumes compiler.cfg.height has already run.
 !
 ! We try to eliminate redundant slot and stack
 ! traffic using some simple heuristics.
@@ -69,8 +71,8 @@ SYMBOL: vregs>acs
 : check [ "BUG: static type error detected" throw ] unless* ; inline
  
 : vreg>ac ( vreg -- ac )
-    #! Only vregs produced by %%allot, %peek and %%slot can
+    #! Only vregs produced by ##allot, ##peek and ##slot can
-    #! ever be used as valid inputs to %%slot and %%set-slot,
+    #! ever be used as valid inputs to ##slot and ##set-slot,
     #! so we assert this fact by not giving alias classes to
     #! other vregs.
     vregs>acs get at check ;
@@ -175,31 +177,30 @@ SYMBOL: heap-ac
         [ kill-constant-set-slot ] 2bi
     ] [ nip kill-computed-set-slot ] if ;
 
-SYMBOL: copies
-
-: resolve ( vreg -- vreg )
-    dup copies get at swap or ;
-
 SYMBOL: constants
 
 : constant ( vreg -- n/f )
-    #! Return an %iconst value, or f if the vreg was not
+    #! Return a ##load-immediate value, or f if the vreg was not
-    #! assigned by an %iconst.
+    #! assigned by an ##load-immediate.
     resolve constants get at ;
 
 ! We treat slot accessors and stack traffic alike
 GENERIC: insn-slot# ( insn -- slot#/f )
 GENERIC: insn-object ( insn -- vreg )
 
-M: %peek insn-slot# n>> ;
+M: ##peek insn-slot# loc>> n>> ;
-M: %replace insn-slot# n>> ;
+M: ##replace insn-slot# loc>> n>> ;
-M: %%slot insn-slot# slot>> constant ;
+M: ##slot insn-slot# slot>> constant ;
-M: %%set-slot insn-slot# slot>> constant ;
+M: ##slot-imm insn-slot# slot>> ;
+M: ##set-slot insn-slot# slot>> constant ;
+M: ##set-slot-imm insn-slot# slot>> ;
 
-M: %peek insn-object stack>> ;
+M: ##peek insn-object loc>> class ;
-M: %replace insn-object stack>> ;
+M: ##replace insn-object loc>> class ;
-M: %%slot insn-object obj>> resolve ;
+M: ##slot insn-object obj>> resolve ;
-M: %%set-slot insn-object obj>> resolve ;
+M: ##slot-imm insn-object obj>> resolve ;
+M: ##set-slot insn-object obj>> resolve ;
+M: ##set-slot-imm insn-object obj>> resolve ;
 
 : init-alias-analysis ( -- )
     H{ } clone histories set
@@ -212,24 +213,37 @@ M: %%set-slot insn-object obj>> resolve ;
     0 ac-counter set
     next-ac heap-ac set
 
-    %data next-ac set-ac
+    ds-loc next-ac set-ac
-    %retain next-ac set-ac ;
+    rs-loc next-ac set-ac ;
 
-GENERIC: analyze-aliases ( insn -- insn' )
+GENERIC: analyze-aliases* ( insn -- insn' )
 
-M: %iconst analyze-aliases
+M: ##load-immediate analyze-aliases*
-    dup [ value>> ] [ out>> ] bi constants get set-at ;
+    dup [ val>> ] [ dst>> ] bi constants get set-at ;
 
-M: %%allot analyze-aliases
+M: ##load-indirect analyze-aliases*
+    dup dst>> set-heap-ac ;
+
+M: ##allot analyze-aliases*
     #! A freshly allocated object is distinct from any other
     #! object.
-    dup out>> set-new-ac ;
+    dup dst>> set-new-ac ;
 
-M: read-op analyze-aliases
+M: ##box-float analyze-aliases*
-    dup out>> set-heap-ac
+    #! A freshly allocated object is distinct from any other
-    dup [ out>> ] [ insn-slot# ] [ insn-object ] tri
+    #! object.
+    dup dst>> set-new-ac ;
+
+M: ##box-alien analyze-aliases*
+    #! A freshly allocated object is distinct from any other
+    #! object.
+    dup dst>> set-new-ac ;
+
+M: ##read analyze-aliases*
+    dup dst>> set-heap-ac
+    dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
     2dup live-slot dup [
-        2nip %copy boa analyze-aliases nip
+        2nip f \ ##copy boa analyze-aliases* nip
     ] [
         drop remember-slot
     ] if ;
@@ -239,21 +253,20 @@ M: read-op analyze-aliases
     #! from?
     live-slot = ;
 
-M: write-op analyze-aliases
+M: ##write analyze-aliases*
     dup
-    [ in>> resolve ] [ insn-slot# ] [ insn-object ] tri
+    [ src>> resolve ] [ insn-slot# ] [ insn-object ] tri
-    3dup idempotent? [
+    [ remember-set-slot drop ] [ load-slot ] 3bi ;
-        2drop 2drop nop
-    ] [
-        [ remember-set-slot drop ] [ load-slot ] 3bi
-    ] if ;
 
-M: %copy analyze-aliases
+M: ##copy analyze-aliases*
     #! The output vreg gets the same alias class as the input
     #! vreg, since they both contain the same value.
-    dup [ in>> resolve ] [ out>> ] bi copies get set-at ;
+    dup record-copy ;
 
-M: vop analyze-aliases ;
+M: insn analyze-aliases* ;
+
+: analyze-aliases ( insns -- insns' )
+    [ insn# set analyze-aliases* ] map-index sift ;
 
 SYMBOL: live-stores
 
@@ -264,30 +277,35 @@ SYMBOL: live-stores
     ] map concat unique
     live-stores set ;
 
-GENERIC: eliminate-dead-store ( insn -- insn' )
+GENERIC: eliminate-dead-stores* ( insn -- insn' )
 
-: (eliminate-dead-store) ( insn -- insn' )
+: (eliminate-dead-stores) ( insn -- insn' )
     dup insn-slot# [
         insn# get live-stores get key? [
-            drop nop
+            drop f
         ] unless
     ] when ;
 
-M: %replace eliminate-dead-store
+M: ##replace eliminate-dead-stores*
     #! Writes to above the top of the stack can be pruned also.
     #! This is sound since any such writes are not observable
     #! after the basic block, and any reads of those locations
     #! will have been converted to copies by analyze-slot,
     #! and the final stack height of the basic block is set at
     #! the beginning by compiler.cfg.stack.
-    dup n>> 0 < [ drop nop ] [ (eliminate-dead-store) ] if ;
+    dup loc>> n>> 0 < [ drop f ] [ (eliminate-dead-stores) ] if ;
 
-M: %%set-slot eliminate-dead-store (eliminate-dead-store) ;
+M: ##set-slot eliminate-dead-stores* (eliminate-dead-stores) ;
 
-M: vop eliminate-dead-store ;
+M: ##set-slot-imm eliminate-dead-stores* (eliminate-dead-stores) ;
+
+M: insn eliminate-dead-stores* ;
+
+: eliminate-dead-stores ( insns -- insns' )
+    [ insn# set eliminate-dead-stores* ] map-index sift ;
 
 : alias-analysis ( insns -- insns' )
     init-alias-analysis
-    [ insn# set analyze-aliases ] map-index
+    analyze-aliases
     compute-live-stores
-    [ insn# set eliminate-dead-store ] map-index ;
+    eliminate-dead-stores ;

basis/compiler/cfg/builder/builder-tests.factor

@@ -0,0 +1,105 @@
+IN: compiler.cfg.builder.tests
+USING: tools.test kernel sequences
+words sequences.private fry prettyprint alien alien.accessors
+math.private compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
+kernel.private math ;
+
+\ build-cfg must-infer
+
+! Just ensure that various CFGs build correctly.
+: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
+
+{
+    [ ]
+    [ dup ]
+    [ swap ]
+    [ >r r> ]
+    [ fixnum+ ]
+    [ fixnum+fast ]
+    [ 3 fixnum+fast ]
+    [ fixnum*fast ]
+    [ 3 fixnum*fast ]
+    [ fixnum-shift-fast ]
+    [ 10 fixnum-shift-fast ]
+    [ -10 fixnum-shift-fast ]
+    [ 0 fixnum-shift-fast ]
+    [ fixnum-bitnot ]
+    [ eq? ]
+    [ "hi" eq? ]
+    [ fixnum< ]
+    [ 5 fixnum< ]
+    [ float+ ]
+    [ 3.0 float+ ]
+    [ float<= ]
+    [ fixnum>bignum ]
+    [ bignum>fixnum ]
+    [ fixnum>float ]
+    [ float>fixnum ]
+    [ 3 f <array> ]
+    [ [ 1 ] [ 2 ] if ]
+    [ fixnum< [ 1 ] [ 2 ] if ]
+    [ float+ [ 2.0 float* ] [ 3.0 float* ] bi float/f ]
+    [ { [ 1 ] [ 2 ] [ 3 ] } dispatch ]
+    [ [ t ] loop ]
+    [ [ dup ] loop ]
+    [ [ 2 ] [ 3 throw ] if 4 ]
+    [ "int" f "malloc" { "int" } alien-invoke ]
+    [ "int" { "int" } "cdecl" alien-indirect ]
+    [ "int" { "int" } "cdecl" [ ] alien-callback ]
+} [
+    unit-test-cfg
+] each
+
+: test-1 ( -- ) test-1 ;
+: test-2 ( -- ) 3 . test-2 ;
+: test-3 ( a -- b ) dup [ test-3 ] when ;
+
+{
+    test-1
+    test-2
+    test-3
+} [ unit-test-cfg ] each
+
+{
+    byte-array
+    simple-alien
+    alien
+    POSTPONE: f
+} [| class |
+    {
+        alien-signed-1
+        alien-signed-2
+        alien-signed-4
+        alien-unsigned-1
+        alien-unsigned-2
+        alien-unsigned-4
+        alien-cell
+        alien-float
+        alien-double
+    } [| word |
+        { class } word '[ _ declare 10 _ execute ] unit-test-cfg
+        { class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+    ] each
+    
+    {
+        set-alien-signed-1
+        set-alien-signed-2
+        set-alien-signed-4
+        set-alien-unsigned-1
+        set-alien-unsigned-2
+        set-alien-unsigned-4
+    } [| word |
+        { fixnum class } word '[ _ declare 10 _ execute ] unit-test-cfg
+        { fixnum class fixnum } word '[ _ declare _ execute ] unit-test-cfg
+    ] each
+    
+    { float class } \ set-alien-float '[ _ declare 10 _ execute ] unit-test-cfg
+    { float class fixnum } \ set-alien-float '[ _ declare _ execute ] unit-test-cfg
+    
+    { float class } \ set-alien-double '[ _ declare 10 _ execute ] unit-test-cfg
+    { float class fixnum } \ set-alien-double '[ _ declare _ execute ] unit-test-cfg
+    
+    { pinned-c-ptr class } \ set-alien-cell '[ _ declare 10 _ execute ] unit-test-cfg
+    { pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-cfg
+] each

basis/compiler/cfg/builder/builder.factor

@@ -0,0 +1,258 @@
+! 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 byte-arrays
+layouts alien.c-types alien.structs
+stack-checker.inlining cpu.architecture
+compiler.tree
+compiler.tree.builder
+compiler.tree.combinators
+compiler.tree.propagation.info
+compiler.cfg
+compiler.cfg.hats
+compiler.cfg.stacks
+compiler.cfg.iterator
+compiler.cfg.utilities
+compiler.cfg.registers
+compiler.cfg.intrinsics
+compiler.cfg.instructions
+compiler.alien ;
+IN: compiler.cfg.builder
+
+! Convert tree SSA IR to CFG SSA IR.
+
+: stop-iterating ( -- next ) end-basic-block f ;
+
+SYMBOL: procedures
+SYMBOL: current-word
+SYMBOL: current-label
+SYMBOL: loops
+SYMBOL: first-basic-block
+
+! Basic block after prologue, makes recursion faster
+SYMBOL: current-label-start
+
+: add-procedure ( -- )
+    basic-block get current-word get current-label get
+    <cfg> procedures get push ;
+
+: begin-procedure ( word label -- )
+    end-basic-block
+    begin-basic-block
+    H{ } clone loops set
+    current-label set
+    current-word set
+    add-procedure ;
+
+: with-cfg-builder ( nodes word label quot -- )
+    '[ begin-procedure @ ] with-scope ; inline
+
+GENERIC: emit-node ( node -- next )
+
+: check-basic-block ( node -- node' )
+    basic-block get [ drop f ] unless ; inline
+
+: emit-nodes ( nodes -- )
+    [ current-node emit-node check-basic-block ] iterate-nodes ;
+
+: begin-word ( -- )
+    #! We store the basic block after the prologue as a loop
+    #! labelled by the current word, so that self-recursive
+    #! calls can skip an epilogue/prologue.
+    ##prologue
+    ##branch
+    begin-basic-block
+    basic-block get first-basic-block set ;
+
+: (build-cfg) ( nodes word label -- )
+    [
+        begin-word
+        V{ } clone node-stack set
+        emit-nodes
+    ] with-cfg-builder ;
+
+: build-cfg ( nodes word -- procedures )
+    V{ } clone [
+        procedures [
+            dup (build-cfg)
+        ] with-variable
+    ] keep ;
+
+: local-recursive-call ( basic-block -- next )
+    ##branch
+    basic-block get successors>> push
+    stop-iterating ;
+
+: emit-call ( word -- next )
+    {
+        { [ dup loops get key? ] [ loops get at local-recursive-call ] }
+        { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
+        { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
+        [ ##epilogue ##jump stop-iterating ]
+    } cond ;
+
+! #recursive
+: compile-recursive ( node -- next )
+    [ label>> id>> emit-call ]
+    [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
+
+: remember-loop ( label -- )
+    basic-block get swap loops get set-at ;
+
+: compile-loop ( node -- next )
+    ##loop-entry
+    begin-basic-block
+    [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
+    iterate-next ;
+
+M: #recursive emit-node
+    dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
+
+! #if
+: emit-branch ( obj -- final-bb )
+    [
+        begin-basic-block
+        emit-nodes
+        basic-block get dup [ ##branch ] when
+    ] with-scope ;
+
+: emit-if ( node -- )
+    children>>  [ emit-branch ] map
+    end-basic-block
+    begin-basic-block
+    basic-block get '[ [ _ swap successors>> push ] when* ] each ;
+
+: ##branch-t ( vreg -- )
+    \ f tag-number cc/= ##compare-imm-branch ;
+
+M: #if emit-node
+    ds-pop ##branch-t emit-if iterate-next ;
+
+! #dispatch
+: dispatch-branch ( nodes word -- label )
+    gensym [
+        [
+            V{ } clone node-stack set
+            ##prologue
+            emit-nodes
+            basic-block get [
+                ##epilogue
+                ##return
+                end-basic-block
+            ] when
+        ] with-cfg-builder
+    ] keep ;
+
+: dispatch-branches ( node -- )
+    children>> [
+        current-word get dispatch-branch
+        ##dispatch-label
+    ] each ;
+
+: emit-dispatch ( node -- )
+    ##epilogue
+    ds-pop ^^offset>slot i ##dispatch
+    dispatch-branches ;
+
+: <dispatch-block> ( -- word )
+    gensym dup t "inlined-block" set-word-prop ;
+
+M: #dispatch emit-node
+    tail-call? [
+        emit-dispatch stop-iterating
+    ] [
+        current-word get <dispatch-block> [
+            [
+                begin-word
+                emit-dispatch
+            ] with-cfg-builder
+        ] keep emit-call
+    ] if ;
+
+! #call
+M: #call emit-node
+    dup word>> dup "intrinsic" word-prop
+    [ emit-intrinsic iterate-next ] [ nip emit-call ] if ;
+
+! #call-recursive
+M: #call-recursive emit-node label>> id>> emit-call ;
+
+! #push
+M: #push emit-node
+    literal>> ^^load-literal ds-push iterate-next ;
+
+! #shuffle
+: emit-shuffle ( effect -- )
+    [ out>> ] [ in>> dup length ds-load zip ] bi
+    '[ _ at ] map ds-store ;
+
+M: #shuffle emit-node
+    shuffle-effect emit-shuffle iterate-next ;
+
+M: #>r emit-node
+    [ in-d>> length ] [ out-r>> empty? ] bi
+    [ neg ##inc-d ] [ ds-load rs-store ] if
+    iterate-next ;
+
+M: #r> emit-node
+    [ in-r>> length ] [ out-d>> empty? ] bi
+    [ neg ##inc-r ] [ rs-load ds-store ] if
+    iterate-next ;
+
+! #return
+M: #return emit-node
+    drop ##epilogue ##return stop-iterating ;
+
+M: #return-recursive emit-node
+    label>> id>> loops get key?
+    [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
+
+! #terminate
+M: #terminate emit-node drop stop-iterating ;
+
+! FFI
+: return-size ( ctype -- n )
+    #! Amount of space we reserve for a return value.
+    {
+        { [ dup c-struct? not ] [ drop 0 ] }
+        { [ dup large-struct? not ] [ drop 2 cells ] }
+        [ heap-size ]
+    } cond ;
+
+: <alien-stack-frame> ( params -- stack-frame )
+    stack-frame new
+        swap
+        [ return>> return-size >>return ]
+        [ alien-parameters parameter-sizes drop >>params ] bi ;
+
+: alien-stack-frame ( params -- )
+    <alien-stack-frame> ##stack-frame ;
+
+: emit-alien-node ( node quot -- next )
+    [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
+    begin-basic-block iterate-next ; inline
+
+M: #alien-invoke emit-node
+    [ ##alien-invoke ] emit-alien-node ;
+
+M: #alien-indirect emit-node
+    [ ##alien-indirect ] emit-alien-node ;
+
+M: #alien-callback emit-node
+    dup params>> xt>> dup
+    [
+        ##prologue
+        dup [ ##alien-callback ] emit-alien-node drop
+        ##epilogue
+        params>> ##callback-return
+    ] with-cfg-builder
+    iterate-next ;
+
+! No-op nodes
+M: #introduce emit-node drop iterate-next ;
+
+M: #copy emit-node drop iterate-next ;
+
+M: #enter-recursive emit-node drop iterate-next ;
+
+M: #phi emit-node drop iterate-next ;

basis/compiler/cfg/cfg.factor

@@ -1,25 +1,27 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sequences sets fry ;
+USING: kernel arrays vectors accessors namespaces ;
 IN: compiler.cfg
 
-TUPLE: cfg entry word label ;
-
-C: <cfg> cfg
-
-! - "number" and "visited" is used by linearization.
 TUPLE: basic-block < identity-tuple
-visited
+id
 number
-instructions
+{ instructions vector }
-successors ;
+{ successors vector }
+{ predecessors vector } ;
 
 : <basic-block> ( -- basic-block )
     basic-block new
         V{ } clone >>instructions
-        V{ } clone >>successors ;
+        V{ } clone >>successors
+        V{ } clone >>predecessors
+        \ basic-block counter >>id ;
 
-TUPLE: mr instructions word label ;
+TUPLE: cfg { entry basic-block } word label ;
+
+C: <cfg> cfg
+
+TUPLE: mr { instructions array } word label spill-counts ;
 
 : <mr> ( instructions word label -- mr )
     mr new

basis/compiler/cfg/copy-prop/copy-prop.factor

@@ -0,0 +1,12 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors ;
+IN: compiler.cfg.copy-prop
+
+SYMBOL: copies
+
+: resolve ( vreg -- vreg )
+    dup copies get at swap or ;
+
+: record-copy ( insn -- )
+    [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline

basis/compiler/cfg/dead-code/dead-code-tests.factor

@@ -0,0 +1,8 @@
+USING: compiler.cfg.dead-code compiler.cfg.instructions
+compiler.cfg.registers cpu.architecture tools.test ;
+IN: compiler.cfg.dead-code.tests
+
+[ { } ] [
+    { T{ ##load-immediate f V int-regs 134 16 } }
+    eliminate-dead-code
+] unit-test

basis/compiler/cfg/dead-code/dead-code.factor

@@ -0,0 +1,61 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sets kernel namespaces sequences
+compiler.cfg.instructions compiler.cfg.def-use ;
+IN: compiler.cfg.dead-code
+
+! Dead code elimination -- assumes compiler.cfg.alias-analysis
+! has already run.
+
+! Maps vregs to sequences of vregs
+SYMBOL: liveness-graph
+
+! vregs which participate in side effects and thus are always live
+SYMBOL: live-vregs
+
+! mapping vregs to stack locations
+SYMBOL: vregs>locs
+
+: init-dead-code ( -- )
+    H{ } clone liveness-graph set
+    H{ } clone live-vregs set
+    H{ } clone vregs>locs set ;
+
+GENERIC: compute-liveness ( insn -- )
+
+M: ##flushable compute-liveness
+    [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
+
+M: ##peek compute-liveness
+    [ [ loc>> ] [ dst>> ] bi vregs>locs get set-at ]
+    [ call-next-method ]
+    bi ;
+
+: live-replace? ( ##replace -- ? )
+    [ src>> vregs>locs get at ] [ loc>> ] bi = not ;
+
+M: ##replace compute-liveness
+    dup live-replace? [ call-next-method ] [ drop ] if ;
+
+: record-live ( vregs -- )
+    [
+        dup live-vregs get key? [ drop ] [
+            [ live-vregs get conjoin ]
+            [ liveness-graph get at record-live ]
+            bi
+        ] if
+    ] each ;
+
+M: insn compute-liveness uses-vregs record-live ;
+
+GENERIC: live-insn? ( insn -- ? )
+
+M: ##flushable live-insn? dst>> live-vregs get key? ;
+
+M: ##replace live-insn? live-replace? ;
+
+M: insn live-insn? drop t ;
+
+: eliminate-dead-code ( insns -- insns' )
+    init-dead-code
+    [ [ compute-liveness ] each ] [ [ live-insn? ] filter ] bi ;

basis/compiler/cfg/debugger/debugger.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel words sequences quotations namespaces io
+classes.tuple accessors prettyprint prettyprint.config
+compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.linearization
+compiler.cfg.stack-frame compiler.cfg.linear-scan
+compiler.cfg.two-operand compiler.cfg.optimizer ;
+IN: compiler.cfg.debugger
+
+GENERIC: test-cfg ( quot -- cfgs )
+
+M: callable test-cfg
+    build-tree optimize-tree gensym build-cfg ;
+
+M: word test-cfg
+    [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
+
+SYMBOL: allocate-registers?
+
+: test-mr ( quot -- mrs )
+    test-cfg [
+        optimize-cfg
+        build-mr
+        convert-two-operand
+        allocate-registers? get
+        [ linear-scan build-stack-frame ] when
+    ] map ;
+
+: insn. ( insn -- )
+    tuple>array allocate-registers? get [ but-last ] unless
+    [ pprint bl ] each nl ;
+
+: mr. ( mrs -- )
+    [
+        "=== word: " write
+        dup word>> pprint
+        ", label: " write
+        dup label>> pprint nl nl
+        instructions>> [ insn. ] each
+        nl
+    ] each ;

basis/compiler/cfg/def-use/def-use.factor

@@ -0,0 +1,44 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel compiler.cfg.instructions ;
+IN: compiler.cfg.def-use
+
+GENERIC: defs-vregs ( insn -- seq )
+GENERIC: uses-vregs ( insn -- seq )
+
+: dst/tmp-vregs ( insn -- seq ) [ dst>> ] [ temp>> ] bi 2array ;
+M: ##flushable defs-vregs dst>> 1array ;
+M: ##write-barrier defs-vregs [ card#>> ] [ table>> ] bi 2array ;
+M: ##unary/temp defs-vregs dst/tmp-vregs ;
+M: ##allot defs-vregs dst/tmp-vregs ;
+M: ##dispatch defs-vregs temp>> 1array ;
+M: ##slot defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
+M: ##set-slot defs-vregs temp>> 1array ;
+M: insn defs-vregs drop f ;
+
+M: ##unary uses-vregs src>> 1array ;
+M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: ##binary-imm uses-vregs src1>> 1array ;
+M: ##effect uses-vregs src>> 1array ;
+M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
+M: ##slot-imm uses-vregs obj>> 1array ;
+M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
+M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
+M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: ##compare-imm-branch uses-vregs src1>> 1array ;
+M: ##dispatch uses-vregs src>> 1array ;
+M: ##alien-getter uses-vregs src>> 1array ;
+M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
+M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
+M: _compare-imm-branch uses-vregs src1>> 1array ;
+M: insn uses-vregs drop f ;
+
+UNION: vreg-insn
+##flushable
+##write-barrier
+##dispatch
+##effect
+##conditional-branch
+##compare-imm-branch
+_conditional-branch
+_compare-imm-branch ;

basis/compiler/cfg/hats/hats.factor

@@ -0,0 +1,72 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays kernel layouts math namespaces
+sequences classes.tuple cpu.architecture compiler.cfg.registers
+compiler.cfg.instructions ;
+IN: compiler.cfg.hats
+
+: i int-regs next-vreg ; inline
+: ^^i i dup ; inline
+: ^^i1 [ ^^i ] dip ; inline
+: ^^i2 [ ^^i ] 2dip ; inline
+: ^^i3 [ ^^i ] 3dip ; inline
+
+: d double-float-regs next-vreg ; inline
+: ^^d d dup ; inline
+: ^^d1 [ ^^d ] dip ; inline
+: ^^d2 [ ^^d ] 2dip ; inline
+: ^^d3 [ ^^d ] 3dip ; inline
+
+: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
+: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
+: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
+: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
+: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
+: ^^add ( src1 src2 -- dst ) ^^i2 ##add ; inline
+: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
+: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
+: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
+: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
+: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
+: ^^and ( input mask -- output ) ^^i2 ##and ; inline
+: ^^and-imm ( input mask -- output ) ^^i2 ##and-imm ; inline
+: ^^or ( src1 src2 -- dst ) ^^i2 ##or ; inline
+: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
+: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
+: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
+: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
+: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
+: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
+: ^^not ( src -- dst ) ^^i1 ##not ; inline
+: ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
+: ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
+: ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline
+: ^^sub-float ( src1 src2 -- dst ) ^^d2 ##sub-float ; inline
+: ^^mul-float ( src1 src2 -- dst ) ^^d2 ##mul-float ; inline
+: ^^div-float ( src1 src2 -- dst ) ^^d2 ##div-float ; inline
+: ^^float>integer ( src -- dst ) ^^i1 ##float>integer ; inline
+: ^^integer>float ( src -- dst ) ^^d1 ##integer>float ; inline
+: ^^allot ( size class -- dst ) ^^i2 i ##allot ; inline
+: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
+: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
+: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
+: ^^box-float ( src -- dst ) ^^i1 i ##box-float ; inline
+: ^^unbox-float ( src -- dst ) ^^d1 ##unbox-float ; inline
+: ^^box-alien ( src -- dst ) ^^i1 i ##box-alien ; inline
+: ^^unbox-alien ( src -- dst ) ^^i1 ##unbox-alien ; inline
+: ^^unbox-c-ptr ( src class -- dst ) ^^i2 i ##unbox-c-ptr ;
+: ^^alien-unsigned-1 ( src -- dst ) ^^i1 ##alien-unsigned-1 ; inline
+: ^^alien-unsigned-2 ( src -- dst ) ^^i1 ##alien-unsigned-2 ; inline
+: ^^alien-unsigned-4 ( src -- dst ) ^^i1 ##alien-unsigned-4 ; inline
+: ^^alien-signed-1 ( src -- dst ) ^^i1 ##alien-signed-1 ; inline
+: ^^alien-signed-2 ( src -- dst ) ^^i1 ##alien-signed-2 ; inline
+: ^^alien-signed-4 ( src -- dst ) ^^i1 ##alien-signed-4 ; inline
+: ^^alien-cell ( src -- dst ) ^^i1 ##alien-cell ; inline
+: ^^alien-float ( src -- dst ) ^^d1 ##alien-float ; inline
+: ^^alien-double ( src -- dst ) ^^d1 ##alien-double ; inline
+: ^^compare ( src1 src2 cc -- dst ) ^^i3 ##compare ; inline
+: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 ##compare-imm ; inline
+: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 ##compare-float ; inline
+: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
+: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
+: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline

basis/compiler/cfg/height/height.factor

@@ -0,0 +1,51 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math namespaces sequences kernel fry
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions ;
+IN: compiler.cfg.height
+
+! Combine multiple stack height changes into one at the
+! start of the basic block.
+
+SYMBOL: ds-height
+SYMBOL: rs-height
+
+GENERIC: compute-heights ( insn -- )
+
+M: ##inc-d compute-heights n>> ds-height [ + ] change ;
+M: ##inc-r compute-heights n>> rs-height [ + ] change ;
+M: insn compute-heights drop ;
+
+GENERIC: normalize-height* ( insn -- insn' )
+
+: normalize-inc-d/r ( insn stack -- insn' )
+    swap n>> '[ _ - ] change f ; inline
+
+M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
+M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
+
+GENERIC: loc-stack ( loc -- stack )
+
+M: ds-loc loc-stack drop ds-height ;
+M: rs-loc loc-stack drop rs-height ;
+
+GENERIC: <loc> ( n stack -- loc )
+
+M: ds-loc <loc> drop <ds-loc> ;
+M: rs-loc <loc> drop <rs-loc> ;
+
+: normalize-peek/replace ( insn -- insn' )
+    [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
+
+M: ##peek normalize-height* normalize-peek/replace ;
+M: ##replace normalize-height* normalize-peek/replace ;
+
+M: insn normalize-height* ;
+
+: normalize-height ( insns -- insns' )
+    0 ds-height set
+    0 rs-height set
+    [ [ compute-heights ] each ]
+    [ [ [ normalize-height* ] map sift ] with-scope ] bi
+    ds-height get dup zero? [ drop ] [ f \ ##inc-d boa prefix ] if
+    rs-height get dup zero? [ drop ] [ f \ ##inc-r boa prefix ] if ;

basis/compiler/cfg/instructions/instructions.factor

@@ -0,0 +1,225 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors arrays kernel sequences namespaces words
+math math.order layouts classes.algebra alien byte-arrays
+compiler.constants combinators compiler.cfg.registers
+compiler.cfg.instructions.syntax ;
+IN: compiler.cfg.instructions
+
+! Virtual CPU instructions, used by CFG and machine IRs
+TUPLE: insn ;
+
+! Instruction with no side effects; if 'out' is never read, we
+! can eliminate it.
+TUPLE: ##flushable < insn { dst vreg } ;
+
+! Instruction which is referentially transparent; we can replace
+! repeated computation with a reference to a previous value
+TUPLE: ##pure < ##flushable ;
+
+TUPLE: ##unary < ##pure { src vreg } ;
+TUPLE: ##unary/temp < ##unary { temp vreg } ;
+TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ;
+TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ;
+TUPLE: ##commutative < ##binary ;
+TUPLE: ##commutative-imm < ##binary-imm ;
+
+! Instruction only used for its side effect, produces no values
+TUPLE: ##effect < insn { src vreg } ;
+
+! Read/write ops: candidates for alias analysis
+TUPLE: ##read < ##flushable ;
+TUPLE: ##write < ##effect ;
+
+TUPLE: ##alien-getter < ##flushable { src vreg } ;
+TUPLE: ##alien-setter < ##effect { value vreg } ;
+
+! Stack operations
+INSN: ##load-immediate < ##pure { val integer } ;
+INSN: ##load-indirect < ##pure obj ;
+
+GENERIC: ##load-literal ( dst value -- )
+
+M: fixnum ##load-literal tag-fixnum ##load-immediate ;
+M: f ##load-literal drop \ f tag-number ##load-immediate ;
+M: object ##load-literal ##load-indirect ;
+
+INSN: ##peek < ##read { loc loc } ;
+INSN: ##replace < ##write { loc loc } ;
+INSN: ##inc-d { n integer } ;
+INSN: ##inc-r { n integer } ;
+
+! Subroutine calls
+TUPLE: stack-frame
+{ params integer }
+{ return integer }
+{ total-size integer }
+spill-counts ;
+
+INSN: ##stack-frame stack-frame ;
+INSN: ##call word ;
+INSN: ##jump word ;
+INSN: ##return ;
+
+! Jump tables
+INSN: ##dispatch src temp ;
+INSN: ##dispatch-label label ;
+
+! Slot access
+INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
+INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
+INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
+INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
+
+! Integer arithmetic
+INSN: ##add < ##commutative ;
+INSN: ##add-imm < ##commutative-imm ;
+INSN: ##sub < ##binary ;
+INSN: ##sub-imm < ##binary-imm ;
+INSN: ##mul < ##commutative ;
+INSN: ##mul-imm < ##commutative-imm ;
+INSN: ##and < ##commutative ;
+INSN: ##and-imm < ##commutative-imm ;
+INSN: ##or < ##commutative ;
+INSN: ##or-imm < ##commutative-imm ;
+INSN: ##xor < ##commutative ;
+INSN: ##xor-imm < ##commutative-imm ;
+INSN: ##shl-imm < ##binary-imm ;
+INSN: ##shr-imm < ##binary-imm ;
+INSN: ##sar-imm < ##binary-imm ;
+INSN: ##not < ##unary ;
+
+: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
+: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
+
+! Bignum/integer conversion
+INSN: ##integer>bignum < ##unary/temp ;
+INSN: ##bignum>integer < ##unary/temp ;
+
+! Float arithmetic
+INSN: ##add-float < ##commutative ;
+INSN: ##sub-float < ##binary ;
+INSN: ##mul-float < ##commutative ;
+INSN: ##div-float < ##binary ;
+
+! Float/integer conversion
+INSN: ##float>integer < ##unary ;
+INSN: ##integer>float < ##unary ;
+
+! Boxing and unboxing
+INSN: ##copy < ##unary ;
+INSN: ##copy-float < ##unary ;
+INSN: ##unbox-float < ##unary ;
+INSN: ##unbox-any-c-ptr < ##unary/temp ;
+INSN: ##box-float < ##unary/temp ;
+INSN: ##box-alien < ##unary/temp ;
+
+: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
+: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
+: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ;
+
+: ##unbox-c-ptr ( dst src class temp -- )
+    {
+        { [ over \ f class<= ] [ 2drop ##unbox-f ] }
+        { [ over simple-alien class<= ] [ 2drop ##unbox-alien ] }
+        { [ over byte-array class<= ] [ 2drop ##unbox-byte-array ] }
+        [ nip ##unbox-any-c-ptr ]
+    } cond ;
+
+! Alien accessors
+INSN: ##alien-unsigned-1 < ##alien-getter ;
+INSN: ##alien-unsigned-2 < ##alien-getter ;
+INSN: ##alien-unsigned-4 < ##alien-getter ;
+INSN: ##alien-signed-1 < ##alien-getter ;
+INSN: ##alien-signed-2 < ##alien-getter ;
+INSN: ##alien-signed-4 < ##alien-getter ;
+INSN: ##alien-cell < ##alien-getter ;
+INSN: ##alien-float < ##alien-getter ;
+INSN: ##alien-double < ##alien-getter ;
+
+INSN: ##set-alien-integer-1 < ##alien-setter ;
+INSN: ##set-alien-integer-2 < ##alien-setter ;
+INSN: ##set-alien-integer-4 < ##alien-setter ;
+INSN: ##set-alien-cell < ##alien-setter ;
+INSN: ##set-alien-float < ##alien-setter ;
+INSN: ##set-alien-double < ##alien-setter ;
+
+! Memory allocation
+INSN: ##allot < ##flushable size class { temp vreg } ;
+INSN: ##write-barrier < ##effect card# table ;
+
+! FFI
+INSN: ##alien-invoke params ;
+INSN: ##alien-indirect params ;
+INSN: ##alien-callback params ;
+INSN: ##callback-return params ;
+
+! Instructions used by CFG IR only.
+INSN: ##prologue ;
+INSN: ##epilogue ;
+
+INSN: ##branch ;
+
+INSN: ##loop-entry ;
+
+! Condition codes
+SYMBOL: cc<
+SYMBOL: cc<=
+SYMBOL: cc=
+SYMBOL: cc>
+SYMBOL: cc>=
+SYMBOL: cc/=
+
+: negate-cc ( cc -- cc' )
+    H{
+        { cc< cc>= }
+        { cc<= cc> }
+        { cc> cc<= }
+        { cc>= cc< }
+        { cc= cc/= }
+        { cc/= cc= }
+    } at ;
+
+: evaluate-cc ( result cc -- ? )
+    H{
+        { cc<  { +lt+           } }
+        { cc<= { +lt+ +eq+      } }
+        { cc=  {      +eq+      } }
+        { cc>= {      +eq+ +gt+ } }
+        { cc>  {           +gt+ } }
+        { cc/= { +lt+      +gt+ } }
+    } at memq? ;
+
+TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
+
+INSN: ##compare-branch < ##conditional-branch ;
+INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
+
+INSN: ##compare < ##binary cc ;
+INSN: ##compare-imm < ##binary-imm cc ;
+
+INSN: ##compare-float-branch < ##conditional-branch ;
+INSN: ##compare-float < ##binary cc ;
+
+! Instructions used by machine IR only.
+INSN: _prologue stack-frame ;
+INSN: _epilogue stack-frame ;
+
+INSN: _label id ;
+
+INSN: _gc ;
+
+INSN: _branch label ;
+
+TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
+
+INSN: _compare-branch < _conditional-branch ;
+INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
+
+INSN: _compare-float-branch < _conditional-branch ;
+
+! These instructions operate on machine registers and not
+! virtual registers
+INSN: _spill src class n ;
+INSN: _reload dst class n ;
+INSN: _spill-counts counts ;

basis/compiler/cfg/instructions/syntax/syntax.factor

@@ -4,11 +4,15 @@ USING: classes.tuple classes.tuple.parser kernel words
 make fry sequences parser ;
 IN: compiler.cfg.instructions.syntax
 
-TUPLE: insn ;
+: insn-word ( -- word )
+    #! We want to put the insn tuple in compiler.cfg.instructions,
+    #! but we cannot have circularity between that vocabulary and
+    #! this one.
+    "insn" "compiler.cfg.instructions" lookup ;
 
 : INSN:
     parse-tuple-definition "regs" suffix
-    [ dup tuple eq? [ drop insn ] when ] dip
+    [ dup tuple eq? [ drop insn-word ] when ] dip
     [ define-tuple-class ]
     [ 2drop save-location ]
     [ 2drop dup '[ f _ boa , ] define-inline ]

basis/compiler/cfg/intrinsics/alien/alien.factor

@@ -0,0 +1,108 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences alien math classes.algebra
+fry locals combinators cpu.architecture
+compiler.tree.propagation.info
+compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
+compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.alien
+
+: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
+    ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
+
+: (prepare-alien-accessor) ( class -- offset-vreg )
+    [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+
+: prepare-alien-accessor ( infos -- offset-vreg )
+    <reversed> [ second class>> ] [ first ] bi
+    dup value-info-small-tagged? [
+        literal>> (prepare-alien-accessor-imm)
+    ] [ drop (prepare-alien-accessor) ] if ;
+
+:: inline-alien ( node quot test -- )
+    [let | infos [ node node-input-infos ] |
+        infos test call
+        [ infos prepare-alien-accessor quot call ]
+        [ node emit-primitive ]
+        if
+    ] ; inline
+
+: inline-alien-getter? ( infos -- ? )
+    [ first class>> c-ptr class<= ]
+    [ second class>> fixnum class<= ]
+    bi and ;
+
+: inline-alien-getter ( node quot -- )
+    '[ @ ds-push ]
+    [ inline-alien-getter? ] inline-alien ; inline
+
+: inline-alien-setter? ( infos class -- ? )
+    '[ first class>> _ class<= ]
+    [ second class>> c-ptr class<= ]
+    [ third class>> fixnum class<= ]
+    tri and and ;
+
+: inline-alien-integer-setter ( node quot -- )
+    '[ ds-pop ^^untag-fixnum @ ]
+    [ fixnum inline-alien-setter? ]
+    inline-alien ; inline
+
+: inline-alien-cell-setter ( node quot -- )
+    [ dup node-input-infos first class>> ] dip
+    '[ ds-pop _ ^^unbox-c-ptr @ ]
+    [ pinned-c-ptr inline-alien-setter? ]
+    inline-alien ; inline
+
+: inline-alien-float-setter ( node quot -- )
+    '[ ds-pop ^^unbox-float @ ]
+    [ float inline-alien-setter? ]
+    inline-alien ; inline
+
+: emit-alien-unsigned-getter ( node n -- )
+    '[
+        _ {
+            { 1 [ ^^alien-unsigned-1 ] }
+            { 2 [ ^^alien-unsigned-2 ] }
+            { 4 [ ^^alien-unsigned-4 ] }
+        } case ^^tag-fixnum
+    ] inline-alien-getter ;
+
+: emit-alien-signed-getter ( node n -- )
+    '[
+        _ {
+            { 1 [ ^^alien-signed-1 ] }
+            { 2 [ ^^alien-signed-2 ] }
+            { 4 [ ^^alien-signed-4 ] }
+        } case ^^tag-fixnum
+    ] inline-alien-getter ;
+
+: emit-alien-integer-setter ( node n -- )
+    '[
+        _ {
+            { 1 [ ##set-alien-integer-1 ] }
+            { 2 [ ##set-alien-integer-2 ] }
+            { 4 [ ##set-alien-integer-4 ] }
+        } case
+    ] inline-alien-integer-setter ;
+
+: emit-alien-cell-getter ( node -- )
+    [ ^^alien-cell ^^box-alien ] inline-alien-getter ;
+
+: emit-alien-cell-setter ( node -- )
+    [ ##set-alien-cell ] inline-alien-cell-setter ;
+
+: emit-alien-float-getter ( node reg-class -- )
+    '[
+        _ {
+            { single-float-regs [ ^^alien-float ] }
+            { double-float-regs [ ^^alien-double ] }
+        } case ^^box-float
+    ] inline-alien-getter ;
+
+: emit-alien-float-setter ( node reg-class -- )
+    '[
+        _ {
+            { single-float-regs [ ##set-alien-float ] }
+            { double-float-regs [ ##set-alien-double ] }
+        } case
+    ] inline-alien-float-setter ;

basis/compiler/cfg/intrinsics/allot/allot.factor

@@ -0,0 +1,68 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.order sequences accessors arrays
+byte-arrays layouts classes.tuple.private fry locals
+compiler.tree.propagation.info compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.stacks
+compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.allot
+
+: ##set-slots ( regs obj class -- )
+    '[ _ swap 1+ _ tag-number ##set-slot-imm ] each-index ;
+
+: emit-simple-allot ( node -- )
+    [ in-d>> length ] [ node-output-infos first class>> ] bi
+    [ drop ds-load ] [ [ 1+ cells ] dip ^^allot ] [ nip ] 2tri
+    [ ##set-slots ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
+
+: tuple-slot-regs ( layout -- vregs )
+    [ size>> ds-load ] [ ^^load-literal ] bi prefix ;
+
+: emit-<tuple-boa> ( node -- )
+    dup node-input-infos peek literal>>
+    dup tuple-layout? [
+        nip
+        ds-drop
+        [ tuple-slot-regs ] [ size>> ^^allot-tuple ] bi
+        [ tuple ##set-slots ] [ ds-push drop ] 2bi
+    ] [ drop emit-primitive ] if ;
+
+: store-length ( len reg -- )
+    [ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
+
+: store-initial-element ( elt reg len -- )
+    [ 2 + object tag-number ##set-slot-imm ] with with each ;
+
+: expand-<array>? ( obj -- ? )
+    dup integer? [ 0 8 between? ] [ drop f ] if ;
+
+:: emit-<array> ( node -- )
+    [let | len [ node node-input-infos first literal>> ] |
+        len expand-<array>? [
+            [let | elt [ ds-pop ]
+                   reg [ len ^^allot-array ] |
+                ds-drop
+                len reg store-length
+                elt reg len store-initial-element
+                reg ds-push
+            ]
+        ] [ node emit-primitive ] if
+    ] ;
+
+: expand-<byte-array>? ( obj -- ? )
+    dup integer? [ 0 32 between? ] [ drop f ] if ;
+
+: bytes>cells ( m -- n ) cell align cell /i ;
+
+:: emit-<byte-array> ( node -- )
+    [let | len [ node node-input-infos first literal>> ] |
+        len expand-<byte-array>? [
+            [let | elt [ 0 ^^load-literal ]
+                   reg [ len ^^allot-byte-array ] |
+                ds-drop
+                len reg store-length
+                elt reg len bytes>cells store-initial-element
+                reg ds-push
+            ]
+        ] [ node emit-primitive ] if
+    ] ;

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -0,0 +1,63 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences accessors layouts kernel math namespaces
+combinators fry locals
+compiler.tree.propagation.info
+compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.fixnum
+
+: (emit-fixnum-imm-op) ( infos insn -- dst )
+    ds-drop
+    [ ds-pop ] [ second literal>> tag-fixnum ] [ ] tri*
+    call ; inline
+
+: (emit-fixnum-op) ( insn -- dst )
+    [ 2inputs ] dip call ; inline
+
+:: emit-fixnum-op ( node insn imm-insn -- )
+    [let | infos [ node node-input-infos ] |
+        infos second value-info-small-tagged?
+        [ infos imm-insn (emit-fixnum-imm-op) ]
+        [ insn (emit-fixnum-op) ]
+        if
+        ds-push
+    ] ; inline
+
+: emit-fixnum-shift-fast ( node -- )
+    dup node-input-infos dup second value-info-small-tagged? [
+        nip
+        [ ds-drop ds-pop ] dip
+        second literal>> dup sgn {
+            { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
+            {  0 [ drop ] }
+            {  1 [ ^^shl-imm ] }
+        } case
+        ds-push
+    ] [ drop emit-primitive ] if ;
+
+: emit-fixnum-bitnot ( -- )
+    ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
+
+: (emit-fixnum*fast) ( -- dst )
+    2inputs ^^untag-fixnum ^^mul ;
+
+: (emit-fixnum*fast-imm) ( infos -- dst )
+    ds-drop
+    [ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
+
+: emit-fixnum*fast ( node -- )
+    node-input-infos
+    dup second value-info-small-tagged?
+    [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
+    ds-push ;
+
+: emit-fixnum-comparison ( node cc -- )
+    [ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
+    emit-fixnum-op ;
+
+: emit-bignum>fixnum ( -- )
+    ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
+
+: emit-fixnum>bignum ( -- )
+    ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;

basis/compiler/cfg/intrinsics/float/float.factor

@@ -0,0 +1,19 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel compiler.cfg.stacks compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.float
+
+: emit-float-op ( insn -- )
+    [ 2inputs [ ^^unbox-float ] bi@ ] dip call ^^box-float
+    ds-push ; inline
+
+: emit-float-comparison ( cc -- )
+    [ 2inputs [ ^^unbox-float ] bi@ ] dip ^^compare-float
+    ds-push ; inline
+
+: emit-float>fixnum ( -- )
+    ds-pop ^^unbox-float ^^float>integer ^^tag-fixnum ds-push ;
+
+: emit-fixnum>float ( -- )
+    ds-pop ^^untag-fixnum ^^integer>float ^^box-float ds-push ;

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -0,0 +1,141 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: qualified words sequences kernel combinators
+cpu.architecture
+compiler.cfg.hats
+compiler.cfg.instructions
+compiler.cfg.intrinsics.alien
+compiler.cfg.intrinsics.allot
+compiler.cfg.intrinsics.fixnum
+compiler.cfg.intrinsics.float
+compiler.cfg.intrinsics.slots ;
+QUALIFIED: kernel
+QUALIFIED: arrays
+QUALIFIED: byte-arrays
+QUALIFIED: kernel.private
+QUALIFIED: slots.private
+QUALIFIED: classes.tuple.private
+QUALIFIED: math.private
+QUALIFIED: alien.accessors
+IN: compiler.cfg.intrinsics
+
+{
+    kernel.private:tag
+    math.private:fixnum+fast
+    math.private:fixnum-fast
+    math.private:fixnum-bitand
+    math.private:fixnum-bitor 
+    math.private:fixnum-bitxor
+    math.private:fixnum-shift-fast
+    math.private:fixnum-bitnot
+    math.private:fixnum*fast
+    math.private:fixnum< 
+    math.private:fixnum<=
+    math.private:fixnum>=
+    math.private:fixnum>
+    math.private:bignum>fixnum
+    math.private:fixnum>bignum
+    kernel:eq?
+    slots.private:slot
+    slots.private:set-slot
+    classes.tuple.private:<tuple-boa>
+    arrays:<array>
+    byte-arrays:<byte-array>
+    math.private:<complex>
+    math.private:<ratio>
+    kernel:<wrapper>
+    alien.accessors:alien-unsigned-1
+    alien.accessors:set-alien-unsigned-1
+    alien.accessors:alien-signed-1
+    alien.accessors:set-alien-signed-1
+    alien.accessors:alien-unsigned-2
+    alien.accessors:set-alien-unsigned-2
+    alien.accessors:alien-signed-2
+    alien.accessors:set-alien-signed-2
+    alien.accessors:alien-cell
+    alien.accessors:set-alien-cell
+} [ t "intrinsic" set-word-prop ] each
+
+: enable-alien-4-intrinsics ( -- )
+    {
+        alien.accessors:alien-unsigned-4
+        alien.accessors:set-alien-unsigned-4
+        alien.accessors:alien-signed-4
+        alien.accessors:set-alien-signed-4
+    } [ t "intrinsic" set-word-prop ] each ;
+
+: enable-float-intrinsics ( -- )
+    {
+        math.private:float+
+        math.private:float-
+        math.private:float*
+        math.private:float/f
+        math.private:fixnum>float
+        math.private:float>fixnum
+        math.private:float<
+        math.private:float<=
+        math.private:float>
+        math.private:float>=
+        math.private:float=
+        alien.accessors:alien-float
+        alien.accessors:set-alien-float
+        alien.accessors:alien-double
+        alien.accessors:set-alien-double
+    } [ t "intrinsic" set-word-prop ] each ;
+
+: emit-intrinsic ( node word -- )
+    {
+        { \ kernel.private:tag [ drop emit-tag ] }
+        { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op ] }
+        { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
+        { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+        { \ math.private:fixnum*fast [ emit-fixnum*fast ] }
+        { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] }
+        { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] }
+        { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] }
+        { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] }
+        { \ kernel:eq? [ cc= emit-fixnum-comparison ] }
+        { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
+        { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
+        { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+        { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+        { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+        { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+        { \ math.private:float< [ drop cc< emit-float-comparison ] }
+        { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
+        { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
+        { \ math.private:float> [ drop cc> emit-float-comparison ] }
+        { \ math.private:float= [ drop cc= emit-float-comparison ] }
+        { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
+        { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
+        { \ slots.private:slot [ emit-slot ] }
+        { \ slots.private:set-slot [ emit-set-slot ] }
+        { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
+        { \ arrays:<array> [ emit-<array> ] }
+        { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
+        { \ math.private:<complex> [ emit-simple-allot ] }
+        { \ math.private:<ratio> [ emit-simple-allot ] }
+        { \ kernel:<wrapper> [ emit-simple-allot ] }
+        { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+        { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+        { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+        { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+        { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+        { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
+        { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
+        { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
+    } case ;

basis/compiler/cfg/intrinsics/slots/slots.factor

@@ -0,0 +1,53 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: layouts namespaces kernel accessors sequences
+classes.algebra compiler.tree.propagation.info
+compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.utilities ;
+IN: compiler.cfg.intrinsics.slots
+
+: emit-tag ( -- )
+    ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
+
+: value-tag ( info -- n ) class>> class-tag ; inline
+
+: (emit-slot) ( infos -- dst )
+    [ 2inputs ^^offset>slot ] [ first value-tag ] bi*
+    ^^slot ;
+
+: (emit-slot-imm) ( infos -- dst )
+    ds-drop
+    [ ds-pop ]
+    [ [ second literal>> ] [ first value-tag ] bi ] bi*
+    ^^slot-imm ;
+
+: emit-slot ( node -- )
+    dup node-input-infos
+    dup first value-tag [
+        nip
+        dup second value-info-small-tagged?
+        [ (emit-slot-imm) ] [ (emit-slot) ] if
+        ds-push
+    ] [ drop emit-primitive ] if ;
+
+: (emit-set-slot) ( infos -- obj-reg )
+    [ 3inputs [ tuck ] dip ^^offset>slot ]
+    [ second value-tag ]
+    bi* ^^set-slot ;
+
+: (emit-set-slot-imm) ( infos -- obj-reg )
+    ds-drop
+    [ 2inputs tuck ]
+    [ [ third literal>> ] [ second value-tag ] bi ] bi*
+    ##set-slot-imm ;
+
+: emit-set-slot ( node -- )
+    dup node-input-infos
+    dup second value-tag [
+        nip
+        [
+            dup third value-info-small-tagged?
+            [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
+        ] [ first class>> immediate class<= ] bi
+        [ drop ] [ i i ##write-barrier ] if
+    ] [ drop emit-primitive ] if ;

basis/compiler/cfg/iterator/iterator.factor

@@ -19,9 +19,6 @@ SYMBOL: node-stack
         [ swap >node call node> drop ] keep iterate-nodes
     ] if ; inline recursive
 
-: with-node-iterator ( quot -- )
-    >r V{ } clone node-stack r> with-variable ; inline
-
 DEFER: (tail-call?)
 
 : tail-phi? ( cursor -- ? )

basis/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -1,10 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences math math.order kernel assocs
-accessors vectors fry heaps
+accessors vectors fry heaps cpu.architecture combinators
 compiler.cfg.registers
-compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.live-intervals ;
-compiler.backend ;
 IN: compiler.cfg.linear-scan.allocation
 
 ! Mapping from register classes to sequences of machine registers
@@ -19,24 +18,22 @@ SYMBOL: free-registers
 ! Vector of active live intervals
 SYMBOL: active-intervals
 
+: active-intervals-for ( vreg -- seq )
+    reg-class>> active-intervals get at ;
+
 : add-active ( live-interval -- )
-    active-intervals get push ;
+    dup vreg>> active-intervals-for push ;
 
 : delete-active ( live-interval -- )
-    active-intervals get delete ;
+    dup vreg>> active-intervals-for delq ;
 
 : expire-old-intervals ( n -- )
-    active-intervals get
+    active-intervals swap '[
-    swap '[ end>> _ < ] partition
+        [
-    active-intervals set
+            [ end>> _ < ] partition
-    [ deallocate-register ] each ;
+            [ [ deallocate-register ] each ] dip
-
+        ] assoc-map
-: expire-old-uses ( n -- )
+    ] change ;
-    active-intervals get
-    swap '[ uses>> dup peek _ < [ pop* ] [ drop ] if ] each ;
-
-: update-state ( live-interval -- )
-    start>> [ expire-old-intervals ] [ expire-old-uses ] bi ;
 
 ! Minheap of live intervals which still need a register allocation
 SYMBOL: unhandled-intervals
@@ -59,14 +56,39 @@ SYMBOL: progress
     [ [ start>> ] keep ] { } map>assoc
     unhandled-intervals get heap-push-all ;
 
-: assign-free-register ( live-interval registers -- )
+! Coalescing
-    #! If the live interval does not have any uses, it means it
+: active-interval ( vreg -- live-interval )
-    #! will be spilled immediately, so it still needs a register
+    dup active-intervals-for [ vreg>> = ] with find nip ;
-    #! to compute the new value, but we don't add the interval
+
-    #! to the active set and we don't remove the register from
+: coalesce? ( live-interval -- ? )
-    #! the free list.
+    [ start>> ] [ copy-from>> ] bi
-    over uses>> empty?
+    dup [ active-interval end>> = ] [ 2drop f ] if ;
-    [ peek >>reg drop ] [ pop >>reg add-active ] if ;
+
+: coalesce ( live-interval -- )
+    dup copy-from>> active-interval
+    [ [ add-active ] [ delete-active ] bi* ]
+    [ reg>> >>reg drop ]
+    2bi ;
+
+! Splitting
+: find-use ( live-interval n quot -- i elt )
+    [ uses>> ] 2dip curry find ; inline
+
+: split-before ( live-interval i -- before )
+    [ clone dup uses>> ] dip
+    [ head >>uses ] [ 1- swap nth >>end ] 2bi ;
+
+: split-after ( live-interval i -- after )
+    [ clone dup uses>> ] dip
+    [ tail >>uses ] [ swap nth >>start ] 2bi
+    f >>reg f >>copy-from ;
+
+: split-interval ( live-interval n -- before after )
+    [ drop ] [ [ > ] find-use drop ] 2bi
+    [ split-before ] [ split-after ] 2bi ;
+
+: record-split ( live-interval before after -- )
+    [ >>split-before ] [ >>split-after ] bi* drop ;
 
 ! Spilling
 SYMBOL: spill-counts
@@ -74,37 +96,23 @@ SYMBOL: spill-counts
 : next-spill-location ( reg-class -- n )
     spill-counts get [ dup 1+ ] change-at ;
 
-: interval-to-spill ( -- live-interval )
+: interval-to-spill ( active-intervals current -- live-interval )
     #! We spill the interval with the most distant use location.
-    active-intervals get unclip-slice [
+    start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
-        [ [ uses>> peek ] bi@ > ] most
+    unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
-    ] reduce ;
-
-: check-split ( live-interval -- )
-    [ start>> ] [ end>> ] bi = [ "Cannot split any further" throw ] when ;
-
-: split-interval ( live-interval -- before after )
-    #! Split the live interval at the location of its first use.
-    #! 'Before' now starts and ends on the same instruction.
-    [ check-split ]
-    [ clone [ uses>> delete-all ] [ dup start>> >>end ] bi ]
-    [ clone f >>reg dup uses>> peek >>start ]
-    tri ;
-
-: record-split ( live-interval before after -- )
-    [ >>split-before ] [ >>split-after ] bi* drop ;
 
 : assign-spill ( before after -- before after )
     #! If it has been spilled already, reuse spill location.
-    over reload-from>> [ next-spill-location ] unless*
+    over reload-from>>
+    [ over vreg>> reg-class>> next-spill-location ] unless*
     tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
 
-: split-and-spill ( live-interval -- before after )
+: split-and-spill ( new existing -- before after )
-    dup split-interval [ record-split ] [ assign-spill ] 2bi ;
+    dup rot start>> split-interval
+    [ record-split ] [ assign-spill ] 2bi ;
 
 : reuse-register ( new existing -- )
-    reg>> >>reg
+    reg>> >>reg add-active ;
-    dup uses>> empty? [ deallocate-register ] [ add-active ] if ;
 
 : spill-existing ( new existing -- )
     #! Our new interval will be used before the active interval
@@ -112,41 +120,52 @@ SYMBOL: spill-counts
     #! interval, then process the new interval and the tail end
     #! of the existing interval again.
     [ reuse-register ]
-    [ delete-active ]
+    [ nip delete-active ]
-    [ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ;
+    [ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
 
 : spill-new ( new existing -- )
     #! Our new interval will be used after the active interval
     #! with the most distant use location. Split the new
     #! interval, then process both parts of the new interval
     #! again.
-    [ split-and-spill add-unhandled ] dip spill-existing ;
+    [ dup split-and-spill add-unhandled ] dip spill-existing ;
 
 : spill-existing? ( new existing -- ? )
-    over uses>> empty? [ 2drop t ] [ [ uses>> peek ] bi@ < ] if ;
+    #! Test if 'new' will be used before 'existing'.
+    over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
 
-: assign-blocked-register ( live-interval -- )
+: assign-blocked-register ( new -- )
-    interval-to-spill
+    [ dup vreg>> active-intervals-for ] keep interval-to-spill
-    2dup spill-existing?
+    2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
-    [ spill-existing ] [ spill-new ] if ;
 
-: assign-register ( live-interval -- )
+: assign-free-register ( new registers -- )
-    dup vreg>> free-registers-for [
+    pop >>reg add-active ;
-        assign-blocked-register
+
+: assign-register ( new -- )
+    dup coalesce? [
+        coalesce
     ] [
-        assign-free-register
+        dup vreg>> free-registers-for
-    ] if-empty ;
+        [ assign-blocked-register ]
+        [ assign-free-register ]
+        if-empty
+    ] if ;
 
 ! Main loop
+: reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
+
 : init-allocator ( registers -- )
-    V{ } clone active-intervals set
     <min-heap> unhandled-intervals set
     [ reverse >vector ] assoc-map free-registers set
-    H{ { int-regs 0 } { double-float-regs 0 } } clone spill-counts set
+    reg-classes [ 0 ] { } map>assoc spill-counts set
+    reg-classes [ V{ } clone ] { } map>assoc active-intervals set
     -1 progress set ;
 
 : handle-interval ( live-interval -- )
-    [ start>> progress set ] [ update-state ] [ assign-register ] tri ;
+    [ start>> progress set ]
+    [ start>> expire-old-intervals ]
+    [ assign-register ]
+    tri ;
 
 : (allocate-registers) ( -- )
     unhandled-intervals get [ handle-interval ] slurp-heap ;

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -2,6 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math assocs namespaces sequences heaps
 fry make combinators
+cpu.architecture
+compiler.cfg.def-use
 compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.linear-scan.live-intervals ;
@@ -34,13 +36,8 @@ SYMBOL: unhandled-intervals
     [ add-unhandled ] each ;
 
 : insert-spill ( live-interval -- )
-    [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri
+    [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri
-    over [
+    dup [ _spill ] [ 3drop ] if ;
-        {
-            { int-regs [ _spill-integer ] }
-            { double-float-regs [ _spill-float ] }
-        } case
-    ] [ 3drop ] if ;
 
 : expire-old-intervals ( n -- )
     active-intervals get
@@ -49,13 +46,8 @@ SYMBOL: unhandled-intervals
     [ insert-spill ] each ;
 
 : insert-reload ( live-interval -- )
-    [ reg>> ] [ reload-from>> ] [ vreg>> reg-class>> ] tri
+    [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri
-    over [
+    dup [ _reload ] [ 3drop ] if ;
-        {
-            { int-regs [ _reload-integer ] }
-            { double-float-regs [ _reload-float ] }
-        } case
-    ] [ 3drop ] if ;
 
 : activate-new-intervals ( n -- )
     #! Any live intervals which start on the current instruction
@@ -67,13 +59,17 @@ SYMBOL: unhandled-intervals
         ] [ 2drop ] if
     ] if ;
 
-: (assign-registers) ( insn -- )
+GENERIC: (assign-registers) ( insn -- )
+
+M: vreg-insn (assign-registers)
     dup
     [ defs-vregs ] [ uses-vregs ] bi append
     active-intervals get swap '[ vreg>> _ member? ] filter
     [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc
     >>regs drop ;
 
+M: insn (assign-registers) drop ;
+
 : init-assignment ( live-intervals -- )
     V{ } clone active-intervals set
     <min-heap> unhandled-intervals set

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -0,0 +1,357 @@
+IN: compiler.cfg.linear-scan.tests
+USING: tools.test random sorting sequences sets hashtables assocs
+kernel fry arrays splitting namespaces math accessors vectors
+math.order
+cpu.architecture
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.linear-scan
+compiler.cfg.linear-scan.live-intervals
+compiler.cfg.linear-scan.allocation
+compiler.cfg.linear-scan.debugger ;
+
+[ 7 ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+        { start 0 }
+        { end 10 }
+        { uses V{ 0 1 3 7 10 } }
+    }
+    4 [ >= ] find-use nip
+] unit-test
+
+[ 4 ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+        { start 0 }
+        { end 10 }
+        { uses V{ 0 1 3 4 10 } }
+    }
+    4 [ >= ] find-use nip
+] unit-test
+
+[ f ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+        { start 0 }
+        { end 10 }
+        { uses V{ 0 1 3 4 10 } }
+    }
+    100 [ >= ] find-use nip
+] unit-test
+
+[
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 0 }
+        { end 1 }
+        { uses V{ 0 1 } }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 5 }
+        { end 5 }
+        { uses V{ 5 } }
+    }
+] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 0 }
+        { end 5 }
+        { uses V{ 0 1 5 } }
+    } 2 split-interval
+] unit-test
+
+[
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 0 }
+        { end 0 }
+        { uses V{ 0 } }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 1 }
+        { end 5 }
+        { uses V{ 1 5 } }
+    }
+] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 0 }
+        { end 5 }
+        { uses V{ 0 1 5 } }
+    } 0 split-interval
+] unit-test
+
+[
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 3 }
+        { end 10 }
+        { uses V{ 3 10 } }
+    }
+] [
+    {
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+            { start 1 }
+            { end 15 }
+            { uses V{ 1 3 7 10 15 } }
+        }
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+            { start 3 }
+            { end 8 }
+            { uses V{ 3 4 8 } }
+        }
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+            { start 3 }
+            { end 10 }
+            { uses V{ 3 10 } }
+        }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 5 }
+        { end 5 }
+        { uses V{ 5 } }
+    }
+    interval-to-spill
+] unit-test
+
+[ t ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 5 }
+        { end 15 }
+        { uses V{ 5 10 15 } }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 1 }
+        { end 20 }
+        { uses V{ 1 20 } }
+    }
+    spill-existing?
+] unit-test
+
+[ f ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 5 }
+        { end 15 }
+        { uses V{ 5 10 15 } }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 1 }
+        { end 20 }
+        { uses V{ 1 7 20 } }
+    }
+    spill-existing?
+] unit-test
+
+[ t ] [
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 5 }
+        { end 5 }
+        { uses V{ 5 } }
+    }
+    T{ live-interval
+        { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+        { start 1 }
+        { end 20 }
+        { uses V{ 1 7 20 } }
+    }
+    spill-existing?
+] unit-test
+
+[ ] [
+    {
+        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+    }
+    H{ { int-regs { "A" } } }
+    check-linear-scan
+] unit-test
+
+[ ] [
+    {
+        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 10 } { uses V{ 0 10 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 11 } { end 20 } { uses V{ 11 20 } } }
+    }
+    H{ { int-regs { "A" } } }
+    check-linear-scan
+] unit-test
+
+[ ] [
+    {
+        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 60 } { uses V{ 30 60 } } }
+    }
+    H{ { int-regs { "A" } } }
+    check-linear-scan
+] unit-test
+
+[ ] [
+    {
+        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 200 } { uses V{ 30 200 } } }
+    }
+    H{ { int-regs { "A" } } }
+    check-linear-scan
+] unit-test
+
+[
+    {
+        T{ live-interval { vreg T{ vreg { n 1 } { reg-class int-regs } } } { start 0 } { end 100 } { uses V{ 0 100 } } }
+        T{ live-interval { vreg T{ vreg { n 2 } { reg-class int-regs } } } { start 30 } { end 100 } { uses V{ 30 100 } } }
+    }
+    H{ { int-regs { "A" } } }
+    check-linear-scan
+] must-fail
+
+SYMBOL: available
+
+SYMBOL: taken
+
+SYMBOL: max-registers
+
+SYMBOL: max-insns
+
+SYMBOL: max-uses
+
+: not-taken ( -- n )
+    available get keys dup empty? [ "Oops" throw ] when
+    random
+    dup taken get nth 1 + max-registers get = [
+        dup available get delete-at
+    ] [
+        dup taken get [ 1 + ] change-nth
+    ] if ;
+
+: random-live-intervals ( num-intervals max-uses max-registers max-insns -- seq )
+    [
+        max-insns set
+        max-registers set
+        max-uses set
+        max-insns get [ 0 ] replicate taken set
+        max-insns get [ dup ] H{ } map>assoc available set
+        [
+            live-interval new
+                swap int-regs swap vreg boa >>vreg
+                max-uses get random 2 max [ not-taken ] replicate natural-sort
+                [ >>uses ] [ first >>start ] bi
+                dup uses>> peek >>end
+        ] map
+    ] with-scope ;
+
+: random-test ( num-intervals max-uses max-registers max-insns -- )
+    over >r random-live-intervals r> int-regs associate check-linear-scan ;
+
+[ ] [ 30 2 1 60 random-test ] unit-test
+[ ] [ 60 2 2 60 random-test ] unit-test
+[ ] [ 80 2 3 200 random-test ] unit-test
+[ ] [ 70 2 5 30 random-test ] unit-test
+[ ] [ 60 2 6 30 random-test ] unit-test
+[ ] [ 1 2 10 10 random-test ] unit-test
+
+[ ] [ 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
+
+[ f ] [
+    T{ ##allot
+        f
+        T{ vreg f int-regs 1 }
+        40
+        array
+        T{ vreg f int-regs 2 }
+        f
+    } clone
+    1array (linear-scan) first regs>> values all-equal?
+] unit-test
+
+[ 0 1 ] [
+    {
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+            { start 0 }
+            { end 5 }
+            { uses V{ 0 1 5 } }
+        }
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+            { start 3 }
+            { end 4 }
+            { uses V{ 3 4 } }
+        }
+        T{ live-interval
+            { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+            { start 2 }
+            { end 6 }
+            { uses V{ 2 4 6 } }
+        }
+    } [ clone ] map
+    H{ { int-regs { "A" "B" } } }
+    allocate-registers
+    first split-before>> [ start>> ] [ end>> ] bi
+] unit-test
+
+! Coalescing interacted badly with splitting
+[ ] [
+    {
+        T{ live-interval
+            { vreg V int-regs 70 }
+            { start 14 }
+            { end 17 }
+            { uses V{ 14 15 16 17 } }
+            { copy-from V int-regs 67 }
+        }
+        T{ live-interval
+            { vreg V int-regs 67 }
+            { start 13 }
+            { end 14 }
+            { uses V{ 13 14 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 30 }
+            { start 4 }
+            { end 18 }
+            { uses V{ 4 12 16 17 18 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 27 }
+            { start 3 }
+            { end 13 }
+            { uses V{ 3 7 13 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 59 }
+            { start 10 }
+            { end 18 }
+            { uses V{ 10 11 12 18 } }
+            { copy-from V int-regs 56 }
+        }
+        T{ live-interval
+            { vreg V int-regs 60 }
+            { start 12 }
+            { end 17 }
+            { uses V{ 12 17 } }
+        }
+        T{ live-interval
+            { vreg V int-regs 56 }
+            { start 9 }
+            { end 10 }
+            { uses V{ 9 10 } }
+        }
+    }
+    { { int-regs { 0 1 2 3 } } }
+    allocate-registers drop
+] unit-test

basis/compiler/cfg/linear-scan/linear-scan.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces
+USING: kernel accessors namespaces make
-compiler.backend
+cpu.architecture
 compiler.cfg
+compiler.cfg.instructions
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation
 compiler.cfg.linear-scan.assignment ;
@@ -22,12 +23,16 @@ IN: compiler.cfg.linear-scan
 ! by Omri Traub, Glenn Holloway, Michael D. Smith
 ! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
 
+: (linear-scan) ( insns -- insns' )
+    dup compute-live-intervals
+    machine-registers allocate-registers assign-registers ;
+
 : linear-scan ( mr -- mr' )
     [
         [
-            dup compute-live-intervals
+            [
-            machine-registers allocate-registers
+                (linear-scan) %
-            assign-registers
+                spill-counts get _spill-counts
+            ] { } make
         ] change-instructions
-        spill-counts get >>spill-counts
     ] with-scope ;

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

@@ -0,0 +1,64 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces kernel assocs accessors sequences math fry
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.def-use ;
+IN: compiler.cfg.linear-scan.live-intervals
+
+TUPLE: live-interval
+vreg
+reg spill-to reload-from split-before split-after
+start end uses
+copy-from ;
+
+: add-use ( n live-interval -- )
+    dup live-interval? [ "No def" throw ] unless
+    [ (>>end) ] [ uses>> push ] 2bi ;
+
+: <live-interval> ( start vreg -- live-interval )
+    live-interval new
+        V{ } clone >>uses
+        swap >>vreg
+        over >>start
+        [ add-use ] keep ;
+
+M: live-interval hashcode*
+    nip [ start>> ] [ end>> 1000 * ] bi + ;
+
+M: live-interval clone
+    call-next-method [ clone ] change-uses ;
+
+! Mapping from vreg to live-interval
+SYMBOL: live-intervals
+
+: new-live-interval ( n vreg live-intervals -- )
+    2dup key? [
+        at add-use
+    ] [
+        [ [ <live-interval> ] keep ] dip set-at
+    ] if ;
+
+GENERIC# compute-live-intervals* 1 ( insn n -- )
+
+M: insn compute-live-intervals* 2drop ;
+
+M: vreg-insn compute-live-intervals*
+    live-intervals get
+    [ [ uses-vregs ] 2dip '[ _ swap _ at add-use ] each ]
+    [ [ defs-vregs ] 2dip '[ _ swap _ new-live-interval ] each ]
+    3bi ;
+
+: record-copy ( insn -- )
+    [ dst>> live-intervals get at ] [ src>> ] bi >>copy-from drop ;
+
+M: ##copy compute-live-intervals*
+    [ call-next-method ] [ drop record-copy ] 2bi ;
+
+M: ##copy-float compute-live-intervals*
+    [ call-next-method ] [ drop record-copy ] 2bi ;
+
+: compute-live-intervals ( instructions -- live-intervals )
+    H{ } clone [
+        live-intervals set
+        [ compute-live-intervals* ] each-index
+    ] keep values ;

basis/compiler/cfg/linearization/linearization-tests.factor

@@ -0,0 +1,4 @@
+IN: compiler.cfg.linearization.tests
+USING: compiler.cfg.linearization tools.test ;
+
+\ build-mr must-infer

basis/compiler/cfg/linearization/linearization.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math accessors sequences namespaces make
-combinators
+combinators classes
 compiler.cfg
 compiler.cfg.rpo
-compiler.cfg.instructions
+compiler.cfg.instructions ;
-compiler.cfg.instructions.syntax ;
 IN: compiler.cfg.linearization
 
 ! Convert CFG IR to machine IR.
@@ -19,7 +18,7 @@ M: insn linearize-insn , drop ;
 : useless-branch? ( basic-block successor -- ? )
     #! If our successor immediately follows us in RPO, then we
     #! don't need to branch.
-    [ number>> 1+ ] [ number>> ] bi* = ; inline
+    [ number>> ] bi@ 1- = ; inline
 
 : branch-to-return? ( successor -- ? )
     #! A branch to a block containing just a return is cloned.
@@ -37,27 +36,39 @@ M: insn linearize-insn , drop ;
 M: ##branch linearize-insn
     drop dup successors>> first emit-branch ;
 
-: conditional ( basic-block -- basic-block successor1 label2 )
+: (binary-conditional)
-    dup successors>> first2 swap number>> ; inline
+    [ dup successors>> first2 ]
+    [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
 
-: boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
+: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
-    [ conditional ] [ src>> ] bi* swap ; inline
+    [ (binary-conditional) ]
+    [ drop dup successors>> first useless-branch? ] 2bi
+    [ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
 
-M: ##branch-f linearize-insn
+M: ##compare-branch linearize-insn
-    boolean-conditional _branch-f emit-branch ;
+    binary-conditional _compare-branch emit-branch ;
 
-M: ##branch-t linearize-insn
+M: ##compare-imm-branch linearize-insn
-    boolean-conditional _branch-t emit-branch ;
+    binary-conditional _compare-imm-branch emit-branch ;
 
-: >intrinsic< ( insn -- quot defs uses )
+M: ##compare-float-branch linearize-insn
-    [ quot>> ] [ defs-vregs>> ] [ uses-vregs>> ] tri ;
+    binary-conditional _compare-float-branch emit-branch ;
 
-M: ##if-intrinsic linearize-insn
+: gc? ( bb -- ? )
-    [ conditional ] [ >intrinsic< ] bi*
+    instructions>> [
-    _if-intrinsic emit-branch ;
+        class {
+            ##allot
+            ##integer>bignum
+            ##box-float
+            ##box-alien
+        } memq?
+    ] contains? ;
 
 : linearize-basic-block ( bb -- )
-    [ number>> _label ] [ linearize-insns ] bi ;
+    [ number>> _label ]
+    [ gc? [ _gc ] when ]
+    [ linearize-insns ]
+    tri ;
 
 : linearize-basic-blocks ( rpo -- insns )
     [ [ linearize-basic-block ] each ] { } make ;

basis/compiler/cfg/optimizer/optimizer.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences compiler.cfg.rpo
+compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.useless-blocks
+compiler.cfg.height
+compiler.cfg.alias-analysis
+compiler.cfg.value-numbering
+compiler.cfg.dead-code
+compiler.cfg.write-barrier ;
+IN: compiler.cfg.optimizer
+
+: trivial? ( insns -- ? )
+    dup length 2 = [ first ##call? ] [ drop f ] if ;
+
+: optimize-cfg ( cfg -- cfg' )
+    compute-predecessors
+    delete-useless-blocks
+    delete-useless-conditionals
+    [
+        dup trivial? [
+            normalize-height
+            alias-analysis
+            value-numbering
+            eliminate-dead-code
+            eliminate-write-barriers
+        ] unless
+    ] change-basic-blocks ;

basis/compiler/cfg/predecessors/predecessors.factor

@@ -0,0 +1,10 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences compiler.cfg.rpo ;
+IN: compiler.cfg.predecessors
+
+: (compute-predecessors) ( bb -- )
+    dup successors>> [ predecessors>> push ] with each ;
+
+: compute-predecessors ( cfg -- cfg' )
+    dup [ (compute-predecessors) ] each-basic-block ;

basis/compiler/cfg/registers/registers.factor

@@ -0,0 +1,37 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors namespaces kernel arrays
+parser prettyprint.backend prettyprint.sections ;
+IN: compiler.cfg.registers
+
+! Virtual registers, used by CFG and machine IRs
+TUPLE: vreg { reg-class read-only } { n read-only } ;
+SYMBOL: vreg-counter
+: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
+
+! Stack locations
+TUPLE: loc { n read-only } ;
+
+TUPLE: ds-loc < loc ;
+C: <ds-loc> ds-loc
+
+TUPLE: rs-loc < loc ;
+C: <rs-loc> rs-loc
+
+! Prettyprinting
+: V scan-word scan-word vreg boa parsed ; parsing
+
+M: vreg pprint*
+    <block
+    \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
+    block> ;
+
+: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
+
+: D scan-word <ds-loc> parsed ; parsing
+
+M: ds-loc pprint* \ D pprint-loc ;
+
+: R scan-word <rs-loc> parsed ; parsing
+
+M: rs-loc pprint* \ R pprint-loc ;

basis/compiler/cfg/rpo/rpo.factor

@@ -0,0 +1,32 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces make math sequences sets
+assocs fry compiler.cfg.instructions ;
+IN: compiler.cfg.rpo
+
+SYMBOL: visited
+
+: post-order-traversal ( bb -- )
+    dup id>> visited get key? [ drop ] [
+        dup id>> visited get conjoin
+        [ successors>> [ post-order-traversal ] each ] [ , ] bi
+    ] if ;
+
+: post-order ( bb -- blocks )
+    [ post-order-traversal ] { } make ;
+
+: number-blocks ( blocks -- )
+    [ >>number drop ] each-index ;
+
+: reverse-post-order ( bb -- blocks )
+    H{ } clone visited [
+        post-order <reversed> dup number-blocks
+    ] with-variable ; inline
+
+: each-basic-block ( cfg quot -- )
+    [ entry>> reverse-post-order ] dip each ; inline
+
+: change-basic-blocks ( cfg quot -- cfg' )
+    [ '[ _ change-instructions drop ] each-basic-block ]
+    [ drop ]
+    2bi ; inline

basis/compiler/cfg/stack-frame/stack-frame.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces accessors math.order assocs kernel sequences
-make compiler.cfg.instructions compiler.cfg.instructions.syntax
+combinators make cpu.architecture compiler.cfg.instructions
 compiler.cfg.registers ;
 IN: compiler.cfg.stack-frame
 
@@ -9,35 +9,37 @@ SYMBOL: frame-required?
 
 SYMBOL: spill-counts
 
-: init-stack-frame-builder ( -- )
-    frame-required? off
-    T{ stack-frame } clone stack-frame set ;
-
 GENERIC: compute-stack-frame* ( insn -- )
 
 : max-stack-frame ( frame1 frame2 -- frame3 )
-    {
+    [ stack-frame new ] 2dip
-        [ [ size>> ] bi@ max ]
+        [ [ params>> ] bi@ max >>params ]
-        [ [ params>> ] bi@ max ]
+        [ [ return>> ] bi@ max >>return ]
-        [ [ return>> ] bi@ max ]
+        2bi ;
-        [ [ total-size>> ] bi@ max ]
-    } cleave
-    stack-frame boa ;
 
 M: ##stack-frame compute-stack-frame*
     frame-required? on
     stack-frame>> stack-frame [ max-stack-frame ] change ;
 
-M: _spill-integer compute-stack-frame*
+M: ##call compute-stack-frame*
+    word>> sub-primitive>> [ frame-required? on ] unless ;
+
+M: _gc compute-stack-frame*
     drop frame-required? on ;
 
-M: _spill-float compute-stack-frame*
+M: _spill compute-stack-frame*
     drop frame-required? on ;
 
+M: _spill-counts compute-stack-frame*
+    counts>> stack-frame get (>>spill-counts) ;
+
 M: insn compute-stack-frame* drop ;
 
 : compute-stack-frame ( insns -- )
-    [ compute-stack-frame* ] each ;
+    frame-required? off
+    T{ stack-frame } clone stack-frame set
+    [ compute-stack-frame* ] each
+    stack-frame get dup stack-frame-size >>total-size drop ;
 
 GENERIC: insert-pro/epilogues* ( insn -- )
 
@@ -56,7 +58,6 @@ M: insn insert-pro/epilogues* , ;
 
 : build-stack-frame ( mr -- mr )
     [
-        init-stack-frame-builder
         [
             [ compute-stack-frame ]
             [ insert-pro/epilogues ]

basis/compiler/cfg/stacks/stacks.factor

@@ -0,0 +1,33 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math sequences kernel cpu.architecture
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.hats ;
+IN: compiler.cfg.stacks
+
+: ds-drop ( -- )
+    -1 ##inc-d ;
+
+: ds-pop ( -- vreg )
+    D 0 ^^peek -1 ##inc-d ;
+
+: ds-push ( vreg -- )
+    1 ##inc-d D 0 ##replace ;
+
+: ds-load ( n -- vregs )
+    [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ;
+
+: ds-store ( vregs -- )
+    <reversed> [ length ##inc-d ] [ [ <ds-loc> ##replace ] each-index ] bi ;
+
+: rs-load ( n -- vregs )
+    [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ;
+
+: rs-store ( vregs -- )
+    <reversed> [ length ##inc-r ] [ [ <rs-loc> ##replace ] each-index ] bi ;
+
+: 2inputs ( -- vreg1 vreg2 )
+    D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
+
+: 3inputs ( -- vreg1 vreg2 vreg3 )
+    D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;

basis/compiler/cfg/two-operand/two-operand.factor

@@ -0,0 +1,60 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel sequences sequences.deep
+compiler.cfg.instructions cpu.architecture ;
+IN: compiler.cfg.two-operand
+
+! On x86, instructions take the form x = x op y
+! Our SSA IR is x = y op z
+
+! We don't bother with ##add, ##add-imm or ##sub-imm since x86
+! has a LEA instruction which is effectively a three-operand
+! addition
+
+: make-copy ( dst src -- insn ) f \ ##copy boa ; inline
+
+: make-copy/float ( dst src -- insn ) f \ ##copy-float boa ; inline
+
+: convert-two-operand/integer ( insn -- insns )
+    [ [ dst>> ] [ src1>> ] bi make-copy ]
+    [ dup dst>> >>src1 ]
+    bi 2array ; inline
+
+: convert-two-operand/float ( insn -- insns )
+    [ [ dst>> ] [ src1>> ] bi make-copy/float ]
+    [ dup dst>> >>src1 ]
+    bi 2array ; inline
+
+GENERIC: convert-two-operand* ( insn -- insns )
+
+M: ##not convert-two-operand*
+    [ [ dst>> ] [ src>> ] bi make-copy ]
+    [ dup dst>> >>src ]
+    bi 2array ;
+
+M: ##sub convert-two-operand* convert-two-operand/integer ;
+M: ##mul convert-two-operand* convert-two-operand/integer ;
+M: ##mul-imm convert-two-operand* convert-two-operand/integer ;
+M: ##and convert-two-operand* convert-two-operand/integer ;
+M: ##and-imm convert-two-operand* convert-two-operand/integer ;
+M: ##or convert-two-operand* convert-two-operand/integer ;
+M: ##or-imm convert-two-operand* convert-two-operand/integer ;
+M: ##xor convert-two-operand* convert-two-operand/integer ;
+M: ##xor-imm convert-two-operand* convert-two-operand/integer ;
+M: ##shl-imm convert-two-operand* convert-two-operand/integer ;
+M: ##shr-imm convert-two-operand* convert-two-operand/integer ;
+M: ##sar-imm convert-two-operand* convert-two-operand/integer ;
+
+M: ##add-float convert-two-operand* convert-two-operand/float ;
+M: ##sub-float convert-two-operand* convert-two-operand/float ;
+M: ##mul-float convert-two-operand* convert-two-operand/float ;
+M: ##div-float convert-two-operand* convert-two-operand/float ;
+
+M: insn convert-two-operand* ;
+
+: convert-two-operand ( mr -- mr' )
+    [
+        two-operand? [
+            [ convert-two-operand* ] map flatten
+        ] when
+    ] change-instructions ;

basis/compiler/cfg/useless-blocks/useless-blocks.factor

@@ -0,0 +1,55 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences combinators classes vectors
+compiler.cfg compiler.cfg.rpo compiler.cfg.instructions ;
+IN: compiler.cfg.useless-blocks
+
+: update-predecessor-for-delete ( bb -- )
+    dup predecessors>> first [
+        [
+            2dup eq? [ drop successors>> first ] [ nip ] if
+        ] with map
+    ] change-successors drop ;
+
+: update-successor-for-delete ( bb -- )
+    [ predecessors>> first ]
+    [ successors>> first predecessors>> ]
+    bi set-first ;
+
+: delete-basic-block ( bb -- )
+    [ update-predecessor-for-delete ]
+    [ update-successor-for-delete ]
+    bi ;
+
+: delete-basic-block? ( bb -- ? )
+    {
+        { [ dup instructions>> length 1 = not ] [ f ] }
+        { [ dup predecessors>> length 1 = not ] [ f ] }
+        { [ dup successors>> length 1 = not ] [ f ] }
+        { [ dup instructions>> first ##branch? not ] [ f ] }
+        [ t ]
+    } cond nip ;
+
+: delete-useless-blocks ( cfg -- cfg' )
+    dup [
+        dup delete-basic-block? [ delete-basic-block ] [ drop ] if
+    ] each-basic-block ;
+
+: delete-conditional? ( bb -- ? )
+    dup instructions>> [ drop f ] [
+        peek class {
+            ##compare-branch
+            ##compare-imm-branch
+            ##compare-float-branch
+        } memq? [ successors>> first2 eq? ] [ drop f ] if
+    ] if-empty ;
+
+: delete-conditional ( bb -- )
+    dup successors>> first 1vector >>successors
+    [ but-last f \ ##branch boa suffix ] change-instructions
+    drop ;
+
+: delete-useless-conditionals ( cfg -- cfg' )
+    dup [
+        dup delete-conditional? [ delete-conditional ] [ drop ] if
+    ] each-basic-block ;

basis/compiler/cfg/utilities/utilities.factor

@@ -0,0 +1,25 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math layouts make sequences
+cpu.architecture namespaces compiler.cfg
+compiler.cfg.instructions ;
+IN: compiler.cfg.utilities
+
+: value-info-small-tagged? ( value-info -- ? )
+    literal>> dup fixnum? [ tag-fixnum small-enough? ] [ drop f ] if ;
+
+: set-basic-block ( basic-block -- )
+    [ basic-block set ] [ instructions>> building set ] bi ;
+
+: begin-basic-block ( -- )
+    <basic-block> basic-block get [
+        dupd successors>> push
+    ] when*
+    set-basic-block ;
+
+: end-basic-block ( -- )
+    building off
+    basic-block off ;
+
+: emit-primitive ( node -- )
+    word>> ##call ##branch begin-basic-block ;

basis/compiler/cfg/value-numbering/expressions/expressions.factor

@@ -0,0 +1,88 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes kernel math namespaces combinators
+compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
+IN: compiler.cfg.value-numbering.expressions
+
+! Referentially-transparent expressions
+TUPLE: expr op ;
+TUPLE: unary-expr < expr in ;
+TUPLE: binary-expr < expr in1 in2 ;
+TUPLE: commutative-expr < binary-expr ;
+TUPLE: compare-expr < binary-expr cc ;
+TUPLE: constant-expr < expr value ;
+
+: <constant> ( constant -- expr )
+    f swap constant-expr boa ; inline
+
+M: constant-expr equal?
+    over constant-expr? [
+        [ [ value>> ] bi@ = ]
+        [ [ value>> class ] bi@ = ] 2bi
+        and
+    ] [ 2drop f ] if ;
+
+SYMBOL: input-expr-counter
+
+: next-input-expr ( -- n )
+    input-expr-counter [ dup 1 + ] change ;
+
+! Expressions whose values are inputs to the basic block. We
+! can eliminate a second computation having the same 'n' as
+! the first one; we can also eliminate input-exprs whose
+! result is not used.
+TUPLE: input-expr < expr n ;
+
+: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
+
+GENERIC: >expr ( insn -- expr )
+
+M: ##load-immediate >expr val>> <constant> ;
+
+M: ##load-indirect >expr obj>> <constant> ;
+
+M: ##unary >expr
+    [ class ] [ src>> vreg>vn ] bi unary-expr boa ;
+
+M: ##binary >expr
+    [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
+    binary-expr boa ;
+
+M: ##binary-imm >expr
+    [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
+    binary-expr boa ;
+
+M: ##commutative >expr
+    [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
+    commutative-expr boa ;
+
+M: ##commutative-imm >expr
+    [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
+    commutative-expr boa ;
+
+: compare>expr ( insn -- expr )
+    {
+        [ class ]
+        [ src1>> vreg>vn ]
+        [ src2>> vreg>vn ]
+        [ cc>> ]
+    } cleave compare-expr boa ; inline
+
+M: ##compare >expr compare>expr ;
+
+: compare-imm>expr ( insn -- expr )
+    {
+        [ class ]
+        [ src1>> vreg>vn ]
+        [ src2>> constant>vn ]
+        [ cc>> ]
+    } cleave compare-expr boa ; inline
+
+M: ##compare-imm >expr compare-imm>expr ;
+
+M: ##compare-float >expr compare>expr ;
+
+M: ##flushable >expr class next-input-expr input-expr boa ;
+
+: init-expressions ( -- )
+    0 input-expr-counter set ;

basis/compiler/cfg/value-numbering/graph/graph.factor

@@ -1,20 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces assocs biassocs accessors
+USING: accessors kernel math namespaces assocs biassocs ;
-math.order prettyprint.backend parser ;
+IN: compiler.cfg.value-numbering.graph
-IN: compiler.cfg.vn.graph
-
-TUPLE: vn n ;
 
 SYMBOL: vn-counter
 
-: next-vn ( -- vn ) vn-counter [ dup 1 + ] change vn boa ;
+: next-vn ( -- vn ) vn-counter [ dup 1 + ] change ;
-
-: VN: scan-word vn boa parsed ; parsing
-
-M: vn <=> [ n>> ] compare ;
-
-M: vn pprint* \ VN: pprint-word n>> pprint* ;
 
 ! biassoc mapping expressions to value numbers
 SYMBOL: exprs>vns
@@ -31,6 +22,10 @@ SYMBOL: vregs>vns
 
 : set-vn ( vn vreg -- ) vregs>vns get set-at ;
 
+: vreg>expr ( vreg -- expr ) vreg>vn vn>expr ; inline
+
+: vn>constant ( vn -- constant ) vn>expr value>> ; inline
+
 : init-value-graph ( -- )
     0 vn-counter set
     <bihash> exprs>vns set

basis/compiler/cfg/value-numbering/propagate/propagate.factor

@@ -0,0 +1,61 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs sequences kernel accessors
+compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
+IN: compiler.cfg.value-numbering.propagate
+
+! If two vregs compute the same value, replace references to
+! the latter with the former.
+
+: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline
+
+GENERIC: propagate ( insn -- insn )
+
+M: ##effect propagate
+    [ resolve ] change-src ;
+
+M: ##unary propagate
+    [ resolve ] change-src ;
+
+M: ##binary propagate
+    [ resolve ] change-src1
+    [ resolve ] change-src2 ;
+
+M: ##binary-imm propagate
+    [ resolve ] change-src1 ;
+
+M: ##slot propagate
+    [ resolve ] change-obj
+    [ resolve ] change-slot ;
+
+M: ##slot-imm propagate
+    [ resolve ] change-obj ;
+
+M: ##set-slot propagate
+    call-next-method
+    [ resolve ] change-obj
+    [ resolve ] change-slot ;
+
+M: ##set-slot-imm propagate
+    call-next-method
+    [ resolve ] change-obj ;
+
+M: ##alien-getter propagate
+    call-next-method
+    [ resolve ] change-src ;
+
+M: ##alien-setter propagate
+    call-next-method
+    [ resolve ] change-value ;
+
+M: ##conditional-branch propagate
+    [ resolve ] change-src1
+    [ resolve ] change-src2 ;
+
+M: ##compare-imm-branch propagate
+    [ resolve ] change-src1 ;
+
+M: ##dispatch propagate
+    [ resolve ] change-src ;
+
+M: insn propagate ;

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -0,0 +1,66 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences layouts accessors combinators namespaces
+math
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.simplify
+compiler.cfg.value-numbering.expressions ;
+IN: compiler.cfg.value-numbering.rewrite
+
+GENERIC: rewrite ( insn -- insn' )
+
+M: ##mul-imm rewrite
+    dup src2>> dup power-of-2? [
+        [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* f \ ##shl-imm boa
+        dup number-values
+    ] [ drop ] if ;
+
+: ##branch-t? ( insn -- ? )
+    dup ##compare-imm-branch? [
+        [ cc>> cc/= eq? ]
+        [ src2>> \ f tag-number eq? ] bi and
+    ] [ drop f ] if ; inline
+
+: rewrite-boolean-comparison? ( insn -- ? )
+    dup ##branch-t? [
+        src1>> vreg>expr compare-expr?
+    ] [ drop f ] if ; inline
+ 
+: >compare-expr< ( expr -- in1 in2 cc )
+    [ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
+
+: >compare-imm-expr< ( expr -- in1 in2 cc )
+    [ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
+
+: rewrite-boolean-comparison ( expr -- insn )
+    src1>> vreg>expr dup op>> {
+        { \ ##compare [ >compare-expr< f \ ##compare-branch boa ] }
+        { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm-branch boa ] }
+        { \ ##compare-float [ >compare-expr< f \ ##compare-float-branch boa ] }
+    } case ;
+
+: tag-fixnum-expr? ( expr -- ? )
+    dup op>> \ ##shl-imm eq?
+    [ in2>> vn>expr value>> tag-bits get = ] [ drop f ] if ;
+
+: rewrite-tagged-comparison? ( insn -- ? )
+    #! Are we comparing two tagged fixnums? Then untag them.
+    dup ##compare-imm-branch? [
+        [ src1>> vreg>expr tag-fixnum-expr? ]
+        [ src2>> tag-mask get bitand 0 = ]
+        bi and
+    ] [ drop f ] if ; inline
+
+: rewrite-tagged-comparison ( insn -- insn' )
+    [ src1>> vreg>expr in1>> vn>vreg ]
+    [ src2>> tag-bits get neg shift ]
+    [ cc>> ]
+    tri
+    f \ ##compare-imm-branch boa ;
+
+M: ##compare-imm-branch rewrite
+    dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
+    dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when ;
+
+M: insn rewrite ;

basis/compiler/cfg/value-numbering/simplify/simplify.factor

@@ -0,0 +1,74 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors combinators classes math layouts
+compiler.cfg.instructions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.expressions ;
+IN: compiler.cfg.value-numbering.simplify
+
+! Return value of f means we didn't simplify.
+GENERIC: simplify* ( expr -- vn/expr/f )
+
+: simplify-unbox ( in boxer -- vn/expr/f )
+    over op>> eq? [ in>> ] [ drop f ] if ; inline
+
+: simplify-unbox-float ( in -- vn/expr/f )
+    \ ##box-float simplify-unbox ; inline
+
+: simplify-unbox-alien ( in -- vn/expr/f )
+    \ ##box-alien simplify-unbox ; inline
+
+M: unary-expr simplify*
+    #! Note the copy propagation: a copy always simplifies to
+    #! its source VN.
+    [ in>> vn>expr ] [ op>> ] bi {
+        { \ ##copy [ ] }
+        { \ ##copy-float [ ] }
+        { \ ##unbox-float [ simplify-unbox-float ] }
+        { \ ##unbox-alien [ simplify-unbox-alien ] }
+        { \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
+        [ 2drop f ]
+    } case ;
+
+: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
+
+: >binary-expr< ( expr -- in1 in2 )
+    [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
+
+: simplify-add ( expr -- vn/expr/f )
+    >binary-expr< {
+        { [ over expr-zero? ] [ nip ] }
+        { [ dup expr-zero? ] [ drop ] }
+        [ 2drop f ]
+    } cond ; inline
+
+: useless-shift? ( in1 in2 -- ? )
+    over op>> \ ##shl-imm eq?
+    [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
+
+: simplify-shift ( expr -- vn/expr/f )
+    >binary-expr<
+    2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline
+
+M: binary-expr simplify*
+    dup op>> {
+        { \ ##add [ simplify-add ] }
+        { \ ##add-imm [ simplify-add ] }
+        { \ ##shr-imm [ simplify-shift ] }
+        { \ ##sar-imm [ simplify-shift ] }
+        [ 2drop f ]
+    } case ;
+
+M: expr simplify* drop f ;
+
+: simplify ( expr -- vn )
+    dup simplify* {
+        { [ dup not ] [ drop expr>vn ] }
+        { [ dup expr? ] [ expr>vn nip ] }
+        { [ dup integer? ] [ nip ] }
+    } cond ;
+
+GENERIC: number-values ( insn -- )
+
+M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ;
+M: insn number-values drop ;

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -0,0 +1,68 @@
+IN: compiler.cfg.value-numbering.tests
+USING: compiler.cfg.value-numbering compiler.cfg.instructions
+compiler.cfg.registers cpu.architecture tools.test kernel ;
+[
+    {
+        T{ ##peek f V int-regs 45 D 1 }
+        T{ ##copy f V int-regs 48 V int-regs 45 }
+        T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 45 D 1 }
+        T{ ##copy f V int-regs 48 V int-regs 45 }
+        T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
+    } value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 2 8 }
+        T{ ##peek f V int-regs 3 D 0 }
+        T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
+        T{ ##replace f V int-regs 4 D 0 }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 2 8 }
+        T{ ##peek f V int-regs 3 D 0 }
+        T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
+        T{ ##replace f V int-regs 4 D 0 }
+    } value-numbering
+] unit-test
+
+[ t ] [
+    {
+        T{ ##peek f V int-regs 1 D 0 }
+        T{ ##dispatch f V int-regs 1 V int-regs 2 }
+    } dup value-numbering =
+] unit-test
+
+[ t ] [
+    {
+        T{ ##peek f V int-regs 16 D 0 }
+        T{ ##peek f V int-regs 17 D -1 }
+        T{ ##sar-imm f V int-regs 18 V int-regs 17 3 }
+        T{ ##add-imm f V int-regs 19 V int-regs 16 13 }
+        T{ ##add f V int-regs 21 V int-regs 18 V int-regs 19 }
+        T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
+        T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
+        T{ ##replace f V int-regs 23 D 0 }
+    } dup value-numbering =
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 1 D 0 }
+        T{ ##shl-imm f V int-regs 2 V int-regs 1 3 }
+        T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
+        T{ ##replace f V int-regs 1 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 1 D 0 }
+        T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
+        T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
+        T{ ##replace f V int-regs 3 D 0 }
+    } value-numbering
+] unit-test

basis/compiler/cfg/value-numbering/value-numbering.factor

@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs biassocs classes kernel math accessors
+sorting sets sequences
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.propagate
+compiler.cfg.value-numbering.simplify
+compiler.cfg.value-numbering.rewrite ;
+IN: compiler.cfg.value-numbering
+
+: value-numbering ( insns -- insns' )
+    init-value-graph
+    init-expressions
+    [ [ number-values ] [ rewrite propagate ] bi ] map ;

basis/compiler/cfg/write-barrier/write-barrier-tests.factor

@@ -0,0 +1,72 @@
+USING: compiler.cfg.write-barrier compiler.cfg.instructions
+compiler.cfg.registers cpu.architecture arrays tools.test ;
+IN: compiler.cfg.write-barrier.tests
+
+[
+    {
+        T{ ##peek f V int-regs 4 D 0 f }
+        T{ ##copy f V int-regs 6 V int-regs 4 f }
+        T{ ##allot f V int-regs 7 24 array V int-regs 8 f }
+        T{ ##load-immediate f V int-regs 9 8 f }
+        T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f }
+        T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f }
+        T{ ##replace f V int-regs 7 D 0 f }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 4 D 0 }
+        T{ ##copy f V int-regs 6 V int-regs 4 }
+        T{ ##allot f V int-regs 7 24 array V int-regs 8 }
+        T{ ##load-immediate f V int-regs 9 8 }
+        T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 }
+        T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 }
+        T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
+        T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
+        T{ ##replace f V int-regs 7 D 0 }
+    } eliminate-write-barriers
+] unit-test
+
+[
+    {
+        T{ ##load-immediate f V int-regs 4 24 }
+        T{ ##peek f V int-regs 5 D -1 }
+        T{ ##peek f V int-regs 6 D -2 }
+        T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
+        T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+    }
+] [
+    {
+        T{ ##load-immediate f V int-regs 4 24 }
+        T{ ##peek f V int-regs 5 D -1 }
+        T{ ##peek f V int-regs 6 D -2 }
+        T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
+        T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+    } eliminate-write-barriers
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 19 D -3 }
+        T{ ##peek f V int-regs 22 D -2 }
+        T{ ##copy f V int-regs 23 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
+        T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
+        T{ ##copy f V int-regs 26 V int-regs 19 }
+        T{ ##peek f V int-regs 28 D -1 }
+        T{ ##copy f V int-regs 29 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 19 D -3 }
+        T{ ##peek f V int-regs 22 D -2 }
+        T{ ##copy f V int-regs 23 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
+        T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
+        T{ ##copy f V int-regs 26 V int-regs 19 }
+        T{ ##peek f V int-regs 28 D -1 }
+        T{ ##copy f V int-regs 29 V int-regs 19 }
+        T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
+        T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
+    } eliminate-write-barriers
+] unit-test

basis/compiler/cfg/write-barrier/write-barrier.factor

@@ -0,0 +1,42 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors namespaces assocs sets sequences locals
+compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop ;
+IN: compiler.cfg.write-barrier
+
+! Eliminate redundant write barrier hits.
+
+! Objects which have already been marked, as well as
+! freshly-allocated objects
+SYMBOL: safe
+
+! Objects which have been mutated
+SYMBOL: mutated
+
+GENERIC: eliminate-write-barrier ( insn -- insn' )
+
+M: ##allot eliminate-write-barrier
+    dup dst>> safe get conjoin ;
+
+M: ##write-barrier eliminate-write-barrier
+    dup src>> resolve dup
+    [ safe get key? not ]
+    [ mutated get key? ] bi and
+    [ safe get conjoin ] [ 2drop f ] if ;
+
+M: ##copy eliminate-write-barrier
+    dup record-copy ;
+
+M: ##set-slot eliminate-write-barrier
+    dup obj>> resolve mutated get conjoin ;
+
+M: ##set-slot-imm eliminate-write-barrier
+    dup obj>> resolve mutated get conjoin ;
+
+M: insn eliminate-write-barrier ;
+
+: eliminate-write-barriers ( insns -- insns' )
+    H{ } clone safe set
+    H{ } clone mutated set
+    H{ } clone copies set
+    [ eliminate-write-barrier ] map sift ;

basis/compiler/codegen/codegen.factor

@@ -3,28 +3,26 @@
 USING: namespaces make math math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
 combinators classes.algebra alien alien.c-types alien.structs
-alien.strings sets threads libc continuations.private
+alien.strings alien.arrays sets threads libc continuations.private
+fry cpu.architecture
 compiler.errors
 compiler.alien
-compiler.backend
-compiler.codegen.fixup
 compiler.cfg
 compiler.cfg.instructions
 compiler.cfg.registers
-compiler.cfg.builder ;
+compiler.cfg.builder
+compiler.codegen.fixup ;
 IN: compiler.codegen
 
 GENERIC: generate-insn ( insn -- )
 
-GENERIC: v>operand ( obj -- operand )
-
 SYMBOL: registers
 
-M: constant v>operand
+: register ( vreg -- operand )
-    value>> [ tag-fixnum ] [ \ f tag-number ] if* ;
+    registers get at [ "Bad value" throw ] unless* ;
 
-M: value v>operand
+: ?register ( obj -- operand )
-    >vreg [ registers get at ] [ "Bad value" throw ] if* ;
+    dup vreg? [ register ] when ;
 
 : generate-insns ( insns -- code )
     [
@@ -68,118 +66,148 @@ SYMBOL: labels
 : lookup-label ( id -- label )
     labels get [ drop <label> ] cache ;
 
-M: _label generate-insn
+M: ##load-immediate generate-insn
-    id>> lookup-label , ;
+    [ dst>> register ] [ val>> ] bi %load-immediate ;
 
-M: _prologue generate-insn
+M: ##load-indirect generate-insn
-    stack-frame>>
+    [ dst>> register ] [ obj>> ] bi %load-indirect ;
-    [ stack-frame set ]
-    [ dup size>> stack-frame-size >>total-size drop ]
-    [ total-size>> %prologue ]
-    tri ;
-
-M: _epilogue generate-insn
-    stack-frame>> total-size>> %epilogue ;
-
-M: ##load-literal generate-insn
-    [ obj>> ] [ dst>> v>operand ] bi load-literal ;
 
 M: ##peek generate-insn
-    [ dst>> v>operand ] [ loc>> ] bi %peek ;
+    [ dst>> register ] [ loc>> ] bi %peek ;
 
 M: ##replace generate-insn
-    [ src>> ] [ loc>> ] bi %replace ;
+    [ src>> register ] [ 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>> dup sub-primitive>>
-M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
+    [ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
 
 M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
 
-SYMBOL: operands
+M: ##return generate-insn drop %return ;
-
-: 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 ;
-
-M: _branch generate-insn
-    label>> lookup-label %jump-label ;
-
-M: _branch-f generate-insn
-    [ src>> v>operand ] [ label>> lookup-label ] bi %jump-f ;
-
-M: _branch-t generate-insn
-    [ src>> v>operand ] [ label>> lookup-label ] bi %jump-t ;
 
 M: ##dispatch-label generate-insn label>> %dispatch-label ;
 
-M: ##dispatch generate-insn drop %dispatch ;
+M: ##dispatch generate-insn
+    [ src>> register ] [ temp>> register ] bi %dispatch ;
+
+: >slot<
+    {
+        [ dst>> register ]
+        [ obj>> register ]
+        [ slot>> ?register ]
+        [ tag>> ]
+    } cleave ; inline
+
+M: ##slot generate-insn
+    [ >slot< ] [ temp>> register ] bi %slot ;
+
+M: ##slot-imm generate-insn
+    >slot< %slot-imm ;
+
+: >set-slot<
+    {
+        [ src>> register ]
+        [ obj>> register ]
+        [ slot>> ?register ]
+        [ tag>> ]
+    } cleave ; inline
+
+M: ##set-slot generate-insn
+    [ >set-slot< ] [ temp>> register ] bi %set-slot ;
+
+M: ##set-slot-imm generate-insn
+    >set-slot< %set-slot-imm ;
 
 : dst/src ( insn -- dst src )
-    [ dst>> v>operand ] [ src>> v>operand ] bi ;
+    [ dst>> register ] [ src>> register ] bi ; inline
+
+: dst/src1/src2 ( insn -- dst src1 src2 )
+    [ dst>> register ]
+    [ src1>> register ]
+    [ src2>> ?register ] tri ; inline
+
+M: ##add     generate-insn dst/src1/src2 %add     ;
+M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
+M: ##sub     generate-insn dst/src1/src2 %sub     ;
+M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
+M: ##mul     generate-insn dst/src1/src2 %mul     ;
+M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
+M: ##and     generate-insn dst/src1/src2 %and     ;
+M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
+M: ##or      generate-insn dst/src1/src2 %or      ;
+M: ##or-imm  generate-insn dst/src1/src2 %or-imm  ;
+M: ##xor     generate-insn dst/src1/src2 %xor     ;
+M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
+M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
+M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
+M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
+M: ##not     generate-insn dst/src       %not     ;
+
+: dst/src/temp ( insn -- dst src temp )
+    [ dst/src ] [ temp>> register ] bi ; inline
+
+M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
+M: ##bignum>integer generate-insn dst/src %bignum>integer ;
+
+M: ##add-float generate-insn dst/src1/src2 %add-float ;
+M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
+M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
+M: ##div-float generate-insn dst/src1/src2 %div-float ;
+
+M: ##integer>float generate-insn dst/src %integer>float ;
+M: ##float>integer generate-insn dst/src %float>integer ;
 
 M: ##copy             generate-insn dst/src %copy ;
-
 M: ##copy-float       generate-insn dst/src %copy-float ;
-
 M: ##unbox-float      generate-insn dst/src %unbox-float ;
+M: ##unbox-any-c-ptr  generate-insn dst/src/temp %unbox-any-c-ptr ;
+M: ##box-float        generate-insn dst/src/temp %box-float ;
+M: ##box-alien        generate-insn dst/src/temp %box-alien ;
 
-M: ##unbox-f generate-insn dst/src %unbox-f ;
+M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
+M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
+M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
+M: ##alien-signed-1   generate-insn dst/src %alien-signed-1   ;
+M: ##alien-signed-2   generate-insn dst/src %alien-signed-2   ;
+M: ##alien-signed-4   generate-insn dst/src %alien-signed-4   ;
+M: ##alien-cell       generate-insn dst/src %alien-cell       ;
+M: ##alien-float      generate-insn dst/src %alien-float      ;
+M: ##alien-double     generate-insn dst/src %alien-double     ;
 
-M: ##unbox-alien generate-insn dst/src %unbox-alien ;
+: >alien-setter< [ src>> register ] [ value>> register ] bi ; inline
 
-M: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
+M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
-
+M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
-M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
+M: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
-
+M: ##set-alien-cell      generate-insn >alien-setter< %set-alien-cell      ;
-M: ##box-float generate-insn dst/src %box-float ;
+M: ##set-alien-float     generate-insn >alien-setter< %set-alien-float     ;
-
+M: ##set-alien-double    generate-insn >alien-setter< %set-alien-double    ;
-M: ##box-alien generate-insn dst/src %box-alien ;
 
 M: ##allot generate-insn
     {
-        [ dst>> v>operand ]
+        [ dst>> register ]
         [ size>> ]
-        [ type>> ]
+        [ class>> ]
-        [ tag>> ]
+        [ temp>> register ]
-        [ temp>> v>operand ]
     } cleave
     %allot ;
 
 M: ##write-barrier generate-insn
-    [ src>> v>operand ] [ temp>> v>operand ] bi %write-barrier ;
+    [ src>> register ]
+    [ card#>> register ]
+    [ table>> register ]
+    tri %write-barrier ;
 
-M: ##gc generate-insn drop %gc ;
+M: _gc generate-insn drop %gc ;
 
-! #alien-invoke
+M: ##loop-entry generate-insn drop %loop-entry ;
+
+! ##alien-invoke
 GENERIC: reg-size ( register-class -- n )
 
 M: int-regs reg-size drop cell ;
@@ -188,6 +216,8 @@ M: single-float-regs reg-size drop 4 ;
 
 M: double-float-regs reg-size drop 8 ;
 
+M: stack-params reg-size drop "void*" heap-size ;
+
 GENERIC: reg-class-variable ( register-class -- symbol )
 
 M: reg-class reg-class-variable ;
@@ -268,7 +298,7 @@ M: long-long-type flatten-value-type ( type -- types )
     >r
     alien-parameters
     flatten-value-types
-    r> [ >r alloc-parameter r> execute ] curry each-parameter ;
+    r> '[ alloc-parameter _ execute ] each-parameter ;
     inline
 
 : unbox-parameters ( offset node -- )
@@ -323,7 +353,7 @@ M: no-such-symbol compiler-error-type
 
 : check-dlsym ( symbols dll -- )
     dup dll-valid? [
-        dupd [ dlsym ] curry contains?
+        dupd '[ _ dlsym ] contains?
         [ drop ] [ no-such-symbol ] if
     ] [
         dll-path no-such-library drop
@@ -399,7 +429,7 @@ TUPLE: callback-context ;
 : callback-return-quot ( ctype -- quot )
     return>> {
         { [ dup "void" = ] [ drop [ ] ] }
-        { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
+        { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
         [ c-type c-type-unboxer-quot ]
     } cond ;
 
@@ -416,23 +446,69 @@ TUPLE: callback-context ;
 
 : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
 
-: callback-unwind ( params -- n )
+M: ##callback-return generate-insn
-    {
-        { [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
-        { [ dup return>> large-struct? ] [ drop 4 ] }
-        [ drop 0 ]
-    } cond ;
-
-: %callback-return ( params -- )
     #! All the extra book-keeping for %unwind is only for x86.
     #! On other platforms its an alias for %return.
-    dup alien-return
+    params>> %callback-return ;
-    [ %unnest-stacks ] [ %callback-value ] if-void
-    callback-unwind %unwind ;
 
 M: ##alien-callback generate-insn
     params>>
     [ registers>objects ]
     [ wrap-callback-quot %alien-callback ]
-    [ %callback-return ]
+    [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
     tri ;
+
+M: _prologue generate-insn
+    stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
+
+M: _epilogue generate-insn
+    stack-frame>> total-size>> %epilogue ;
+
+M: _label generate-insn
+    id>> lookup-label , ;
+
+M: _branch generate-insn
+    label>> lookup-label %jump-label ;
+
+: >compare< ( insn -- label cc src1 src2 )
+    {
+        [ dst>> register ]
+        [ cc>> ]
+        [ src1>> register ]
+        [ src2>> ?register ]
+    } cleave ; inline
+
+M: ##compare generate-insn >compare< %compare ;
+M: ##compare-imm generate-insn >compare< %compare-imm ;
+M: ##compare-float generate-insn >compare< %compare-float ;
+
+: >binary-branch< ( insn -- label cc src1 src2 )
+    {
+        [ label>> lookup-label ]
+        [ cc>> ]
+        [ src1>> register ]
+        [ src2>> ?register ]
+    } cleave ; inline
+
+M: _compare-branch generate-insn
+    >binary-branch< %compare-branch ;
+
+M: _compare-imm-branch generate-insn
+    >binary-branch< %compare-imm-branch ;
+
+M: _compare-float-branch generate-insn
+    >binary-branch< %compare-float-branch ;
+
+M: _spill generate-insn
+    [ src>> ] [ n>> ] [ class>> ] tri {
+        { int-regs [ %spill-integer ] }
+        { double-float-regs [ %spill-float ] }
+    } case ;
+
+M: _reload generate-insn
+    [ dst>> ] [ n>> ] [ class>> ] tri {
+        { int-regs [ %reload-integer ] }
+        { double-float-regs [ %reload-float ] }
+    } case ;
+
+M: _spill-counts generate-insn drop ;

basis/compiler/codegen/fixup/fixup.factor

@@ -4,7 +4,7 @@ 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 math.order accessors
-growable compiler.constants compiler.backend ;
+growable cpu.architecture compiler.constants ;
 IN: compiler.codegen.fixup
 
 GENERIC: fixup* ( obj -- )
@@ -43,9 +43,10 @@ M: rel-fixup fixup*
 
 M: integer fixup* , ;
 
+: indq ( elt seq -- n ) [ eq? ] with find drop ;
+
 : adjoin* ( obj table -- n )
-    2dup swap [ eq? ] curry find drop
+    2dup indq [ 2nip ] [ dup length >r push r> ] if* ;
-    [ 2nip ] [ dup length >r push r> ] if* ;
 
 SYMBOL: literal-table
 

basis/compiler/compiler-docs.factor

@@ -1,4 +1,4 @@
-USING: compiler.generator help.markup help.syntax words io parser
+USING: help.markup help.syntax words io parser
 assocs words.private sequences compiler.units ;
 IN: compiler
 
@@ -27,8 +27,7 @@ ARTICLE: "compiler" "Optimizing compiler"
 "The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect; for otherwise, most of the system would be compiled with the non-optimizing compiler. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
 { $subsection "compiler-usage" }
 { $subsection "compiler-errors" }
-{ $subsection "hints" }
+{ $subsection "hints" } ;
-{ $subsection "generator" } ;
 
 ABOUT: "compiler"
 

basis/compiler/compiler.factor

@@ -1,12 +1,32 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces arrays sequences io debugger words fry
+USING: accessors kernel namespaces arrays sequences io debugger
-compiler.units continuations vocabs assocs dlists definitions
+words fry continuations vocabs assocs dlists definitions math
-math threads graphs generic combinators deques search-deques
+threads graphs generic combinators deques search-deques
-stack-checker stack-checker.state compiler.generator
+prettyprint io stack-checker stack-checker.state
-compiler.errors compiler.tree.builder compiler.tree.optimizer ;
+stack-checker.inlining compiler.errors compiler.units
+compiler.tree.builder compiler.tree.optimizer
+compiler.cfg.builder compiler.cfg.optimizer
+compiler.cfg.linearization compiler.cfg.two-operand
+compiler.cfg.linear-scan compiler.cfg.stack-frame
+compiler.codegen ;
 IN: compiler
 
+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 -- )
@@ -24,10 +44,13 @@ SYMBOL: +failed+
     [ "compiled-effect" set-word-prop ]
     2bi ;
 
-: compile-begins ( word -- )
+: start ( word -- )
+    "trace-compilation" get [ dup . flush ] when
+    H{ } clone dependencies set
+    H{ } clone generic-dependencies set
     f swap compiler-error ;
 
-: compile-failed ( word error -- )
+: fail ( word error -- )
     [ swap compiler-error ]
     [
         drop
@@ -35,9 +58,34 @@ SYMBOL: +failed+
         [ f swap compiled get set-at ]
         [ +failed+ save-effect ]
         tri
-    ] 2bi ;
+    ] 2bi
+    return ;
 
-: compile-succeeded ( effect word -- )
+: frontend ( word -- effect nodes )
+    [ build-tree-from-word ] [ fail ] recover optimize-tree ;
+
+! Only switch this off for debugging.
+SYMBOL: compile-dependencies?
+
+t compile-dependencies? set-global
+
+: save-asm ( asm -- )
+    [ [ code>> ] [ label>> ] bi compiled get set-at ]
+    [ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
+    bi ;
+
+: backend ( nodes word -- )
+    build-cfg [
+        optimize-cfg
+        build-mr
+        convert-two-operand
+        linear-scan
+        build-stack-frame
+        generate
+        save-asm
+    ] each ;
+
+: finish ( effect word -- )
     [ swap save-effect ]
     [ compiled-unxref ]
     [
@@ -51,17 +99,11 @@ SYMBOL: +failed+
 
 : (compile) ( word -- )
     '[
-        H{ } clone dependencies set
-        H{ } clone generic-dependencies set
-
         _ {
-            [ compile-begins ]
+            [ start ]
-            [
+            [ frontend ]
-                [ build-tree-from-word ] [ compile-failed return ] recover
+            [ backend ]
-                optimize-tree
+            [ finish ]
-            ]
-            [ dup generate ]
-            [ compile-succeeded ]
         } cleave
     ] with-return ;
 

basis/compiler/generator/fixup/fixup-docs.factor

@@ -1,19 +0,0 @@
-USING: help.syntax help.markup math kernel
-words strings alien compiler.generator ;
-IN: compiler.generator.fixup
-
-HELP: frame-required
-{ $values { "n" "a non-negative integer" } }
-{ $description "Notify the code generator that the currently compiling code block needs a stack frame with room for at least " { $snippet "n" } " parameters." } ;
-
-HELP: add-literal
-{ $values { "obj" object } { "n" integer } }
-{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
-
-HELP: rel-dlsym
-{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
-{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
-} ;
-
-HELP: literal-table
-{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link begin-compiling } " ensures that the first entry is the word being compiled." } ;

basis/compiler/generator/fixup/fixup.factor

@@ -1,154 +0,0 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-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.generator.fixup
-
-: no-stack-frame -1 ; inline
-
-TUPLE: frame-required n ;
-
-: frame-required ( n -- ) \ frame-required boa , ;
-
-: compute-stack-frame-size ( code -- n )
-    no-stack-frame [
-        dup frame-required? [ n>> max ] [ drop ] if
-    ] reduce ;
-
-GENERIC: fixup* ( frame-size obj -- frame-size )
-
-: 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-size 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 ;
-
-TUPLE: label-fixup label class ;
-
-: label-fixup ( label class -- ) \ label-fixup boa , ;
-
-M: label-fixup fixup*
-    dup class>> rc-absolute?
-    [ "Absolute labels not supported" throw ] when
-    dup label>> swap class>> compiled-offset 4 - rot
-    3array label-table get push ;
-
-TUPLE: rel-fixup arg class type ;
-
-: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
-
-: push-4 ( value vector -- )
-    [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
-    swap set-alien-unsigned-4 ;
-
-M: rel-fixup fixup*
-    [ [ arg>> ] [ class>> ] [ type>> ] tri { 0 8 16 } bitfield ]
-    [ 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 )
-    2dup swap [ eq? ] curry find drop
-    [ 2nip ] [ dup length >r push r> ] if* ;
-
-SYMBOL: literal-table
-
-: add-literal ( obj -- n ) literal-table get adjoin* ;
-
-: add-dlsym-literals ( symbol dll -- )
-    >r string>symbol r> 2array literal-table get push-all ;
-
-: rel-dlsym ( name dll class -- )
-    >r literal-table get length >r
-    add-dlsym-literals
-    r> r> rt-dlsym rel-fixup ;
-
-: rel-word ( word class -- )
-    >r add-literal r> rt-xt rel-fixup ;
-
-: rel-primitive ( word class -- )
-    >r def>> first r> rt-primitive rel-fixup ;
-
-: rel-literal ( literal class -- )
-    >r add-literal r> rt-literal rel-fixup ;
-
-: rel-this ( class -- )
-    0 swap rt-label rel-fixup ;
-
-: rel-here ( class -- )
-    0 swap rt-here rel-fixup ;
-
-: init-fixup ( -- )
-    BV{ } clone relocation-table set
-    V{ } clone label-table set ;
-
-: resolve-labels ( labels -- labels' )
-    [
-        first3 offset>>
-        [ "Unresolved label" throw ] unless*
-        3array
-    ] map concat ;
-
-: fixup ( code -- literals relocation labels code )
-    [
-        init-fixup
-        dup compute-stack-frame-size swap [ fixup* ] each drop
-
-        literal-table get >array
-        relocation-table get >byte-array
-        label-table get resolve-labels
-    ] { } make ;

basis/compiler/generator/generator-docs.factor

@@ -1,85 +0,0 @@
-USING: help.markup help.syntax words debugger
-compiler.generator.fixup compiler.generator.registers quotations
-kernel vectors arrays effects sequences ;
-IN: compiler.generator
-
-ARTICLE: "generator" "Compiled code generator"
-"Most of the words in the " { $vocab-link "compiler.generator" } " vocabulary are internal to the compiler and user code has no reason to call them."
-$nl
-"Debugging information can be enabled or disabled; this hook is used by " { $link "tools.deploy" } ":"
-{ $subsection compiled-stack-traces? }
-"Assembler intrinsics can be defined for low-level optimization:"
-{ $subsection define-intrinsic }
-{ $subsection define-intrinsics }
-{ $subsection define-if-intrinsic }
-{ $subsection define-if-intrinsics }
-"The main entry point into the code generator:"
-{ $subsection generate } ;
-
-ABOUT: "generator"
-
-HELP: compiled
-{ $var-description "During compilation, holds a hashtable mapping words to 5-element arrays holding compiled code." } ;
-
-HELP: compiling-word
-{ $var-description "The word currently being compiled, set by " { $link with-generator } "." } ;
-
-HELP: compiling-label
-{ $var-description "The label currently being compiled, set by " { $link with-generator } "." } ;
-
-HELP: compiled-stack-traces?
-{ $values { "?" "a boolean" } }
-{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ;
-
-HELP: begin-compiling
-{ $values { "word" word } { "label" word } }
-{ $description "Prepares to generate machine code for a word." } ;
-
-HELP: with-generator
-{ $values { "nodes" "a sequence of nodes" } { "word" word } { "label" word } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
-{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the sequence of nodes." } ;
-
-HELP: generate-node
-{ $values { "node" "a dataflow node" } { "next" "a dataflow node" } }
-{ $contract "Generates machine code for a dataflow node, and outputs the next node to generate machine code for." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
-
-HELP: generate-nodes
-{ $values { "nodes" "a sequence of nodes" } } 
-{ $description "Recursively generate machine code for a dataflow graph." }
-{ $notes "This word can only be called from inside the quotation passed to " { $link with-generator } "." } ;
-
-HELP: generate
-{ $values { "word" word } { "label" word } { "nodes" "a sequence of nodes" } }
-{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "nodes" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
-
-HELP: define-intrinsics
-{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot assoc }" } " pairs" } }
-{ $description "Defines a set of assembly intrinsics for the word. When a call to the word is being compiled, each intrinsic is tested in turn; the first applicable one will be called to generate machine code. If no suitable intrinsic is found, a simple call to the word is compiled instead."
-$nl
-"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
-
-HELP: define-intrinsic
-{ $values { "word" word } { "quot" quotation } { "assoc" "an assoc" } }
-{ $description "Defines an assembly intrinsic for the word. When a call to the word is being compiled, this intrinsic will be used if it is found to be applicable. If it is not applicable, a simple call to the word is compiled instead."
-$nl
-"See " { $link with-template } " for an explanation of the keys which may appear in " { $snippet "assoc" } "." } ;
-
-HELP: if>boolean-intrinsic
-{ $values { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } }
-{ $description "Generates code which pushes " { $link t } " or " { $link f } " on the data stack, depending on whether the quotation jumps to the label or not." } ;
-
-HELP: define-if-intrinsics
-{ $values { "word" word } { "intrinsics" "a sequence of " { $snippet "{ quot inputs }" } " pairs" } }
-{ $description "Defines a set of conditional assembly intrinsics for the word, which must have a boolean value as its single output."
-$nl
-"The quotations must have stack effect " { $snippet "( label -- )" } "; they are required to branch to the label if the word evaluates to true."
-$nl
-"The " { $snippet "inputs" } " are in the same format as the " { $link +input+ } " key to " { $link with-template } "; a description can be found in the documentation for thatt word." }
-{ $notes "Conditional intrinsics are used when the word is followed by a call to " { $link if } ". They allow for tighter code to be generated in certain situations; for example, if two integers are being compared and the result is immediately used to branch, the intermediate boolean does not need to be pushed at all." } ;
-
-HELP: define-if-intrinsic
-{ $values { "word" word } { "quot" "a quotation with stack effect " { $snippet "( label -- )" } } { "inputs" "a sequence of input register specifiers" } }
-{ $description "Defines a conditional assembly intrinsic for the word, which must have a boolean value as its single output."
-$nl
-"See " { $link define-if-intrinsics } " for a description of the parameters." } ;

basis/compiler/generator/generator.factor

@@ -1,581 +0,0 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes combinators
-cpu.architecture effects generic hashtables io kernel
-kernel.private layouts math math.parser namespaces make
-prettyprint quotations sequences system threads words vectors
-sets deques continuations.private summary alien alien.c-types
-alien.structs alien.strings alien.arrays libc compiler.errors
-stack-checker.inlining compiler.tree compiler.tree.builder
-compiler.tree.combinators compiler.tree.propagation.info
-compiler.generator.fixup compiler.generator.registers
-compiler.generator.iterator ;
-IN: compiler.generator
-
-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: compiling-word
-
-SYMBOL: compiling-label
-
-SYMBOL: compiling-loops
-
-! Label of current word, after prologue, makes recursion faster
-SYMBOL: current-label-start
-
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
-
-: begin-compiling ( word label -- )
-    H{ } clone compiling-loops set
-    compiling-label set
-    compiling-word set
-    compiled-stack-traces?
-    compiling-word get f ?
-    1vector literal-table set
-    f compiling-label get compiled get set-at ;
-
-: save-machine-code ( literals relocation labels code -- )
-    4array compiling-label get compiled get set-at ;
-
-: with-generator ( nodes word label quot -- )
-    [
-        >r begin-compiling r>
-        { } make fixup
-        save-machine-code
-    ] with-scope ; inline
-
-GENERIC: generate-node ( node -- next )
-
-: generate-nodes ( nodes -- )
-    [ current-node generate-node ] iterate-nodes
-    end-basic-block ;
-
-: init-generate-nodes ( -- )
-    init-templates
-    %save-word-xt
-    %prologue-later
-    current-label-start define-label
-    current-label-start resolve-label ;
-
-: generate ( nodes word label -- )
-    [
-        init-generate-nodes
-        [ generate-nodes ] with-node-iterator
-    ] with-generator ;
-
-: intrinsics ( #call -- quot )
-    word>> "intrinsics" word-prop ;
-
-: if-intrinsics ( #call -- quot )
-    word>> "if-intrinsics" word-prop ;
-
-! node
-M: node generate-node drop iterate-next ;
-
-: %jump ( word -- )
-    dup compiling-label get eq?
-    [ drop current-label-start get ] [ %epilogue-later ] if
-    %jump-label ;
-
-: generate-call ( label -- next )
-    dup maybe-compile
-    end-basic-block
-    dup compiling-loops get at [
-        %jump-label f
-    ] [
-        tail-call? [
-            %jump f
-        ] [
-            0 frame-required
-            %call
-            iterate-next
-        ] if
-    ] ?if ;
-
-! #recursive
-: compile-recursive ( node -- next )
-    dup label>> id>> generate-call >r
-    [ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
-    r> ;
-
-: compiling-loop ( word -- )
-    <label> dup resolve-label swap compiling-loops get set-at ;
-
-: compile-loop ( node -- next )
-    end-basic-block
-    [ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
-    iterate-next ;
-
-M: #recursive generate-node
-    dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
-
-! #if
-: end-false-branch ( label -- )
-    tail-call? [ %return drop ] [ %jump-label ] if ;
-
-: generate-branch ( nodes -- )
-    [ copy-templates generate-nodes ] with-scope ;
-
-: generate-if ( node label -- next )
-    <label> [
-        >r >r children>> first2 swap generate-branch
-        r> r> end-false-branch resolve-label
-        generate-branch
-        init-templates
-    ] keep resolve-label iterate-next ;
-
-M: #if generate-node
-    [ <label> dup %jump-f ]
-    H{ { +input+ { { f "flag" } } } }
-    with-template
-    generate-if ;
-
-! #dispatch
-: dispatch-branch ( nodes word -- label )
-    gensym [
-        [
-            copy-templates
-            %save-dispatch-xt
-            %prologue-later
-            [ generate-nodes ] with-node-iterator
-            %return
-        ] with-generator
-    ] keep ;
-
-: dispatch-branches ( node -- )
-    children>> [
-        compiling-word get dispatch-branch
-        %dispatch-label
-    ] each ;
-
-: generate-dispatch ( node -- )
-    %dispatch dispatch-branches init-templates ;
-
-M: #dispatch generate-node
-    #! The order here is important, dispatch-branches must
-    #! run after %dispatch, so that each branch gets the
-    #! correct register state
-    tail-call? [
-        generate-dispatch iterate-next
-    ] [
-        compiling-word get gensym [
-            [
-                init-generate-nodes
-                generate-dispatch
-            ] with-generator
-        ] keep generate-call
-    ] if ;
-
-! #call
-: define-intrinsics ( word intrinsics -- )
-    "intrinsics" set-word-prop ;
-
-: define-intrinsic ( word quot assoc -- )
-    2array 1array define-intrinsics ;
-
-: define-if>branch-intrinsics ( word intrinsics -- )
-    "if-intrinsics" set-word-prop ;
-
-: if>boolean-intrinsic ( quot -- )
-    "false" define-label
-    "end" define-label
-    "false" get swap call
-    t "if-scratch" get load-literal
-    "end" get %jump-label
-    "false" resolve-label
-    f "if-scratch" get load-literal
-    "end" resolve-label
-    "if-scratch" get phantom-push ; inline
-
-: define-if>boolean-intrinsics ( word intrinsics -- )
-    [
-        >r [ if>boolean-intrinsic ] curry r>
-        { { f "if-scratch" } } +scratch+ associate assoc-union
-    ] assoc-map "intrinsics" set-word-prop ;
-
-: define-if-intrinsics ( word intrinsics -- )
-    [ +input+ associate ] assoc-map
-    2dup define-if>branch-intrinsics
-    define-if>boolean-intrinsics ;
-
-: define-if-intrinsic ( word quot inputs -- )
-    2array 1array define-if-intrinsics ;
-
-: do-if-intrinsic ( pair -- next )
-    <label> [ swap do-template skip-next ] keep generate-if ;
-
-: find-intrinsic ( #call -- pair/f )
-    intrinsics find-template ;
-
-: find-if-intrinsic ( #call -- pair/f )
-    node@ {
-        { [ dup length 2 < ] [ 2drop f ] }
-        { [ dup second #if? ] [ drop if-intrinsics find-template ] }
-        [ 2drop f ]
-    } cond ;
-
-M: #call generate-node
-    dup node-input-infos [ class>> ] map set-operand-classes
-    dup find-if-intrinsic [
-        do-if-intrinsic
-    ] [
-        dup find-intrinsic [
-            do-template iterate-next
-        ] [
-            word>> generate-call
-        ] ?if
-    ] ?if ;
-
-! #call-recursive
-M: #call-recursive generate-node label>> id>> generate-call ;
-
-! #push
-M: #push generate-node
-    literal>> <constant> phantom-push iterate-next ;
-
-! #shuffle
-M: #shuffle generate-node
-    shuffle-effect phantom-shuffle iterate-next ;
-
-M: #>r generate-node
-    [ in-d>> length ] [ out-r>> empty? ] bi
-    [ phantom-drop ] [ phantom->r ] if
-    iterate-next ;
-
-M: #r> generate-node
-    [ in-r>> length ] [ out-d>> empty? ] bi
-    [ phantom-rdrop ] [ phantom-r> ] if
-    iterate-next ;
-
-! #return
-M: #return generate-node
-    drop end-basic-block %return f ;
-
-M: #return-recursive generate-node
-    end-basic-block
-    label>> id>> compiling-loops get key?
-    [ %return ] unless f ;
-
-! #alien-invoke
-: large-struct? ( ctype -- ? )
-    dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
-
-: alien-parameters ( params -- seq )
-    dup parameters>>
-    swap return>> large-struct? [ "void*" prefix ] when ;
-
-: alien-return ( params -- ctype )
-    return>> dup large-struct? [ drop "void" ] when ;
-
-: c-type-stack-align ( type -- align )
-    dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
-
-: parameter-align ( n type -- n delta )
-    over >r c-type-stack-align align dup r> - ;
-
-: parameter-sizes ( types -- total offsets )
-    #! Compute stack frame locations.
-    [
-        0 [
-            [ parameter-align drop dup , ] keep stack-size +
-        ] reduce cell align
-    ] { } make ;
-
-: return-size ( ctype -- n )
-    #! Amount of space we reserve for a return value.
-    dup large-struct? [ heap-size ] [ drop 2 cells ] if ;
-
-: alien-stack-frame ( params -- n )
-    stack-frame new
-        swap
-        [ return>> return-size >>return ]
-        [ alien-parameters parameter-sizes drop >>params ] bi
-        dup [ params>> ] [ return>> ] bi + >>size
-        dup size>> stack-frame-size >>total-size ;
-
-: with-stack-frame ( params quot -- )
-    swap alien-stack-frame [ size>> frame-required ] [ stack-frame set ] bi
-    call
-    stack-frame off ; inline
-
-GENERIC: reg-size ( register-class -- n )
-
-M: int-regs reg-size drop cell ;
-
-M: single-float-regs reg-size drop 4 ;
-
-M: double-float-regs reg-size drop 8 ;
-
-M: stack-params reg-size drop "void*" heap-size ;
-
-GENERIC: reg-class-variable ( register-class -- symbol )
-
-M: reg-class reg-class-variable ;
-
-M: float-regs reg-class-variable drop float-regs ;
-
-M: stack-params reg-class-variable drop stack-params ;
-
-GENERIC: inc-reg-class ( register-class -- )
-
-M: reg-class inc-reg-class
-    dup reg-class-variable inc
-    fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
-
-M: float-regs inc-reg-class
-    dup call-next-method
-    fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
-
-: reg-class-full? ( class -- ? )
-    [ reg-class-variable get ] [ param-regs length ] bi >= ;
-
-: spill-param ( reg-class -- n reg-class )
-    stack-params get
-    >r reg-size stack-params +@ r>
-    stack-params ;
-
-: fastcall-param ( reg-class -- n reg-class )
-    [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
-
-: alloc-parameter ( parameter -- reg reg-class )
-    c-type-reg-class dup reg-class-full?
-    [ spill-param ] [ fastcall-param ] if
-    [ param-reg ] keep ;
-
-: (flatten-int-type) ( size -- types )
-    cell /i "void*" c-type <repetition> ;
-
-GENERIC: flatten-value-type ( type -- types )
-
-M: object flatten-value-type 1array ;
-
-M: struct-type flatten-value-type ( type -- types )
-    stack-size cell align (flatten-int-type) ;
-
-M: long-long-type flatten-value-type ( type -- types )
-    stack-size cell align (flatten-int-type) ;
-
-: flatten-value-types ( params -- params )
-    #! Convert value type structs to consecutive void*s.
-    [
-        0 [
-            c-type
-            [ parameter-align (flatten-int-type) % ] keep
-            [ stack-size cell align + ] keep
-            flatten-value-type %
-        ] reduce drop
-    ] { } make ;
-
-: each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2each ; inline
-
-: reverse-each-parameter ( parameters quot -- )
-    >r [ parameter-sizes nip ] keep r> 2reverse-each ; inline
-
-: reset-freg-counts ( -- )
-    { int-regs float-regs stack-params } [ 0 swap set ] each ;
-
-: with-param-regs ( quot -- )
-    #! In quot you can call alloc-parameter
-    [ reset-freg-counts call ] with-scope ; inline
-
-: move-parameters ( node word -- )
-    #! Moves values from C stack to registers (if word is
-    #! %load-param-reg) and registers to C stack (if word is
-    #! %save-param-reg).
-    >r
-    alien-parameters
-    flatten-value-types
-    r> [ >r alloc-parameter r> execute ] curry each-parameter ;
-    inline
-
-: unbox-parameters ( offset node -- )
-    parameters>> [
-        %prepare-unbox >r over + r> unbox-parameter
-    ] reverse-each-parameter drop ;
-
-: prepare-box-struct ( node -- offset )
-    #! Return offset on C stack where to store unboxed
-    #! parameters. If the C function is returning a structure,
-    #! the first parameter is an implicit target area pointer,
-    #! so we need to use a different offset.
-    return>> large-struct?
-    [ %prepare-box-struct cell ] [ 0 ] if ;
-
-: objects>registers ( params -- )
-    #! Generate code for unboxing a list of C types, then
-    #! generate code for moving these parameters to register on
-    #! architectures where parameters are passed in registers.
-    [
-        [ prepare-box-struct ] keep
-        [ unbox-parameters ] keep
-        \ %load-param-reg move-parameters
-    ] with-param-regs ;
-
-: box-return* ( node -- )
-    return>> [ ] [ box-return ] if-void ;
-
-TUPLE: no-such-library name ;
-
-M: no-such-library summary
-    drop "Library not found" ;
-
-M: no-such-library compiler-error-type
-    drop +linkage+ ;
-
-: no-such-library ( name -- )
-    \ no-such-library boa
-    compiling-word get compiler-error ;
-
-TUPLE: no-such-symbol name ;
-
-M: no-such-symbol summary
-    drop "Symbol not found" ;
-
-M: no-such-symbol compiler-error-type
-    drop +linkage+ ;
-
-: no-such-symbol ( name -- )
-    \ no-such-symbol boa
-    compiling-word get compiler-error ;
-
-: check-dlsym ( symbols dll -- )
-    dup dll-valid? [
-        dupd [ dlsym ] curry contains?
-        [ drop ] [ no-such-symbol ] if
-    ] [
-        dll-path no-such-library drop
-    ] if ;
-
-: stdcall-mangle ( symbol node -- symbol )
-    "@"
-    swap parameters>> parameter-sizes drop
-    number>string 3append ;
-
-: alien-invoke-dlsym ( params -- symbols dll )
-    dup function>> dup pick stdcall-mangle 2array
-    swap library>> library dup [ dll>> ] when
-    2dup check-dlsym ;
-
-M: #alien-invoke generate-node
-    params>>
-    dup [
-        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 ;
-
-! #alien-indirect
-M: #alien-indirect generate-node
-    params>>
-    dup [
-        ! 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 ;
-
-! #alien-callback
-: box-parameters ( params -- )
-    alien-parameters [ box-parameter ] each-parameter ;
-
-: registers>objects ( node -- )
-    [
-        dup \ %save-param-reg move-parameters
-        "nest_stacks" f %alien-invoke
-        box-parameters
-    ] with-param-regs ;
-
-TUPLE: callback-context ;
-
-: current-callback 2 getenv ;
-
-: wait-to-return ( token -- )
-    dup current-callback eq? [
-        drop
-    ] [
-        yield wait-to-return
-    ] if ;
-
-: do-callback ( quot token -- )
-    init-catchstack
-    dup 2 setenv
-    slip
-    wait-to-return ; inline
-
-: callback-return-quot ( ctype -- quot )
-    return>> {
-        { [ dup "void" = ] [ drop [ ] ] }
-        { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
-        [ c-type c-type-unboxer-quot ]
-    } cond ;
-
-: callback-prep-quot ( params -- quot )
-    parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
-
-: wrap-callback-quot ( params -- quot )
-    [
-        [ callback-prep-quot ]
-        [ quot>> ]
-        [ callback-return-quot ] tri 3append ,
-        [ callback-context new do-callback ] %
-    ] [ ] make ;
-
-: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
-
-: callback-unwind ( params -- n )
-    {
-        { [ dup abi>> "stdcall" = ] [ drop stack-frame get params>> ] }
-        { [ dup return>> large-struct? ] [ drop 4 ] }
-        [ drop 0 ]
-    } cond ;
-
-: %callback-return ( params -- )
-    #! All the extra book-keeping for %unwind is only for x86.
-    #! On other platforms its an alias for %return.
-    dup alien-return
-    [ %unnest-stacks ] [ %callback-value ] if-void
-    callback-unwind %unwind ;
-
-: generate-callback ( params -- )
-    dup xt>> dup [
-        init-templates
-        %prologue-later
-        dup [
-            [ registers>objects ]
-            [ wrap-callback-quot %alien-callback ]
-            [ %callback-return ]
-            tri
-        ] with-stack-frame
-    ] with-generator ;
-
-M: #alien-callback generate-node
-    end-basic-block
-    params>> generate-callback iterate-next ;

basis/compiler/generator/iterator/iterator.factor

@@ -1,45 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences kernel compiler.tree ;
-IN: compiler.generator.iterator
-
-SYMBOL: node-stack
-
-: >node ( cursor -- ) node-stack get push ;
-: node> ( -- cursor ) node-stack get pop ;
-: node@ ( -- cursor ) node-stack get peek ;
-: current-node ( -- node ) node@ first ;
-: iterate-next ( -- cursor ) node@ rest-slice ;
-: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
-
-: iterate-nodes ( cursor quot: ( -- ) -- )
-    over empty? [
-        2drop
-    ] [
-        [ swap >node call node> drop ] keep iterate-nodes
-    ] if ; inline recursive
-
-: with-node-iterator ( quot -- )
-    >r V{ } clone node-stack r> with-variable ; inline
-
-DEFER: (tail-call?)
-
-: tail-phi? ( cursor -- ? )
-    [ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
-
-: (tail-call?) ( cursor -- ? )
-    [ t ] [
-        [ first [ #return? ] [ #terminate? ] bi or ]
-        [ tail-phi? ]
-        bi or
-    ] if-empty ;
-
-: tail-call? ( -- ? )
-    node-stack get [
-        rest-slice
-        [ t ] [
-            [ (tail-call?) ]
-            [ first #terminate? not ]
-            bi and
-        ] if-empty
-    ] all? ;

basis/compiler/generator/registers/registers.factor

@@ -1,672 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes classes.private classes.algebra
-combinators hashtables kernel layouts math namespaces make
-quotations sequences system vectors words effects alien
-byte-arrays accessors sets math.order cpu.architecture
-compiler.generator.fixup ;
-IN: compiler.generator.registers
-
-SYMBOL: +input+
-SYMBOL: +output+
-SYMBOL: +scratch+
-SYMBOL: +clobber+
-SYMBOL: known-tag
-
-<PRIVATE
-
-! Value protocol
-GENERIC: set-operand-class ( class obj -- )
-GENERIC: operand-class* ( operand -- class )
-GENERIC: move-spec ( obj -- spec )
-GENERIC: live-vregs* ( obj -- )
-GENERIC: live-loc? ( actual current -- ? )
-GENERIC# (lazy-load) 1 ( value spec -- value )
-GENERIC: lazy-store ( dst src -- )
-GENERIC: minimal-ds-loc* ( min obj -- min )
-
-! This will be a multimethod soon
-DEFER: %move
-
-MIXIN: value
-
-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-vregs* drop ;
-M: value live-loc? 2drop f ;
-M: value minimal-ds-loc* drop ;
-M: value lazy-store 2drop ;
-
-! A scratch register for computations
-TUPLE: vreg n reg-class ;
-
-C: <vreg> vreg ( n reg-class -- vreg )
-
-M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
-M: vreg live-vregs* , ;
-
-M: vreg move-spec
-    reg-class>> {
-        { [ dup int-regs? ] [ f ] }
-        { [ dup float-regs? ] [ float ] }
-    } cond nip ;
-
-M: vreg operand-class*
-    reg-class>> {
-        { [ dup int-regs? ] [ f ] }
-        { [ dup float-regs? ] [ float ] }
-    } cond nip ;
-
-INSTANCE: vreg value
-
-! Temporary register for stack shuffling
-SINGLETON: temp-reg
-
-M: temp-reg move-spec drop f ;
-
-INSTANCE: temp-reg value
-
-! A data stack location.
-TUPLE: ds-loc n class ;
-
-: <ds-loc> ( n -- loc ) f ds-loc boa ;
-
-M: ds-loc minimal-ds-loc* n>> min ;
-M: ds-loc live-loc?
-    over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-! A retain stack location.
-TUPLE: rs-loc n class ;
-
-: <rs-loc> ( n -- loc ) f rs-loc boa ;
-M: rs-loc live-loc?
-    over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
-
-UNION: loc ds-loc rs-loc ;
-
-M: loc operand-class* class>> ;
-M: loc set-operand-class (>>class) ;
-M: loc move-spec drop loc ;
-
-INSTANCE: loc value
-
-M: f move-spec drop loc ;
-M: f operand-class* ;
-
-! A stack location which has been loaded into a register. To
-! read the location, we just read the register, but when time
-! comes to save it back to the stack, we know the register just
-! contains a stack value so we don't have to redundantly write
-! it back.
-TUPLE: cached loc vreg ;
-
-C: <cached> cached
-
-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-vregs* vreg>> live-vregs* ;
-M: cached live-loc? loc>> live-loc? ;
-M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
-M: cached lazy-store
-    2dup loc>> live-loc?
-    [ "live-locs" get at %move ] [ 2drop ] if ;
-M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
-
-INSTANCE: cached value
-
-! A tagged pointer
-TUPLE: tagged vreg class ;
-
-: <tagged> ( vreg -- tagged )
-    f tagged boa ;
-
-M: tagged v>operand vreg>> v>operand ;
-M: tagged set-operand-class (>>class) ;
-M: tagged operand-class* class>> ;
-M: tagged move-spec drop f ;
-M: tagged live-vregs* vreg>> , ;
-
-INSTANCE: tagged value
-
-! Unboxed alien pointers
-TUPLE: unboxed-alien vreg ;
-C: <unboxed-alien> unboxed-alien
-M: unboxed-alien v>operand vreg>> v>operand ;
-M: unboxed-alien operand-class* drop simple-alien ;
-M: unboxed-alien move-spec class ;
-M: unboxed-alien live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-alien value
-
-TUPLE: unboxed-byte-array vreg ;
-C: <unboxed-byte-array> unboxed-byte-array
-M: unboxed-byte-array v>operand vreg>> v>operand ;
-M: unboxed-byte-array operand-class* drop c-ptr ;
-M: unboxed-byte-array move-spec class ;
-M: unboxed-byte-array live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-byte-array value
-
-TUPLE: unboxed-f vreg ;
-C: <unboxed-f> unboxed-f
-M: unboxed-f v>operand vreg>> v>operand ;
-M: unboxed-f operand-class* drop \ f ;
-M: unboxed-f move-spec class ;
-M: unboxed-f live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-f value
-
-TUPLE: unboxed-c-ptr vreg ;
-C: <unboxed-c-ptr> unboxed-c-ptr
-M: unboxed-c-ptr v>operand vreg>> v>operand ;
-M: unboxed-c-ptr operand-class* drop c-ptr ;
-M: unboxed-c-ptr move-spec class ;
-M: unboxed-c-ptr live-vregs* vreg>> , ;
-
-INSTANCE: unboxed-c-ptr value
-
-! A constant value
-TUPLE: constant value ;
-C: <constant> constant
-M: constant operand-class* value>> class ;
-M: constant move-spec class ;
-
-INSTANCE: constant value
-
-<PRIVATE
-
-! 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 ]
-    } 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.
-    temp-reg over %move
-    operand-class temp-reg
-    tagged new
-        swap >>vreg
-        swap >>class
-    %move ;
-
-: %move ( dst src -- )
-    2dup [ move-spec ] bi@ 2array {
-        { { f f } [ %move-bug ] }
-        { { f unboxed-c-ptr } [ %move-bug ] }
-        { { f unboxed-byte-array } [ %move-bug ] }
-
-        { { f constant } [ value>> swap load-literal ] }
-
-        { { 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 ] }
-        { { unboxed-c-ptr f } [ %unbox-c-ptr ] }
-        { { loc f } [ swap %replace ] }
-
-        [ drop %move-via-temp ]
-    } case ;
-
-! A compile-time stack
-TUPLE: phantom-stack height stack ;
-
-M: phantom-stack clone
-    call-next-method [ clone ] change-stack ;
-
-GENERIC: finalize-height ( stack -- )
-
-: new-phantom-stack ( class -- stack )
-    >r 0 V{ } clone r> boa ; inline
-
-: (loc) ( m stack -- n )
-    #! Utility for methods on <loc>
-    height>> - ;
-
-: (finalize-height) ( stack word -- )
-    #! We consolidate multiple stack height changes until the
-    #! last moment, and we emit the final height changing
-    #! instruction here.
-    [
-        over zero? [ 2drop ] [ execute ] if 0
-    ] curry change-height drop ; inline
-
-GENERIC: <loc> ( n stack -- loc )
-
-TUPLE: phantom-datastack < phantom-stack ;
-
-: <phantom-datastack> ( -- stack )
-    phantom-datastack new-phantom-stack ;
-
-M: phantom-datastack <loc> (loc) <ds-loc> ;
-
-M: phantom-datastack finalize-height
-    \ %inc-d (finalize-height) ;
-
-TUPLE: phantom-retainstack < phantom-stack ;
-
-: <phantom-retainstack> ( -- stack )
-    phantom-retainstack new-phantom-stack ;
-
-M: phantom-retainstack <loc> (loc) <rs-loc> ;
-
-M: phantom-retainstack finalize-height
-    \ %inc-r (finalize-height) ;
-
-: phantom-locs ( n phantom -- locs )
-    #! A sequence of n ds-locs or rs-locs indexing the stack.
-    >r <reversed> r> [ <loc> ] curry map ;
-
-: phantom-locs* ( phantom -- locs )
-    [ stack>> length ] keep phantom-locs ;
-
-: phantoms ( -- phantom phantom )
-    phantom-datastack get phantom-retainstack get ;
-
-: (each-loc) ( phantom quot -- )
-    >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
-
-: each-loc ( quot -- )
-    phantoms 2array swap [ (each-loc) ] curry each ; inline
-
-: adjust-phantom ( n phantom -- )
-    swap [ + ] curry change-height drop ;
-
-: cut-phantom ( n phantom -- seq )
-    swap [ cut* swap ] curry change-stack drop ;
-
-: phantom-append ( seq stack -- )
-    over length over adjust-phantom stack>> push-all ;
-
-: add-locs ( n phantom -- )
-    2dup stack>> length <= [
-        2drop
-    ] [
-        [ phantom-locs ] keep
-        [ stack>> length head-slice* ] keep
-        [ append >vector ] change-stack drop
-    ] if ;
-
-: phantom-input ( n phantom -- seq )
-    2dup add-locs
-    2dup cut-phantom
-    >r >r neg r> adjust-phantom r> ;
-
-: each-phantom ( quot -- ) phantoms rot bi@ ; inline
-
-: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
-
-: live-vregs ( -- seq )
-    [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
-
-: (live-locs) ( phantom -- seq )
-    #! Discard locs which haven't moved
-    [ phantom-locs* ] [ stack>> ] bi zip
-    [ live-loc? ] assoc-filter
-    values ;
-
-: 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
-
-! Computing free registers and initializing allocator
-: reg-spec>class ( spec -- class )
-    float eq? double-float-regs int-regs ? ;
-
-: free-vregs ( reg-class -- seq )
-    #! Free vregs in a given register class
-    \ free-vregs get at ;
-
-: alloc-vreg ( spec -- reg )
-    [ reg-spec>class free-vregs pop ] keep {
-        { f [ <tagged> ] }
-        { unboxed-alien [ <unboxed-alien> ] }
-        { unboxed-byte-array [ <unboxed-byte-array> ] }
-        { unboxed-f [ <unboxed-f> ] }
-        { unboxed-c-ptr [ <unboxed-c-ptr> ] }
-        [ drop ]
-    } case ;
-
-: compatible? ( value spec -- ? )
-    >r move-spec r> {
-        { [ 2dup = ] [ t ] }
-        { [ dup unboxed-c-ptr eq? ] [
-            over { unboxed-byte-array unboxed-alien } member?
-        ] }
-        [ f ]
-    } cond 2nip ;
-
-: allocation ( value spec -- reg-class )
-    {
-        { [ dup quotation? ] [ 2drop f ] }
-        { [ 2dup compatible? ] [ 2drop f ] }
-        [ nip reg-spec>class ]
-    } cond ;
-
-: alloc-vreg-for ( value spec -- vreg )
-    alloc-vreg swap operand-class
-    over tagged? [ >>class ] [ drop ] if ;
-
-M: value (lazy-load)
-    2dup allocation [
-        dupd alloc-vreg-for dup rot %move
-    ] [
-        drop
-    ] if ;
-
-: (compute-free-vregs) ( used class -- vector )
-    #! Find all vregs in 'class' which are not in 'used'.
-    [ vregs length reverse ] keep
-    [ <vreg> ] curry map swap diff
-    >vector ;
-
-: compute-free-vregs ( -- )
-    #! Create a new hashtable for thee free-vregs variable.
-    live-vregs
-    { int-regs double-float-regs }
-    [ 2dup (compute-free-vregs) ] H{ } map>assoc
-    \ free-vregs set
-    drop ;
-
-M: loc lazy-store
-    2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
-
-: do-shuffle ( hash -- )
-    dup assoc-empty? [
-        drop
-    ] [
-        "live-locs" set
-        [ lazy-store ] each-loc
-    ] if ;
-
-: fast-shuffle ( locs -- )
-    #! We have enough free registers to load all shuffle inputs
-    #! at once
-    [ dup f (lazy-load) ] H{ } map>assoc do-shuffle ;
-
-: minimal-ds-loc ( phantom -- n )
-    #! When shuffling more values than can fit in registers, we
-    #! need to find an area on the data stack which isn't in
-    #! use.
-    [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
-
-: find-tmp-loc ( -- n )
-    #! Find an area of the data stack which is not referenced
-    #! from the phantom stacks. We can clobber there all we want
-    [ minimal-ds-loc ] each-phantom min 1- ;
-
-: slow-shuffle-mapping ( locs tmp -- pairs )
-    >r dup length r>
-    [ swap - <ds-loc> ] curry map zip ;
-
-: slow-shuffle ( locs -- )
-    #! We don't have enough free registers to load all shuffle
-    #! inputs, so we use a single temporary register, together
-    #! with the area of the data stack above the stack pointer
-    find-tmp-loc slow-shuffle-mapping [
-        [
-            swap dup cached? [ vreg>> ] when %move
-        ] assoc-each
-    ] keep >hashtable do-shuffle ;
-
-: fast-shuffle? ( live-locs -- ? )
-    #! Test if we have enough free registers to load all
-    #! shuffle inputs at once.
-    int-regs free-vregs [ length ] bi@ <= ;
-
-: finalize-locs ( -- )
-    #! Perform any deferred stack shuffling.
-    [
-        \ free-vregs [ [ clone ] assoc-map ] change
-        live-locs dup fast-shuffle?
-        [ fast-shuffle ] [ slow-shuffle ] if
-    ] with-scope ;
-
-: finalize-vregs ( -- )
-    #! Store any vregs to their final stack locations.
-    [
-        dup loc? over cached? or [ 2drop ] [ %move ] if
-    ] each-loc ;
-
-: reset-phantom ( phantom -- )
-    #! Kill register assignments but preserve constants and
-    #! class information.
-    dup phantom-locs*
-    over stack>> [
-        dup constant? [ nip ] [
-            operand-class over set-operand-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 ;
-
-! Loading stacks to vregs
-: free-vregs? ( int# float# -- ? )
-    double-float-regs free-vregs length <=
-    >r int-regs free-vregs length <= r> and ;
-
-: phantom&spec ( phantom spec -- phantom' spec' )
-    >r stack>> r>
-    [ length f pad-left ] keep
-    [ <reversed> ] bi@ ; inline
-
-: phantom&spec-agree? ( phantom spec quot -- ? )
-    >r phantom&spec r> 2all? ; inline
-
-: vreg-substitution ( value vreg -- pair )
-    dupd <cached> 2array ;
-
-: substitute-vreg? ( old new -- ? )
-    #! We don't substitute locs for float or alien vregs,
-    #! since in those cases the boxing overhead might kill us.
-    vreg>> tagged? >r loc? r> and ;
-
-: substitute-vregs ( values vregs -- )
-    [ vreg-substitution ] 2map
-    [ substitute-vreg? ] assoc-filter >hashtable
-    [ >r stack>> r> substitute-here ] curry each-phantom ;
-
-: set-operand ( value var -- )
-    >r dup constant? [ value>> ] when r> set ;
-
-: lazy-load ( values template -- )
-    #! Set operand vars here.
-    2dup [ first (lazy-load) ] 2map
-    dup rot [ second set-operand ] 2each
-    substitute-vregs ;
-
-: load-inputs ( -- )
-    +input+ get
-    [ length phantom-datastack get phantom-input ] keep
-    lazy-load ;
-
-: output-vregs ( -- seq seq )
-    +output+ +clobber+ [ get [ get ] map ] bi@ ;
-
-: clash? ( seq -- ? )
-    phantoms [ stack>> ] bi@ append [
-        dup cached? [ vreg>> ] when swap member?
-    ] with contains? ;
-
-: outputs-clash? ( -- ? )
-    output-vregs append clash? ;
-
-: count-vregs ( reg-classes -- ) [ [ inc ] when* ] each ;
-
-: count-input-vregs ( phantom spec -- )
-    phantom&spec [
-        >r dup cached? [ vreg>> ] when r> first allocation
-    ] 2map count-vregs ;
-
-: count-scratch-regs ( spec -- )
-    [ first reg-spec>class ] map count-vregs ;
-
-: guess-vregs ( dinput rinput scratch -- int# float# )
-    [
-        0 int-regs set
-        0 double-float-regs set
-        count-scratch-regs
-        phantom-retainstack get swap count-input-vregs
-        phantom-datastack get swap count-input-vregs
-        int-regs get double-float-regs get
-    ] with-scope ;
-
-: alloc-scratch ( -- )
-    +scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
-
-: guess-template-vregs ( -- int# float# )
-    +input+ get { } +scratch+ get guess-vregs ;
-
-: template-inputs ( -- )
-    ! Load input values into registers
-    load-inputs
-    ! Allocate scratch registers
-    alloc-scratch
-    ! If outputs clash, we write values back to the stack
-    outputs-clash? [ finalize-contents ] when ;
-
-: template-outputs ( -- )
-    +output+ get [ get ] map phantom-datastack get phantom-append ;
-
-: value-matches? ( value spec -- ? )
-    #! If the spec is a quotation and the value is a literal
-    #! fixnum, see if the quotation yields true when applied
-    #! 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?
-        [ >r value>> r> call ] [ 2drop f ] if
-    ] [
-        2drop t
-    ] if ;
-
-: class-matches? ( actual expected -- ? )
-    {
-        { f [ drop t ] }
-        { known-tag [ dup [ class-tag >boolean ] when ] }
-        [ class<= ]
-    } case ;
-
-: spec-matches? ( value spec -- ? )
-    2dup first value-matches?
-    >r >r operand-class 2 r> ?nth class-matches? r> and ;
-
-: template-matches? ( spec -- ? )
-    phantom-datastack get +input+ rot at
-    [ spec-matches? ] phantom&spec-agree? ;
-
-: ensure-template-vregs ( -- )
-    guess-template-vregs free-vregs? [
-        finalize-contents compute-free-vregs
-    ] unless ;
-
-: clear-phantoms ( -- )
-    [ stack>> delete-all ] each-phantom ;
-
-PRIVATE>
-
-: set-operand-classes ( classes -- )
-    phantom-datastack get
-    over length over add-locs
-    stack>> [ set-operand-class ] 2reverse-each ;
-
-: end-basic-block ( -- )
-    #! 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 ;
-
-: with-template ( quot hash -- )
-    clone [
-        ensure-template-vregs
-        template-inputs call template-outputs
-    ] bind
-    compute-free-vregs ; inline
-
-: do-template ( pair -- )
-    #! Use with return value from find-template
-    first2 with-template ;
-
-: fresh-object ( obj -- ) fresh-objects get push ;
-
-: fresh-object? ( obj -- ? ) fresh-objects get memq? ;
-
-: init-templates ( -- )
-    #! Initialize register allocator.
-    V{ } clone fresh-objects set
-    <phantom-datastack> phantom-datastack set
-    <phantom-retainstack> phantom-retainstack set
-    compute-free-vregs ;
-
-: copy-templates ( -- )
-    #! Copies register allocator state, used when compiling
-    #! branches.
-    fresh-objects [ clone ] change
-    phantom-datastack [ clone ] change
-    phantom-retainstack [ clone ] change
-    compute-free-vregs ;
-
-: find-template ( templates -- pair/f )
-    #! Pair has shape { quot hash }
-    [ second template-matches? ] find nip ;
-
-: 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 ;
-
-: phantom-shuffle ( shuffle -- )
-    [ in>> length phantom-datastack get phantom-input ] keep
-    shuffle phantom-datastack get phantom-append ;
-
-: phantom->r ( n -- )
-    phantom-datastack get phantom-input
-    phantom-retainstack get phantom-append ;
-
-: phantom-r> ( n -- )
-    phantom-retainstack get phantom-input
-    phantom-datastack get phantom-append ;
-
-: phantom-drop ( n -- )
-    phantom-datastack get phantom-input drop ;
-
-: phantom-rdrop ( n -- )
-    phantom-retainstack get phantom-input drop ;

basis/compiler/generator/registers/summary.txt

@@ -1 +0,0 @@
-Register allocation and intrinsic selection

basis/compiler/intrinsics/intrinsics.factor

@@ -1,45 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes.tuple classes.tuple.private math arrays 
-byte-arrays words stack-checker.known-words ;
-IN: compiler.intrinsics
-
-ERROR: missing-intrinsic ;
-
-: (tuple) ( n -- tuple ) missing-intrinsic ;
-
-\ (tuple) { tuple-layout } { tuple } define-primitive
-\ (tuple) make-flushable
-
-: (array) ( n -- array ) missing-intrinsic ;
-
-\ (array) { integer } { array } define-primitive
-\ (array) make-flushable
-
-: (byte-array) ( n -- byte-array ) missing-intrinsic ;
-
-\ (byte-array) { integer } { byte-array } define-primitive
-\ (byte-array) make-flushable
-
-: (ratio) ( -- ratio ) missing-intrinsic ;
-
-\ (ratio) { } { ratio } define-primitive
-\ (ratio) make-flushable
-
-: (complex) ( -- complex ) missing-intrinsic ;
-
-\ (complex) { } { complex } define-primitive
-\ (complex) make-flushable
-
-: (wrapper) ( -- wrapper ) missing-intrinsic ;
-
-\ (wrapper) { } { wrapper } define-primitive
-\ (wrapper) make-flushable
-
-: (set-slot) ( val obj n -- ) missing-intrinsic ;
-
-\ (set-slot) { object object fixnum } { } define-primitive
-
-: (write-barrier) ( obj -- ) missing-intrinsic ;
-
-\ (write-barrier) { object } { } define-primitive

basis/compiler/tests/alien.factor

@@ -173,7 +173,7 @@ C-STRUCT: rect
     { "float" "h" }
 ;
 
-: <rect>
+: <rect> ( x y w h -- rect )
     "rect" <c-object>
     [ set-rect-h ] keep
     [ set-rect-w ] keep

basis/compiler/tests/intrinsics.factor

@@ -27,7 +27,7 @@ IN: compiler.tests
 
 [ 1 ] [ { 1 2 } [ 2 slot ] compile-call ] unit-test
 [ 1 ] [ [ { 1 2 } 2 slot ] compile-call ] unit-test
-[ 3 ] [ 3 1 2 2array [ [ 2 set-slot ] keep ] compile-call first ] unit-test
+[ 3 ] [ 3 1 2 2array [ { array } declare [ 2 set-slot ] keep ] compile-call first ] unit-test
 [ 3 ] [ 3 1 2 [ 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
 [ 3 ] [ [ 3 1 2 2array [ 2 set-slot ] keep ] compile-call first ] unit-test
 [ 3 ] [ 3 1 2 2array [ [ 3 set-slot ] keep ] compile-call second ] unit-test
@@ -252,31 +252,34 @@ cell 8 = [
 ! Some randomized tests
 : compiled-fixnum* fixnum* ;
 
-: test-fixnum* ( -- )
+[ ] [
+    10000 [ 
         32 random-bits >fixnum 32 random-bits >fixnum
         2dup
         [ fixnum* ] 2keep compiled-fixnum* =
-    [ 2drop ] [ "Oops" throw ] if ;
+        [ 2drop ] [ "Oops" throw ] if
-
+    ] times
-[ ] [ 10000 [ test-fixnum* ] times ] unit-test
+] unit-test
 
 : compiled-fixnum>bignum fixnum>bignum ;
 
-: test-fixnum>bignum ( -- )
+[ ] [
+    10000 [
         32 random-bits >fixnum
         dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
-    [ drop ] [ "Oops" throw ] if ;
+        [ drop ] [ "Oops" throw ] if
-
+    ] times
-[ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test
+] unit-test
 
 : compiled-bignum>fixnum bignum>fixnum ;
 
-: test-bignum>fixnum ( -- )
+[ ] [
+    10000 [
         5 random [ drop 32 random-bits ] map product >bignum
         dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
-    [ drop ] [ "Oops" throw ] if ;
+        [ drop ] [ "Oops" throw ] if
-
+    ] times
-[ ] [ 10000 [ test-bignum>fixnum ] times ] unit-test
+] unit-test
 
 ! Test overflow check removal
 [ t ] [
@@ -377,25 +380,23 @@ cell 8 = [
 [ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
 [ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
 
-: xword-def ( word -- def ) def>> [ { fixnum } declare ] prepend ;
-
 [ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
 [ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
 
-[ -100 ] [ -100 \ <char> xword-def compile-call *char ] unit-test
+[ -100 ] [ -100 \ <char> def>> [ { fixnum } declare ] prepend compile-call *char ] unit-test
-[ 156 ] [ -100 \ <uchar> xword-def compile-call *uchar ] unit-test
+[ 156 ] [ -100 \ <uchar> def>> [ { fixnum } declare ] prepend compile-call *uchar ] unit-test
 
 [ -1000 ] [ -1000 <short> [ { byte-array } declare *short ] compile-call ] unit-test
 [ 64536 ] [ -1000 <ushort> [ { byte-array } declare *ushort ] compile-call ] unit-test
 
-[ -1000 ] [ -1000 \ <short> xword-def compile-call *short ] unit-test
+[ -1000 ] [ -1000 \ <short> def>> [ { fixnum } declare ] prepend compile-call *short ] unit-test
-[ 64536 ] [ -1000 \ <ushort> xword-def compile-call *ushort ] unit-test
+[ 64536 ] [ -1000 \ <ushort> def>> [ { fixnum } declare ] prepend compile-call *ushort ] unit-test
 
 [ -100000 ] [ -100000 <int> [ { byte-array } declare *int ] compile-call ] unit-test
 [ 4294867296 ] [ -100000 <uint> [ { byte-array } declare *uint ] compile-call ] unit-test
 
-[ -100000 ] [ -100000 \ <int> xword-def compile-call *int ] unit-test
+[ -100000 ] [ -100000 \ <int> def>> [ { fixnum } declare ] prepend compile-call *int ] unit-test
-[ 4294867296 ] [ -100000 \ <uint> xword-def compile-call *uint ] unit-test
+[ 4294867296 ] [ -100000 \ <uint> def>> [ { fixnum } declare ] prepend compile-call *uint ] unit-test
 
 [ t ] [ pi pi <double> *double = ] unit-test
 
@@ -461,3 +462,21 @@ TUPLE: alien-accessor-regression { b byte-array } { i fixnum } ;
     ] compile-call
     b>>
 ] unit-test
+
+: mutable-value-bug-1 ( a b -- c )
+    swap [
+        { tuple } declare 1 slot
+    ] [
+        0 slot
+    ] if ;
+
+[ t ] [ f B{ } mutable-value-bug-1 byte-array type-number = ] unit-test
+
+: mutable-value-bug-2 ( a b -- c )
+    swap [
+        0 slot
+    ] [
+        { tuple } declare 1 slot
+    ] if ;
+
+[ t ] [ t B{ } mutable-value-bug-2 byte-array type-number = ] unit-test

basis/compiler/tests/simple.factor

@@ -1,8 +1,10 @@
-USING: compiler.units tools.test kernel kernel.private
+USING: compiler compiler.units tools.test kernel kernel.private
-sequences.private math.private math combinators strings
+sequences.private math.private math combinators strings alien
-alien arrays memory vocabs parser eval ;
+arrays memory vocabs parser eval ;
 IN: compiler.tests
 
+\ (compile) must-infer
+
 ! Test empty word
 [ ] [ [ ] compile-call ] unit-test
 
@@ -52,11 +54,11 @@ IN: compiler.tests
 
 ! Labels
 
-: recursive ( ? -- ) [ f recursive ] when ; inline
+: recursive-test ( ? -- ) [ f recursive-test ] when ; inline
 
-[ ] [ t [ recursive ] compile-call ] unit-test
+[ ] [ t [ recursive-test ] compile-call ] unit-test
 
-[ ] [ t recursive ] unit-test
+[ ] [ t recursive-test ] unit-test
 
 ! Make sure error reporting works
 

basis/compiler/tests/templates-early.factor

@@ -1,220 +0,0 @@
-! Testing templates machinery without compiling anything
-IN: compiler.tests
-USING: compiler compiler.generator compiler.generator.registers
-compiler.generator.registers.private tools.test namespaces
-sequences words kernel math effects definitions compiler.units
-accessors cpu.architecture make ;
-
-: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
-
-[
-    [ ] [ init-templates ] unit-test
-    
-    [ V{ 3 } ] [ 3 fresh-object fresh-objects get ] unit-test
-    
-    [ ] [ 0 <int-vreg> phantom-push ] unit-test
-    
-    [ ] [ compute-free-vregs ] unit-test
-    
-    [ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
-    
-    [ f ] [
-        [
-            copy-templates
-            1 <int-vreg> phantom-push
-            compute-free-vregs
-            1 <int-vreg> int-regs free-vregs member?
-        ] with-scope
-    ] unit-test
-    
-    [ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
-] with-scope
-
-[
-    [ ] [ init-templates ] unit-test
-    
-    [ ] [ T{ effect f 3 { 1 2 0 } f } phantom-shuffle ] unit-test
-    
-    [ 3 ] [ live-locs length ] unit-test
-    
-    [ ] [ T{ effect f 2 { 1 0 } f } phantom-shuffle ] unit-test
-    
-    [ 2 ] [ live-locs length ] unit-test
-] with-scope
-
-[
-    [ ] [ init-templates ] unit-test
-
-    H{ } clone compiled set
-
-    [ ] [ gensym gensym begin-compiling ] unit-test
-
-    [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-
-    3 fresh-object
-
-    [ f ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-[
-    [ ] [ init-templates ] unit-test
-    
-    H{
-        { +input+ { { f "x" } } }
-    } clone [
-        [ 1 0 ] [ +input+ get { } { } guess-vregs ] unit-test
-        [ ] [ finalize-contents ] unit-test
-        [ ] [ [ template-inputs ] { } make drop ] unit-test
-    ] bind
-] with-scope
-
-! Test template picking strategy
-SYMBOL: template-chosen
-
-: template-test ( a b -- c d ) ;
-
-\ template-test {
-    {
-        [
-            1 template-chosen get push
-        ] H{
-            { +input+ { { f "obj" } { [ ] "n" } } }
-            { +output+ { "obj" "obj" } }
-        }
-    }
-    {
-        [
-            2 template-chosen get push
-        ] H{
-            { +input+ { { f "obj" } { f "n" } } }
-            { +output+ { "obj" "n" } }
-        }
-    }
-} define-intrinsics
-
-[ V{ 2 } ] [
-    V{ } clone template-chosen set
-    0 0 [ template-test ] compile-call 2drop
-    template-chosen get
-] unit-test
-
-[ V{ 1 } ] [
-    V{ } clone template-chosen set
-    1 [ dup 0 template-test ] compile-call 3drop
-    template-chosen get
-] unit-test
-
-[ V{ 1 } ] [
-    V{ } clone template-chosen set
-    1 [ 0 template-test ] compile-call 2drop
-    template-chosen get
-] unit-test
-
-! Regression
-[
-    [ ] [ init-templates ] unit-test
-
-    ! dup dup
-    [ ] [
-        T{ effect f { "x" } { "x" "x" } } phantom-shuffle
-        T{ effect f { "x" } { "x" "x" } } phantom-shuffle
-    ] unit-test
-
-    ! This is not empty since a load instruction is emitted
-    [ f ] [
-        [ { { f "x" } } +input+ set load-inputs ] { } make
-        empty?
-    ] unit-test
-
-    ! This is empty since we already loaded the value
-    [ t ] [
-        [ { { f "x" } } +input+ set load-inputs ] { } make
-        empty?
-    ] unit-test
-
-    ! This is empty since we didn't change the stack
-    [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-! Regression
-[
-    [ ] [ init-templates ] unit-test
-
-    ! >r r>
-    [ ] [
-        1 phantom->r
-        1 phantom-r>
-    ] unit-test
-
-    ! This is empty since we didn't change the stack
-    [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-
-    ! >r r>
-    [ ] [
-        1 phantom->r
-        1 phantom-r>
-    ] unit-test
-
-    [ ] [ { object } set-operand-classes ] unit-test
-
-    ! This is empty since we didn't change the stack
-    [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
-] with-scope
-
-! Regression
-[
-    [ ] [ init-templates ] unit-test
-
-    [ ] [ { object object } set-operand-classes ] unit-test
-
-    ! 2dup
-    [ ] [
-        T{ effect f { "x" "y" } { "x" "y" "x" "y" } }
-        phantom-shuffle
-    ] unit-test
-
-    [ ] [
-        2 phantom-datastack get phantom-input
-        [ { { f "a" } { f "b" } } lazy-load ] { } make drop
-    ] unit-test
-    
-    [ t ] [
-        phantom-datastack get stack>> [ cached? ] all?
-    ] unit-test
-
-    ! >r
-    [ ] [
-        1 phantom->r
-    ] unit-test
-
-    ! This should not fail
-    [ ] [ [ end-basic-block ] { } make drop ] unit-test
-] with-scope
-
-! Regression
-SYMBOL: templates-chosen
-
-V{ } clone templates-chosen set
-
-: template-choice-1 ;
-
-\ template-choice-1
-[ "template-choice-1" templates-chosen get push ]
-H{
-    { +input+ { { f "obj" } { [ ] "n" } } }
-    { +output+ { "obj" } }
-} define-intrinsic
-
-: template-choice-2 ;
-
-\ template-choice-2
-[ "template-choice-2" templates-chosen get push drop ]
-{ { f "x" } { f "y" } } define-if-intrinsic
-
-[ ] [
-    [ 2 template-choice-1 template-choice-2 ]
-    [ define-temp ] with-compilation-unit drop
-] unit-test
-
-[ V{ "template-choice-1" "template-choice-2" } ]
-[ templates-chosen get ] unit-test

basis/compiler/tests/templates.factor

@@ -1,11 +1,15 @@
-! Black box testing of templating optimization
+USING: generalizations accessors arrays compiler kernel
-USING: accessors arrays compiler kernel kernel.private math
+kernel.private math hashtables.private math.private namespaces
-hashtables.private math.private namespaces sequences
+sequences sequences.private tools.test namespaces.private
-sequences.private tools.test namespaces.private slots.private
+slots.private sequences.private byte-arrays alien
-sequences.private byte-arrays alien alien.accessors layouts
+alien.accessors layouts words definitions compiler.units io
-words definitions compiler.units io combinators vectors ;
+combinators vectors ;
 IN: compiler.tests
 
+! Originally, this file did black box testing of templating
+! optimization. We now have a different codegen, but the tests
+! in here are still useful.
+
 ! Oops!
 [ 5000 ] [ [ 5000 ] compile-call ] unit-test
 [ "hi" ] [ [ "hi" ] compile-call ] unit-test
@@ -101,9 +105,8 @@ unit-test
     ] [ define-temp ] with-compilation-unit drop
 ] unit-test
 
-
 ! Test how dispatch handles the end of a basic block
-: try-breaking-dispatch ( n a b -- a b str )
+: try-breaking-dispatch ( n a b -- x str )
     float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
 
 : try-breaking-dispatch-2 ( -- ? )
@@ -122,7 +125,7 @@ unit-test
 ] unit-test
 
 ! Regression
-: hellish-bug-1 2drop ;
+: hellish-bug-1 ( a b -- ) 2drop ;
 
 : hellish-bug-2 ( i array x -- x ) 
     2dup 1 slot eq? [ 2drop ] [ 
@@ -132,7 +135,7 @@ unit-test
                 pick 2dup hellish-bug-1 3drop
             ] 2keep
         ] unless >r 2 fixnum+fast r> hellish-bug-2
-    ] if ; inline
+    ] if ; inline recursive
 
 : hellish-bug-3 ( hash array -- ) 
     0 swap hellish-bug-2 drop ;
@@ -189,7 +192,7 @@ TUPLE: my-tuple ;
 ] unit-test
 
 ! Regression
-: a-dummy ( -- ) drop "hi" print ;
+: a-dummy ( a -- ) drop "hi" print ;
 
 [ ] [
     1 [
@@ -245,8 +248,125 @@ TUPLE: my-tuple ;
         [ dup float+ ]
     } cleave ;
 
+[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
+[ 1.0 float-spill-bug ] unit-test
+
 [ t ] [ \ float-spill-bug compiled>> ] unit-test
 
+: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
+    {
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+        [ dup float+ ]
+        [ float>fixnum dup fixnum+fast ]
+    } cleave ;
+
+[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
+[ 1.0 float-fixnum-spill-bug ] unit-test
+
+[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
+
+: resolve-spill-bug ( a b -- c )
+    [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
+        nip 2 fixnum+fast
+    ] [
+        drop {
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+            [ dup fixnum+fast ]
+        } cleave
+        16 narray
+    ] if ;
+
+[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+
+[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
+
 ! Regression
 : dispatch-alignment-regression ( -- c )
     { tuple vector } 3 slot { word } declare
@@ -255,3 +375,8 @@ TUPLE: my-tuple ;
 [ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
 
 [ vector ] [ dispatch-alignment-regression ] unit-test
+
+! Regression
+: bad-value-bug ( a -- b ) [ 3 ] [ 3 ] if f <array> ;
+
+[ { f f f } ] [ t bad-value-bug ] unit-test

basis/compiler/tree/builder/builder.factor

@@ -7,7 +7,7 @@ stack-checker.backend compiler.tree ;
 IN: compiler.tree.builder
 
 : with-tree-builder ( quot -- nodes )
-    [ V{ } clone stack-visitor set ] prepose
+    '[ V{ } clone stack-visitor set @ ]
     with-infer ; inline
 
 : build-tree ( quot -- nodes )

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -5,7 +5,7 @@ strings sbufs sequences.private slots.private combinators
 definitions system layouts vectors math.partial-dispatch
 math.order math.functions accessors hashtables classes assocs
 io.encodings.utf8 io.encodings.ascii io.encodings fry slots
-sorting.private
+sorting.private combinators.short-circuit
 compiler.tree
 compiler.tree.combinators
 compiler.tree.cleanup
@@ -13,6 +13,7 @@ compiler.tree.builder
 compiler.tree.recursive
 compiler.tree.normalization
 compiler.tree.propagation
+compiler.tree.propagation.info
 compiler.tree.checker
 compiler.tree.debugger ;
 
@@ -494,3 +495,8 @@ cell-bits 32 = [
 [ t ] [
     [ hashtable new ] \ new inlined?
 ] unit-test
+
+[ t ] [
+    [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
+    [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
+] unit-test

basis/compiler/tree/cleanup/cleanup.factor

@@ -5,7 +5,6 @@ classes.algebra namespaces assocs words math math.private
 math.partial-dispatch math.intervals classes classes.tuple
 classes.tuple.private layouts definitions stack-checker.state
 stack-checker.branches
-compiler.intrinsics
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -79,7 +78,7 @@ GENERIC: cleanup* ( node -- node/nodes )
     } cond ;
 
 : remove-overflow-check ( #call -- #call )
-    [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
+    [ no-overflow-variant ] change-word cleanup* ;
 
 M: #call cleanup*
     {

basis/compiler/tree/combinators/combinators.factor

@@ -48,7 +48,7 @@ IN: compiler.tree.combinators
 : sift-children ( seq flags -- seq' )
     zip [ nip ] assoc-filter keys ;
 
-: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
+: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
 
 : 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
 

basis/compiler/tree/debugger/debugger.factor

@@ -24,7 +24,7 @@ IN: compiler.tree.debugger
 GENERIC: node>quot ( node -- )
 
 MACRO: match-choose ( alist -- )
-    [ [ ] curry ] assoc-map [ match-cond ] curry ;
+    [ '[ _ ] ] assoc-map '[ _ match-cond ] ;
 
 MATCH-VARS: ?a ?b ?c ;
 

basis/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -6,7 +6,7 @@ math.functions compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.combinators compiler.tree sequences math
 math.private kernel tools.test accessors slots.private
 quotations.private prettyprint classes.tuple.private classes
-classes.tuple compiler.intrinsics namespaces
+classes.tuple namespaces
 compiler.tree.propagation.info stack-checker.errors
 kernel.private ;
 

basis/compiler/tree/escape-analysis/simple/simple.factor

@@ -4,7 +4,6 @@ USING: kernel accessors sequences classes.tuple
 classes.tuple.private arrays math math.private slots.private
 combinators deques search-deques namespaces fry classes
 classes.algebra stack-checker.state
-compiler.intrinsics
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes

basis/compiler/tree/finalization/finalization.factor

@@ -1,10 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays accessors sequences sequences.private words
+USING: kernel accessors sequences words memoize classes.builtin
-fry namespaces make math math.order memoize classes.builtin
-classes.tuple.private slots.private combinators layouts
-byte-arrays alien.accessors
-compiler.intrinsics
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -15,14 +11,19 @@ IN: compiler.tree.finalization
 ! See the comment in compiler.tree.late-optimizations.
 
 ! This pass runs after propagation, so that it can expand
-! built-in type predicates and memory allocation; these cannot
+! built-in type predicates; these cannot be expanded before
-! be expanded before propagation since we need to see 'fixnum?'
+! propagation since we need to see 'fixnum?' instead of
-! instead of 'tag 0 eq?' and so on, for semantic reasoning.
+! 'tag 0 eq?' and so on, for semantic reasoning.
+
 ! We also delete empty stack shuffles and copies to facilitate
 ! tail call optimization in the code generator.
 
 GENERIC: finalize* ( node -- nodes )
 
+: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
+
+: splice-final ( quot -- nodes ) splice-quot finalize ;
+
 M: #copy finalize* drop f ;
 
 M: #shuffle finalize*
@@ -34,77 +35,12 @@ M: #shuffle finalize*
     word>> "predicating" word-prop builtin-class? ;
 
 MEMO: builtin-predicate-expansion ( word -- nodes )
-    def>> splice-quot ;
+    def>> splice-final ;
 
 : expand-builtin-predicate ( #call -- nodes )
     word>> builtin-predicate-expansion ;
 
-: first-literal ( #call -- obj ) node-input-infos first literal>> ;
-
-: last-literal ( #call -- obj ) node-input-infos peek literal>> ;
-
-: expand-tuple-boa? ( #call -- ? )
-    dup word>> \ <tuple-boa> eq? [
-        last-literal tuple-layout?
-    ] [ drop f ] if ;
-
-MEMO: (tuple-boa-expansion) ( n -- quot )
-    [
-        [ 2 + ] map <reversed>
-        [ '[ [ _ set-slot ] keep ] % ] each
-    ] [ ] make ;
-
-: tuple-boa-expansion ( layout -- quot )
-    #! No memoization here since otherwise we'd hang on to
-    #! tuple layout objects.
-    size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
-
-: expand-tuple-boa ( #call -- node )
-    last-literal tuple-boa-expansion ;
-
-MEMO: <array>-expansion ( n -- quot )
-    [
-        [ swap (array) ] %
-        [ \ 2dup , , [ swap set-array-nth ] % ] each
-        \ nip ,
-    ] [ ] make splice-quot ;
-
-: expand-<array>? ( #call -- ? )
-    dup word>> \ <array> eq? [
-        first-literal dup integer?
-        [ 0 32 between? ] [ drop f ] if
-    ] [ drop f ] if ;
-
-: expand-<array> ( #call -- node )
-    first-literal <array>-expansion ;
-
-: bytes>cells ( m -- n ) cell align cell /i ;
-
-MEMO: <byte-array>-expansion ( n -- quot )
-    [
-        [ (byte-array) ] %
-        bytes>cells [ cell * ] map
-        [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
-    ] [ ] make splice-quot ;
-
-: expand-<byte-array>? ( #call -- ? )
-    dup word>> \ <byte-array> eq? [
-        first-literal dup integer?
-        [ 0 128 between? ] [ drop f ] if
-    ] [ drop f ] if ;
-
-: expand-<byte-array> ( #call -- nodes )
-    first-literal <byte-array>-expansion ;
-
 M: #call finalize*
-    {
+    dup builtin-predicate? [ expand-builtin-predicate ] when ;
-        { [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
-        { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
-        { [ dup expand-<array>? ] [ expand-<array> ] }
-        { [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
-        [ ]
-    } cond ;
 
 M: node finalize* ;
-
-: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;

basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor

@@ -53,17 +53,8 @@ M: node maybe-modularize* 2drop ;
 GENERIC: compute-modularized-values* ( node -- )
 
 M: #call compute-modularized-values*
-    dup word>> {
+    dup word>> \ >fixnum eq?
-        { [ \ >fixnum eq? ] [ in-d>> first maybe-modularize ] }
+    [ in-d>> first maybe-modularize ] [ drop ] if ;
-        ! { [
-        !     {
-        !         mod-integer-fixnum
-        !         mod-integer-integer
-        !         mod-fixnum-integer
-        !     } memq?
-        ! ] [ ] }
-        [ drop ]
-    } cond ;
 
 M: node compute-modularized-values* drop ;
 

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -7,7 +7,6 @@ classes.algebra combinators generic.math splitting fry locals
 classes.tuple alien.accessors classes.tuple.private slots.private
 definitions
 stack-checker.state
-compiler.intrinsics
 compiler.tree.comparisons
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
@@ -277,10 +276,10 @@ generic-comparison-ops [
         }
     } cond
     [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
-    [ 2nip ] curry "outputs" set-word-prop
+    '[ 2drop _ ] "outputs" set-word-prop
 ] each
 
-{ <tuple> <tuple-boa> (tuple) } [
+{ <tuple> <tuple-boa> } [
     [
         literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
         [ clear ] dip

basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -4,7 +4,6 @@ USING: namespaces assocs accessors kernel combinators
 classes.algebra sequences sequences.deep slots.private
 classes.tuple.private math math.private arrays
 stack-checker.branches
-compiler.intrinsics
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info

basis/cpu/architecture/architecture.factor

@@ -2,9 +2,16 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generic kernel kernel.private math
 memory namespaces make sequences layouts system hashtables
-classes alien byte-arrays combinators words sets ;
+classes alien byte-arrays combinators words sets fry ;
 IN: cpu.architecture
 
+! Labels
+TUPLE: label offset ;
+
+: <label> ( -- label ) label new ;
+: define-label ( name -- ) <label> swap set ;
+: resolve-label ( label/name -- ) dup label? [ get ] unless , ;
+
 ! Register classes
 SINGLETON: int-regs
 SINGLETON: single-float-regs
@@ -12,6 +19,9 @@ SINGLETON: double-float-regs
 UNION: float-regs single-float-regs double-float-regs ;
 UNION: reg-class int-regs float-regs ;
 
+! Mapping from register class to machine registers
+HOOK: machine-registers cpu ( -- assoc )
+
 ! A pseudo-register class for parameters spilled on the stack
 SINGLETON: stack-params
 
@@ -25,67 +35,102 @@ GENERIC: param-reg ( n register-class -- reg )
 
 M: object param-reg param-regs nth ;
 
-! Sequence mapping vreg-n to native assembler registers
+HOOK: two-operand? cpu ( -- ? )
-GENERIC: vregs ( register-class -- regs )
 
-! Load a literal (immediate or indirect)
+HOOK: %load-immediate cpu ( reg obj -- )
-GENERIC# load-literal 1 ( obj vreg -- )
+HOOK: %load-indirect cpu ( reg obj -- )
 
-HOOK: load-indirect cpu ( obj reg -- )
+HOOK: %peek cpu ( vreg loc -- )
-
+HOOK: %replace cpu ( vreg loc -- )
-HOOK: stack-frame-size cpu ( frame-size -- n )
-
-TUPLE: stack-frame total-size size params return ;
-
-! Set up caller stack frame
-HOOK: %prologue cpu ( n -- )
-
-: %prologue-later ( -- ) \ %prologue-later , ;
-
-! Tear down stack frame
-HOOK: %epilogue cpu ( n -- )
-
-: %epilogue-later ( -- ) \ %epilogue-later , ;
-
-! Store word XT in stack frame
-HOOK: %save-word-xt cpu ( -- )
-
-! Store dispatch branch XT in stack frame
-HOOK: %save-dispatch-xt cpu ( -- )
-
-M: object %save-dispatch-xt %save-word-xt ;
-
-! 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 -- )
-
-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: stack-frame-size cpu ( stack-frame -- n )
-HOOK: %peek cpu ( vreg loc -- )
+HOOK: %call cpu ( word -- )
+HOOK: %jump-label cpu ( label -- )
+HOOK: %return cpu ( -- )
 
-! Store vreg to stack
+HOOK: %dispatch cpu ( src temp -- )
-HOOK: %replace cpu ( vreg loc -- )
+HOOK: %dispatch-label cpu ( word -- )
 
-! Box and unbox floats
+HOOK: %slot cpu ( dst obj slot tag temp -- )
+HOOK: %slot-imm cpu ( dst obj slot tag -- )
+HOOK: %set-slot cpu ( src obj slot tag temp -- )
+HOOK: %set-slot-imm cpu ( src obj slot tag -- )
+
+HOOK: %add     cpu ( dst src1 src2 -- )
+HOOK: %add-imm cpu ( dst src1 src2 -- )
+HOOK: %sub     cpu ( dst src1 src2 -- )
+HOOK: %sub-imm cpu ( dst src1 src2 -- )
+HOOK: %mul     cpu ( dst src1 src2 -- )
+HOOK: %mul-imm cpu ( dst src1 src2 -- )
+HOOK: %and     cpu ( dst src1 src2 -- )
+HOOK: %and-imm cpu ( dst src1 src2 -- )
+HOOK: %or      cpu ( dst src1 src2 -- )
+HOOK: %or-imm  cpu ( dst src1 src2 -- )
+HOOK: %xor     cpu ( dst src1 src2 -- )
+HOOK: %xor-imm cpu ( dst src1 src2 -- )
+HOOK: %shl-imm cpu ( dst src1 src2 -- )
+HOOK: %shr-imm cpu ( dst src1 src2 -- )
+HOOK: %sar-imm cpu ( dst src1 src2 -- )
+HOOK: %not     cpu ( dst src -- )
+
+HOOK: %integer>bignum cpu ( dst src temp -- )
+HOOK: %bignum>integer cpu ( dst src -- )
+
+HOOK: %add-float cpu ( dst src1 src2 -- )
+HOOK: %sub-float cpu ( dst src1 src2 -- )
+HOOK: %mul-float cpu ( dst src1 src2 -- )
+HOOK: %div-float cpu ( dst src1 src2 -- )
+
+HOOK: %integer>float cpu ( dst src -- )
+HOOK: %float>integer cpu ( dst src -- )
+
+HOOK: %copy cpu ( dst src -- )
+HOOK: %copy-float cpu ( dst src -- )
 HOOK: %unbox-float cpu ( dst src -- )
-HOOK: %box-float cpu ( dst src -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
+HOOK: %box-float cpu ( dst src temp -- )
+HOOK: %box-alien cpu ( dst src temp -- )
+
+HOOK: %alien-unsigned-1 cpu ( dst src -- )
+HOOK: %alien-unsigned-2 cpu ( dst src -- )
+HOOK: %alien-unsigned-4 cpu ( dst src -- )
+HOOK: %alien-signed-1   cpu ( dst src -- )
+HOOK: %alien-signed-2   cpu ( dst src -- )
+HOOK: %alien-signed-4   cpu ( dst src -- )
+HOOK: %alien-cell       cpu ( dst src -- )
+HOOK: %alien-float      cpu ( dst src -- )
+HOOK: %alien-double     cpu ( dst src -- )
+
+HOOK: %set-alien-integer-1 cpu ( ptr value -- )
+HOOK: %set-alien-integer-2 cpu ( ptr value -- )
+HOOK: %set-alien-integer-4 cpu ( ptr value -- )
+HOOK: %set-alien-cell      cpu ( ptr value -- )
+HOOK: %set-alien-float     cpu ( ptr value -- )
+HOOK: %set-alien-double    cpu ( ptr value -- )
+
+HOOK: %allot cpu ( dst size class temp -- )
+HOOK: %write-barrier cpu ( src card# table -- )
+HOOK: %gc cpu ( -- )
+
+HOOK: %prologue cpu ( n -- )
+HOOK: %epilogue cpu ( n -- )
+
+HOOK: %compare cpu ( dst cc src1 src2 -- )
+HOOK: %compare-imm cpu ( dst cc src1 src2 -- )
+HOOK: %compare-float cpu ( dst cc src1 src2 -- )
+
+HOOK: %compare-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
+
+HOOK: %spill-integer cpu ( src n -- )
+HOOK: %spill-float cpu ( src n -- )
+HOOK: %reload-integer cpu ( dst n -- )
+HOOK: %reload-float cpu ( dst n -- )
+
+HOOK: %loop-entry cpu ( -- )
 
 ! FFI stuff
 
@@ -96,7 +141,7 @@ 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?
+! Do we pass value structs by value or hidden reference?
 HOOK: value-structs? cpu ( -- ? )
 
 ! If t, fp parameters are shadowed by dummy int parameters
@@ -134,69 +179,34 @@ M: object %prepare-var-args ;
 
 HOOK: %alien-invoke cpu ( function library -- )
 
-HOOK: %cleanup cpu ( alien-node -- )
+HOOK: %cleanup cpu ( params -- )
+
+M: object %cleanup ( params -- ) drop ;
+
+HOOK: %prepare-alien-indirect cpu ( -- )
+
+HOOK: %alien-indirect cpu ( -- )
 
 HOOK: %alien-callback cpu ( quot -- )
 
 HOOK: %callback-value cpu ( ctype -- )
 
 ! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind cpu ( n -- )
+HOOK: %callback-return cpu ( params -- )
 
-HOOK: %prepare-alien-indirect cpu ( -- )
+M: object %callback-return drop %return ;
-
-HOOK: %alien-indirect cpu ( -- )
 
 M: stack-params param-reg drop ;
 
 M: stack-params param-regs drop f ;
 
-GENERIC: v>operand ( obj -- operand )
-
-M: integer v>operand tag-fixnum ;
-
-M: f v>operand drop \ f tag-number ;
-
-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
+    [ 2dup [ not ] [ struct-small-enough? ] bi* and ] 2dip
-    [ [ nip ] prepose ] dip if ;
+    [ '[ nip @ ] ] dip if ;
     inline
 
 : %unbox-struct ( n c-type -- )
-    [
+    [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
-        %unbox-small-struct
-    ] [
-        %unbox-large-struct
-    ] if-small-struct ;
 
 : %box-struct ( n c-type -- )
-    [
+    [ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
-        %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 ( -- )
-
-: operand ( var -- op ) get v>operand ; inline
-
-: unique-operands ( operands quot -- )
-    >r [ operand ] map prune r> each ; inline

basis/cpu/ppc/allot/allot.factor

@@ -66,7 +66,7 @@ M: ppc %box-float ( dst src -- )
         ! is it zero?
         0 over v>operand 0 CMPI
         "non-zero" get BNE
-        0 >bignum over load-literal
+        dup 0 >bignum %load-literal
         "end" get B
         ! it is non-zero
         "non-zero" resolve-label

basis/cpu/ppc/architecture/architecture.factor

@@ -128,8 +128,6 @@ M: ppc %dispatch-label ( word -- )
 
 M: ppc %return ( -- ) %epilogue-later BLR ;
 
-M: ppc %unwind drop %return ;
-
 M: ppc %peek ( vreg loc -- )
     >r v>operand r> loc>operand LWZ ;
 
@@ -267,8 +265,6 @@ M: ppc %callback-value ( ctype -- )
      ! Unbox former top of data stack to return registers
      unbox-return ;
 
-M: ppc %cleanup ( alien-node -- ) drop ;
-
 : %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
 
 : %tag-fixnum ( src dest -- ) tag-bits get SLWI ;

basis/cpu/ppc/assembler/assembler.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.generator.fixup kernel namespaces words
+USING: compiler.codegen.fixup kernel namespaces words
 io.binary math math.order cpu.ppc.assembler.backend ;
 IN: cpu.ppc.assembler
 

basis/cpu/ppc/assembler/backend/backend.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.generator.fixup kernel namespaces make sequences
+USING: compiler.codegen.fixup cpu.architecture
-words math math.bitwise io.binary parser lexer ;
+compiler.constants kernel namespaces make sequences words math
+math.bitwise io.binary parser lexer ;
 IN: cpu.ppc.assembler.backend
 
 : insn ( operand opcode -- ) { 26 0 } bitfield , ;

basis/cpu/ppc/bootstrap.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel kernel.private namespaces
-system cpu.ppc.assembler compiler.generator.fixup compiler.units
+system cpu.ppc.assembler compiler.codegen.fixup compiler.units
 compiler.constants math math.private layouts words words.private
 vocabs slots.private ;
 IN: bootstrap.ppc

basis/cpu/x86/32/32.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types arrays cpu.x86.assembler
+USING: locals alien.c-types alien.syntax arrays kernel
-cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
+math namespaces sequences system layouts io vocabs.loader
-cpu.architecture kernel kernel.private math namespaces sequences
+accessors init combinators command-line cpu.x86.assembler
-stack-checker.known-words compiler.generator.registers
+cpu.x86.architecture cpu.architecture compiler compiler.units
-compiler.generator.fixup compiler.generator system layouts
+compiler.constants compiler.alien compiler.codegen
-combinators command-line compiler compiler.units io
+compiler.codegen.fixup compiler.cfg.instructions
-vocabs.loader accessors init ;
+compiler.cfg.builder compiler.cfg.intrinsics ;
 IN: cpu.x86.32
 
 ! We implement the FFI for Linux, OS X and Windows all at once.
@@ -14,14 +14,18 @@ IN: cpu.x86.32
 ! 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 temp-reg-1 EAX ;
 M: x86.32 temp-reg-2 ECX ;
 
-M: temp-reg v>operand drop EBX ;
-
 M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
 
 M: x86.32 %alien-invoke (CALL) rel-dlsym ;
@@ -36,7 +40,6 @@ M: x86.32 struct-small-enough? ( size -- ? )
 ! On x86, parameters are never passed in registers.
 M: int-regs return-reg drop EAX ;
 M: int-regs param-regs drop { } ;
-M: int-regs vregs drop { EAX ECX EDX EBP } ;
 M: int-regs push-return-reg return-reg PUSH ;
 
 M: int-regs load-return-reg
@@ -46,7 +49,6 @@ M: int-regs store-return-reg
     [ stack@ ] [ return-reg ] bi* MOV ;
 
 M: float-regs param-regs drop { } ;
-M: float-regs vregs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
 : FSTP ( operand size -- ) 4 = [ FSTPS ] [ FSTPL ] if ;
 
@@ -72,12 +74,12 @@ M: float-regs store-return-reg
     [ [ align-sub ] [ call ] bi* ]
     [ [ align-add ] [ drop ] bi* ] 2bi ; inline
 
-M: x86.32 fixnum>slot@ 1 SHR ;
+M: x86.32 rel-literal-x86 rc-absolute-cell rel-literal ;
 
-M: x86.32 prepare-division CDQ ;
+M: x86.32 %prologue ( n -- )
-
+    dup PUSH
-M: x86.32 load-indirect
+    0 PUSH rc-absolute-cell rel-this
-    0 [] MOV rc-absolute-cell rel-literal ;
+    stack-reg swap 3 cells - SUB ;
 
 M: object %load-param-reg 3drop ;
 
@@ -219,7 +221,7 @@ M: x86.32 %alien-indirect ( -- )
 
 M: x86.32 %alien-callback ( quot -- )
     4 [
-        EAX load-indirect
+        EAX swap %load-indirect
         EAX PUSH
         "c_to_factor" f %alien-invoke
     ] with-aligned-stack ;
@@ -239,7 +241,7 @@ M: x86.32 %callback-value ( ctype -- )
     ! Unbox EAX
     unbox-return ;
 
-M: x86.32 %cleanup ( alien-node -- )
+M: x86.32 %cleanup ( params -- )
     #! 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.
@@ -256,7 +258,19 @@ M: x86.32 %cleanup ( alien-node -- )
         [ drop ]
     } cond ;
 
-M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
+M: x86.32 %callback-return ( n -- )
+    #! a) If the callback is stdcall, we have to clean up the
+    #! caller's stack frame.
+    #! b) If the callback is returning a large struct, we have
+    #! to fix ESP.
+    {
+        { [ dup abi>> "stdcall" = ] [
+            <alien-stack-frame>
+            [ params>> ] [ return>> ] bi +
+        ] }
+        { [ dup return>> large-struct? ] [ drop 4 ] }
+        [ drop 0 ]
+    } cond RET ;
 
 os windows? [
     cell "longlong" c-type (>>align)
@@ -264,34 +278,19 @@ os windows? [
     4 "double" c-type (>>align)
 ] unless
 
-: (sse2?) ( -- ? ) "Intrinsic" throw ;
+FUNCTION: bool check_sse2 ( ) ;
 
-<<
+: sse2? ( -- ? )
-
+    check_sse2 ;
-\ (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? [
+    [ optimized-recompile-hook ] recompile-hook
+    [ { check_sse2 } compile ] with-variable
+
     "Checking if your CPU supports SSE2..." print flush
-    [ optimized-recompile-hook ] recompile-hook [
+    sse2? [
-        [ sse2? ] compile-call
-    ] with-variable
-    [
         " - yes" print
-        "cpu.x86.sse2" require
+        enable-float-intrinsics
         [
             sse2? [
                 "This image was built to use SSE2, which your CPU does not support." print
@@ -300,7 +299,5 @@ os windows? [
                 1 exit
             ] unless
         ] "cpu.x86" add-init-hook
-    ] [
+    ] [ " - no" print ] if
-        " - no" print
-    ] if
 ] unless

basis/cpu/x86/32/bootstrap.factor

@@ -6,6 +6,9 @@ IN: bootstrap.x86
 
 4 \ cell set
 
+: shift-arg ( -- reg ) ECX ;
+: div-arg ( -- reg ) EAX ;
+: mod-arg ( -- reg ) EDX ;
 : arg0 ( -- reg ) EAX ;
 : arg1 ( -- reg ) EDX ;
 : temp-reg ( -- reg ) EBX ;

basis/cpu/x86/64/64.factor

@@ -1,43 +1,44 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays cpu.x86.assembler
+USING: accessors arrays kernel math namespaces make sequences
-cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
+system layouts alien alien.c-types alien.accessors alien.structs
-cpu.x86.allot cpu.architecture kernel kernel.private math
+slots splitting assocs combinators cpu.x86.assembler
-namespaces make sequences compiler.generator
+cpu.x86.architecture cpu.architecture compiler.constants
-compiler.generator.registers compiler.generator.fixup system
+compiler.codegen compiler.codegen.fixup
-layouts alien alien.accessors alien.structs slots splitting
+compiler.cfg.instructions compiler.cfg.builder
-assocs combinators ;
+compiler.cfg.intrinsics ;
 IN: cpu.x86.64
 
+M: x86.64 machine-registers
+    {
+        { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
+        { double-float-regs {
+            XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
+            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 temp-reg-1 RAX ;
 M: x86.64 temp-reg-2 RCX ;
 
-M: temp-reg v>operand drop RBX ;
-
 M: int-regs return-reg drop RAX ;
-M: int-regs vregs drop { RAX RCX RDX RBP RSI RDI R8 R9 R10 R11 R12 R13 } ;
 M: int-regs param-regs drop { RDI RSI RDX RCX R8 R9 } ;
 
 M: float-regs return-reg drop XMM0 ;
 
-M: float-regs vregs
-    drop {
-        XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7
-        XMM8 XMM9 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15
-    } ;
-
 M: float-regs param-regs
     drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
-M: x86.64 fixnum>slot@ drop ;
+M: x86.64 rel-literal-x86 rc-relative rel-literal ;
 
-M: x86.64 prepare-division CQO ;
+M: x86.64 %prologue ( n -- )
-
+    temp-reg-1 0 MOV rc-absolute-cell rel-this
-M: x86.64 load-indirect ( literal reg -- )
+    dup PUSH
-    0 [] MOV rc-relative rel-literal ;
+    temp-reg-1 PUSH
+    stack-reg swap 3 cells - SUB ;
 
 M: stack-params %load-param-reg
     drop
@@ -199,7 +200,8 @@ M: x86.64 %alien-indirect ( -- )
     RBP CALL ;
 
 M: x86.64 %alien-callback ( quot -- )
-    RDI load-indirect "c_to_factor" f %alien-invoke ;
+    RDI swap %load-indirect
+    "c_to_factor" f %alien-invoke ;
 
 M: x86.64 %callback-value ( ctype -- )
     ! Save top of data stack
@@ -215,16 +217,9 @@ M: x86.64 %callback-value ( ctype -- )
     ! Unbox former top of data stack to return registers
     unbox-return ;
 
-M: x86.64 %cleanup ( alien-node -- ) drop ;
+! The result of reading 4 bytes from memory is a fixnum on
+! x86-64.
+enable-alien-4-intrinsics
 
-M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
+! SSE2 is always available on x86-64.
-
+enable-float-intrinsics
-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

basis/cpu/x86/64/bootstrap.factor

@@ -6,6 +6,9 @@ IN: bootstrap.x86
 
 8 \ cell set
 
+: shift-arg ( -- reg ) RCX ;
+: div-arg ( -- reg ) RAX ;
+: mod-arg ( -- reg ) RDX ;
 : arg0 ( -- reg ) RDI ;
 : arg1 ( -- reg ) RSI ;
 : temp-reg ( -- reg ) RBX ;

basis/cpu/x86/allot/allot.factor

@@ -1,119 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel cpu.architecture cpu.x86.assembler
-cpu.x86.architecture kernel.private namespaces math sequences
-generic arrays compiler.generator compiler.generator.fixup
-compiler.generator.registers system layouts alien ;
-IN: cpu.x86.allot
-
-: 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
-    0 frame-required
-    %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
-
-: %store-tagged ( reg tag -- )
-    >r dup fresh-object v>operand r>
-    allot-reg swap tag-number OR
-    allot-reg MOV ;
-
-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 ;
-
-: %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 load-literal ! 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 v>operand MOV
-            2 object@ f v>operand 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 ;

basis/cpu/x86/architecture/architecture.factor

@@ -1,29 +1,473 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays cpu.x86.assembler
+USING: accessors assocs alien alien.c-types arrays
-cpu.x86.assembler.private cpu.architecture kernel kernel.private
+cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
-math memory namespaces make sequences words compiler.generator
+kernel kernel.private math memory namespaces make sequences
-compiler.generator.registers compiler.generator.fixup system
+words system layouts combinators math.order fry locals
-layouts combinators compiler.constants math.order ;
+compiler.constants compiler.cfg.registers
+compiler.cfg.instructions compiler.codegen
+compiler.codegen.fixup ;
 IN: cpu.x86.architecture
 
+M: x86 two-operand? t ;
+
+HOOK: temp-reg-1 cpu ( -- reg )
+HOOK: temp-reg-2 cpu ( -- reg )
+
+M: x86 %load-immediate MOV ;
+
+HOOK: rel-literal-x86 cpu ( literal -- )
+
+M: x86 %load-indirect swap 0 [] MOV rel-literal-x86 ;
+
 HOOK: ds-reg cpu ( -- reg )
 HOOK: rs-reg cpu ( -- reg )
-HOOK: stack-reg cpu ( -- reg )
-
-: stack@ ( n -- op ) stack-reg swap [+] ;
-
-: next-stack@ ( n -- operand )
-    #! nth parameter from the next stack frame. Used to box
-    #! input values to callbacks; the callback has its own
-    #! stack frame set up, and we want to read the frame
-    #! set up by the caller.
-    stack-frame get total-size>> + stack@ ;
 
 : 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: x86 %peek loc>operand MOV ;
+M: x86 %replace loc>operand swap MOV ;
+: (%inc) ( n reg -- ) swap cells dup 0 > [ ADD ] [ neg SUB ] if ; inline
+M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
+M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
+
+: align-stack ( n -- n' )
+    os macosx? cpu x86.64? or [ 16 align ] when ;
+
+M: x86 stack-frame-size ( stack-frame -- i )
+    [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+    [ params>> ]
+    [ return>> ]
+    tri + +
+    3 cells +
+    align-stack ;
+
+M: x86 %call ( label -- ) CALL ;
+M: x86 %jump-label ( label -- ) JMP ;
+M: x86 %return ( -- ) 0 RET ;
+
+: code-alignment ( align -- n )
+    [ building get [ integer? ] count dup ] dip align swap - ;
+
+: align-code ( n -- )
+    0 <repetition> % ;
+
+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.
+    ! Add jump table base
+    temp HEX: ffffffff MOV rc-absolute-cell rel-here
+    src temp ADD
+    src HEX: 7f [+] JMP
+    ! Fix up the displacement above
+    cell 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 ;
+
+:: (%slot) ( obj slot tag temp -- op )
+    temp slot obj [+] LEA
+    temp tag neg [+] ; inline
+
+:: (%slot-imm) ( obj slot tag -- op )
+    obj slot cells tag - [+] ; inline
+
+M: x86 %slot ( dst obj slot tag temp -- ) (%slot) MOV ;
+M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
+M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ;
+M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
+
+M: x86 %add     [+] LEA ;
+M: x86 %add-imm [+] LEA ;
+M: x86 %sub     nip SUB ;
+M: x86 %sub-imm neg [+] LEA ;
+M: x86 %mul     nip swap IMUL2 ;
+M: x86 %mul-imm nip IMUL2 ;
+M: x86 %and     nip AND ;
+M: x86 %and-imm nip AND ;
+M: x86 %or      nip OR ;
+M: x86 %or-imm  nip OR ;
+M: x86 %xor     nip XOR ;
+M: x86 %xor-imm nip XOR ;
+M: x86 %shl-imm nip SHL ;
+M: x86 %shr-imm nip SHR ;
+M: x86 %sar-imm nip SAR ;
+M: x86 %not     drop NOT ;
+
+: bignum@ ( reg n -- op )
+    cells bignum tag-number - [+] ; inline
+
+M:: x86 %integer>bignum ( dst src temp -- )
+    #! 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" } [ define-label ] each
+        src 0 CMP ! is it zero?
+        "nonzero" get JNE
+        ! Use cached zero value
+        dst 0 >bignum %load-indirect
+        "end" get JMP
+        "nonzero" resolve-label
+        ! Allocate a bignum
+        dst 4 cells bignum temp %allot
+        ! Write length
+        dst 1 bignum@ 2 tag-fixnum MOV
+        ! Test sign
+        src 0 CMP
+        "positive" get JGE
+        dst 2 bignum@ 1 MOV ! negative sign
+        src NEG
+        dst 3 bignum@ src MOV
+        src NEG ! we don't want to clobber src
+        "end" get JMP
+        "positive" resolve-label
+        dst 2 bignum@ 0 MOV ! positive sign
+        dst 3 bignum@ src MOV
+        "end" resolve-label
+    ] with-scope ;
+
+M:: x86 %bignum>integer ( dst src -- )
+    [
+        "nonzero" define-label
+        "end" define-label
+        dst src 1 bignum@ MOV
+         ! if the length is 1, its just the sign and nothing else,
+         ! so output 0
+        dst 1 tag-fixnum CMP
+        "nonzero" get JNE
+        dst 0 MOV
+        "end" get JMP
+        "nonzero" resolve-label
+        ! load the value
+        dst src 3 bignum@ MOV
+        ! is the sign negative?
+        src 2 bignum@ 0 CMP
+        "end" get JE
+        dst NEG
+        "end" resolve-label
+    ] with-scope ;
+
+M: x86 %add-float nip ADDSD ;
+M: x86 %sub-float nip SUBSD ;
+M: x86 %mul-float nip MULSD ;
+M: x86 %div-float nip DIVSD ;
+
+M: x86 %integer>float CVTSI2SD ;
+M: x86 %float>integer CVTTSD2SI ;
+
+: ?MOV ( dst src -- )
+    2dup = [ 2drop ] [ MOV ] if ; inline
+
+M: x86 %copy ( dst src -- ) ?MOV ;
+
+M: x86 %copy-float ( dst src -- )
+    2dup = [ 2drop ] [ MOVSD ] if ;
+
+M: x86 %unbox-float ( dst src -- )
+    float-offset [+] MOVSD ;
+
+M:: x86 %unbox-any-c-ptr ( dst src temp -- )
+    [
+        { "is-byte-array" "end" "start" } [ define-label ] each
+        dst 0 MOV
+        temp src MOV
+        ! We come back here with displaced aliens
+        "start" resolve-label
+        ! Is the object f?
+        temp \ f tag-number CMP
+        "end" get JE
+        ! Is the object an alien?
+        temp header-offset [+] alien type-number tag-fixnum CMP
+        "is-byte-array" get JNE
+        ! If so, load the offset and add it to the address
+        dst temp alien-offset [+] ADD
+        ! Now recurse on the underlying alien
+        temp temp underlying-alien-offset [+] MOV
+        "start" get JMP
+        "is-byte-array" resolve-label
+        ! Add byte array address to address being computed
+        dst temp ADD
+        ! Add an offset to start of byte array's data
+        dst byte-array-offset ADD
+        "end" resolve-label
+    ] with-scope ;
+
+M:: x86 %box-float ( dst src temp -- )
+    dst 16 float temp %allot
+    dst float-offset [+] src MOVSD ;
+
+: alien@ ( reg n -- op ) cells object tag-number - [+] ;
+
+M:: x86 %box-alien ( dst src temp -- )
+    [
+        { "end" "f" } [ define-label ] each
+        src 0 CMP
+        "f" get JE
+        dst 4 cells alien temp %allot
+        dst 1 alien@ \ f tag-number MOV
+        dst 2 alien@ \ f tag-number MOV
+        ! Store src in alien-offset slot
+        dst 3 alien@ src MOV
+        "end" get JMP
+        "f" resolve-label
+        dst \ f tag-number MOV
+        "end" resolve-label
+    ] with-scope ;
+
+: small-reg-4 ( reg -- reg' )
+    H{
+        { EAX EAX }
+        { ECX ECX }
+        { EDX EDX }
+        { EBX EBX }
+        { ESP ESP }
+        { EBP EBP }
+        { ESI ESP }
+        { EDI EDI }
+
+        { RAX EAX }
+        { RCX ECX }
+        { RDX EDX }
+        { RBX EBX }
+        { RSP ESP }
+        { RBP EBP }
+        { RSI ESP }
+        { RDI EDI }
+    } at ; inline
+
+: small-reg-2 ( reg -- reg' )
+    small-reg-4 H{
+        { EAX AX }
+        { ECX CX }
+        { EDX DX }
+        { EBX BX }
+        { ESP SP }
+        { EBP BP }
+        { ESI SI }
+        { EDI DI }
+    } at ; inline
+
+: small-reg-1 ( reg -- reg' )
+    small-reg-4 {
+        { EAX AL }
+        { ECX CL }
+        { EDX DL }
+        { EBX BL }
+    } at ; inline
+
+: small-reg ( reg size -- reg' )
+    {
+        { 1 [ small-reg-1 ] }
+        { 2 [ small-reg-2 ] }
+        { 4 [ small-reg-4 ] }
+    } case ;
+
+: small-regs ( -- regs ) { EAX ECX EDX EBX } ; inline
+
+: small-reg-that-isn't ( exclude -- reg' )
+    small-reg-4 small-regs [ eq? not ] with find nip ;
+
+: with-save/restore ( reg quot -- )
+    [ drop PUSH ] [ call ] [ drop POP ] 2tri ; inline
+
+:: with-small-register ( dst src quot: ( dst src -- ) -- )
+    #! If the destination register overlaps a small register, we
+    #! call the quot with that. Otherwise, we find a small
+    #! register that is not equal to src, and call quot, saving
+    #! and restoring the small register.
+    dst small-reg-4 small-regs memq? [ dst src quot call ] [
+        src small-reg-that-isn't
+        [| new-dst |
+            new-dst src quot call
+            dst new-dst MOV
+        ] with-save/restore
+    ] if ; inline
+
+: %alien-integer-getter ( dst src size quot -- )
+    '[ [ dup _ small-reg dup ] [ [] ] bi* MOV @ ]
+    with-small-register ; inline
+
+: %alien-unsigned-getter ( dst src size -- )
+    [ MOVZX ] %alien-integer-getter ; inline
+
+M: x86 %alien-unsigned-1 1 %alien-unsigned-getter ;
+M: x86 %alien-unsigned-2 2 %alien-unsigned-getter ;
+
+: %alien-signed-getter ( dst src size -- )
+    [ MOVSX ] %alien-integer-getter ; inline
+
+M: x86 %alien-signed-1 1 %alien-signed-getter ;
+M: x86 %alien-signed-2 2 %alien-signed-getter ;
+M: x86 %alien-signed-4 4 %alien-signed-getter ;
+
+M: x86 %alien-unsigned-4 4 [ 2drop ] %alien-integer-getter ;
+
+M: x86 %alien-cell [] MOV ;
+M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
+M: x86 %alien-double [] MOVSD ;
+
+:: %alien-integer-setter ( ptr value size -- )
+    value ptr [| new-value ptr |
+        new-value value ?MOV
+        ptr [] new-value size small-reg MOV
+    ] with-small-register ; inline
+
+M: x86 %set-alien-integer-1 1 %alien-integer-setter ;
+M: x86 %set-alien-integer-2 2 %alien-integer-setter ;
+M: x86 %set-alien-integer-4 4 %alien-integer-setter ;
+M: x86 %set-alien-cell [ [] ] dip MOV ;
+M: x86 %set-alien-float dup dup CVTSD2SS [ [] ] dip MOVSS ;
+M: x86 %set-alien-double [ [] ] dip MOVSD ;
+
+: load-zone-ptr ( reg -- )
+    #! Load pointer to start of zone array
+    0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
+
+: load-allot-ptr ( nursery-ptr allot-ptr -- )
+    [ drop load-zone-ptr ] [ swap cell [+] MOV ] 2bi ;
+
+: inc-allot-ptr ( nursery-ptr n -- )
+    [ cell [+] ] dip 8 align ADD ;
+
+: store-header ( temp type -- )
+    [ [] ] [ type-number tag-fixnum ] bi* MOV ;
+
+: store-tagged ( dst tag -- )
+    tag-number OR ;
+
+M:: x86 %allot ( dst size class nursery-ptr -- )
+    nursery-ptr dst load-allot-ptr
+    dst class store-header
+    dst class store-tagged
+    nursery-ptr size inc-allot-ptr ;
+
+HOOK: %alien-global cpu ( symbol dll register -- )
+
+M:: x86 %write-barrier ( src card# table -- )
+    #! Mark the card pointed to by vreg.
+    ! Mark the card
+    card# src MOV
+    card# card-bits SHR
+    "cards_offset" f table %alien-global
+    table card# [+] card-mark <byte> MOV
+
+    ! Mark the card deck
+    card# deck-bits card-bits - SHR
+    "decks_offset" f table %alien-global
+    table card# [+] card-mark <byte> MOV ;
+
+M: x86 %gc ( -- )
+    "end" define-label
+    temp-reg-1 load-zone-ptr
+    temp-reg-2 temp-reg-1 cell [+] MOV
+    temp-reg-2 1024 ADD
+    temp-reg-1 temp-reg-1 3 cells [+] MOV
+    temp-reg-2 temp-reg-1 CMP
+    "end" get JLE
+    %prepare-alien-invoke
+    "minor_gc" f %alien-invoke
+    "end" resolve-label ;
+
+HOOK: stack-reg cpu ( -- reg )
+
+: decr-stack-reg ( n -- )
+    dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
+
+: incr-stack-reg ( n -- )
+    dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
+
+M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
+
+: %boolean ( dst word -- )
+    over \ f tag-number MOV
+    0 [] swap execute
+    \ t rel-literal-x86 ; inline
+
+M: x86 %compare ( dst cc src1 src2 -- )
+    CMP {
+        { cc< [ \ CMOVL %boolean ] }
+        { cc<= [ \ CMOVLE %boolean ] }
+        { cc> [ \ CMOVG %boolean ] }
+        { cc>= [ \ CMOVGE %boolean ] }
+        { cc= [ \ CMOVE %boolean ] }
+        { cc/= [ \ CMOVNE %boolean ] }
+    } case ;
+
+M: x86 %compare-imm ( dst cc src1 src2 -- )
+    %compare ;
+
+M: x86 %compare-float ( dst cc src1 src2 -- )
+    UCOMISD {
+        { cc< [ \ CMOVB %boolean ] }
+        { cc<= [ \ CMOVBE %boolean ] }
+        { cc> [ \ CMOVA %boolean ] }
+        { cc>= [ \ CMOVAE %boolean ] }
+        { cc= [ \ CMOVE %boolean ] }
+        { cc/= [ \ CMOVNE %boolean ] }
+    } case ;
+
+M: x86 %compare-branch ( label cc src1 src2 -- )
+    CMP {
+        { cc< [ JL ] }
+        { cc<= [ JLE ] }
+        { cc> [ JG ] }
+        { cc>= [ JGE ] }
+        { cc= [ JE ] }
+        { cc/= [ JNE ] }
+    } case ;
+
+M: x86 %compare-imm-branch ( label src1 src2 cc -- )
+    %compare-branch ;
+
+M: x86 %compare-float-branch ( label cc src1 src2 -- )
+    UCOMISD {
+        { cc< [ JB ] }
+        { cc<= [ JBE ] }
+        { cc> [ JA ] }
+        { cc>= [ JAE ] }
+        { cc= [ JE ] }
+        { cc/= [ JNE ] }
+    } case ;
+
+: stack@ ( n -- op ) stack-reg swap [+] ;
+
+: spill-integer-base ( stack-frame -- n )
+    [ params>> ] [ return>> ] bi + ;
+
+: spill-integer@ ( n -- op )
+    cells
+    stack-frame get spill-integer-base
+    + stack@ ;
+
+: spill-float-base ( stack-frame -- n )
+    [ spill-counts>> int-regs swap at int-regs reg-size * ]
+    [ params>> ]
+    [ return>> ]
+    tri + + ;
+
+: spill-float@ ( n -- op )
+    double-float-regs reg-size *
+    stack-frame get spill-float-base
+    + stack@ ;
+
+M: x86 %spill-integer ( src n -- ) spill-integer@ swap MOV ;
+M: x86 %reload-integer ( dst n -- ) spill-integer@ MOV ;
+
+M: x86 %spill-float spill-float@ swap MOVSD ;
+M: x86 %reload-float spill-float@ MOVSD ;
+
+M: x86 %loop-entry
+    16 code-alignment [ NOP ] times ;
 
 M: int-regs %save-param-reg drop >r stack@ r> MOV ;
 M: int-regs %load-param-reg drop swap stack@ MOV ;
@@ -31,7 +475,6 @@ 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 ;
@@ -41,100 +484,15 @@ GENERIC: push-return-reg ( reg-class -- )
 GENERIC: load-return-reg ( n reg-class -- )
 GENERIC: store-return-reg ( n 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: immediate load-literal v>operand swap v>operand MOV ;
-
-: align-stack ( n -- n' )
-    os macosx? cpu x86.64? or [ 16 align ] when ;
-
-M: x86 stack-frame-size ( n -- i )
-    3 cells + align-stack ;
-
-M: x86 %save-word-xt ( -- )
-    temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
-
-: decr-stack-reg ( n -- )
-    dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
-
-M: x86 %prologue ( n -- )
-    dup PUSH
-    temp-reg v>operand PUSH
-    3 cells - decr-stack-reg ;
-
-: incr-stack-reg ( n -- )
-    dup 0 = [ drop ] [ stack-reg swap ADD ] if ;
-
-M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
-
-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 v>operand %alien-global
+    "stack_chain" f temp-reg-1 %alien-global
-    temp-reg v>operand [] stack-reg MOV
+    temp-reg-1 [] stack-reg MOV
-    temp-reg v>operand [] cell SUB
+    temp-reg-1 [] cell SUB
-    temp-reg v>operand 2 cells [+] ds-reg MOV
+    temp-reg-1 2 cells [+] ds-reg MOV
-    temp-reg v>operand 3 cells [+] rs-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 -- )
-    "flag" operand f v>operand CMP JE ;
-
-: code-alignment ( -- n )
-    building get length dup cell align swap - ;
-
-: align-code ( n -- )
-    0 <repetition> % ;
-
-M: x86 %dispatch ( -- )
-    [
-        %epilogue-later
-        ! 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
-        "n" operand fixnum>slot@
-        ! Add jump table base
-        "offset" operand HEX: ffffffff MOV rc-absolute-cell rel-here
-        "n" operand "offset" operand ADD
-        "n" operand HEX: 7f [+] JMP
-        ! Fix up the displacement above
-        code-alignment dup bootstrap-cell 8 = 15 9 ? +
-        building get dup pop* push
-        align-code
-    ] H{
-        { +input+ { { f "n" } } }
-        { +scratch+ { { f "offset" } } }
-        { +clobber+ { "n" } }
-    } with-template ;
-
-M: x86 %dispatch-label ( word -- )
-    0 cell, rc-absolute-cell rel-word ;
-
-M: x86 %unbox-float ( dst src -- )
-    [ v>operand ] bi@ float-offset [+] MOVSD ;
-
-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 ;
 
@@ -143,54 +501,9 @@ M: x86 value-structs? t ;
 M: x86 small-enough? ( n -- ? )
     HEX: -80000000 HEX: 7fffffff between? ;
 
-: %untag ( reg -- ) tag-mask get bitnot AND ;
+: next-stack@ ( n -- operand )
-
+    #! nth parameter from the next stack frame. Used to box
-: %untag-fixnum ( reg -- ) tag-bits get SAR ;
+    #! input values to callbacks; the callback has its own
-
+    #! stack frame set up, and we want to read the frame
-: %tag-fixnum ( reg -- ) tag-bits get SHL ;
+    #! set up by the caller.
-
+    stack-frame get total-size>> + stack@ ;
-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 v>operand 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 ;

basis/cpu/x86/assembler/assembler-tests.factor

@@ -57,3 +57,8 @@ IN: cpu.x86.assembler.tests
 
 [ { HEX: 49 HEX: 89 HEX: 04 HEX: 2c } ] [ [ R12 RBP [+] RAX MOV ] { } make ] unit-test
 [ [ R12 RSP [+] RAX MOV ] { } make ] must-fail
+
+[ { HEX: 48 HEX: d3 HEX: e0 } ] [ [ RAX CL SHL ] { } make ] unit-test
+[ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
+[ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
+[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test

basis/cpu/x86/assembler/assembler.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays compiler.generator.fixup io.binary kernel
+USING: arrays cpu.architecture compiler.constants
-combinators kernel.private math namespaces make sequences
+compiler.codegen.fixup io.binary kernel combinators
-words system layouts math.order accessors
+kernel.private math namespaces make sequences words system
-cpu.x86.assembler.syntax ;
+layouts math.order accessors cpu.x86.assembler.syntax ;
 IN: cpu.x86.assembler
 
 ! A postfix assembler for x86 and AMD64.
@@ -379,6 +379,8 @@ GENERIC: CMP ( dst src -- )
 M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
 M: operand CMP OCT: 070 2-operand ;
 
+: XCHG ( dst src -- ) OCT: 207 2-operand ;
+
 : NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
 : NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
 : MUL  ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;
@@ -389,13 +391,20 @@ M: operand CMP OCT: 070 2-operand ;
 : CDQ ( -- ) HEX: 99 , ;
 : CQO ( -- ) HEX: 48 , CDQ ;
 
-: ROL ( dst n -- ) swap { BIN: 000 t HEX: c0 } immediate-1 ;
+: (SHIFT) ( dst src op -- )
-: ROR ( dst n -- ) swap { BIN: 001 t HEX: c0 } immediate-1 ;
+    over CL eq? [
-: RCL ( dst n -- ) swap { BIN: 010 t HEX: c0 } immediate-1 ;
+        nip t HEX: d3 3array 1-operand
-: RCR ( dst n -- ) swap { BIN: 011 t HEX: c0 } immediate-1 ;
+    ] [
-: SHL ( dst n -- ) swap { BIN: 100 t HEX: c0 } immediate-1 ;
+        swapd t HEX: c0 3array immediate-1
-: SHR ( dst n -- ) swap { BIN: 101 t HEX: c0 } immediate-1 ;
+    ] if ; inline
-: SAR ( dst n -- ) swap { BIN: 111 t HEX: c0 } immediate-1 ;
+
+: ROL ( dst n -- ) BIN: 000 (SHIFT) ;
+: ROR ( dst n -- ) BIN: 001 (SHIFT) ;
+: RCL ( dst n -- ) BIN: 010 (SHIFT) ;
+: RCR ( dst n -- ) BIN: 011 (SHIFT) ;
+: SHL ( dst n -- ) BIN: 100 (SHIFT) ;
+: SHR ( dst n -- ) BIN: 101 (SHIFT) ;
+: SAR ( dst n -- ) BIN: 111 (SHIFT) ;
 
 GENERIC: IMUL2 ( dst src -- )
 M: immediate IMUL2 swap dup reg-code t HEX: 68 3array immediate-1/4 ;
@@ -407,6 +416,12 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
     swapd
     (2-operand) ;
 
+: MOVZX ( dst src -- )
+    OCT: 266 extended-opcode
+    over register-16? [ BIN: 1 opcode-or ] when
+    swapd
+    (2-operand) ;
+
 ! Conditional move
 : MOVcc ( dst src cc -- ) extended-opcode swapd (2-operand) ;
 
@@ -431,6 +446,10 @@ M: operand IMUL2 OCT: 257 extended-opcode (2-operand) ;
 
 : CPUID ( -- ) HEX: a2 extended-opcode, ;
 
+! Misc
+
+: NOP ( -- ) HEX: 90 , ;
+
 ! x87 Floating Point Unit
 
 : FSTPS ( operand -- ) { BIN: 011 f HEX: d9 } 1-operand ;