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

Makefile

@@ -170,7 +170,7 @@ vm/resources.o:
 	$(CC) -c $(CFLAGS) -o $@ $<
 
 .S.o:
-	$(CC) -c $(CFLAGS) -o $@ $<
+	$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
 
 .m.o:
 	$(CC) -c $(CFLAGS) -o $@ $<

basis/alien/c-types/c-types.factor

@@ -435,7 +435,7 @@ M: long-long-type box-return ( type -- )
         [ >float ] >>unboxer-quot
     "double" define-primitive-type
 
-    os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
+    "long" "ptrdiff_t" typedef
 
     "ulong" "size_t" typedef
 ] with-compilation-unit

basis/alien/strings/strings-tests.factor

@@ -1,6 +1,6 @@
 USING: alien.strings tools.test kernel libc
 io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
-io.encodings.ascii alien ;
+io.encodings.ascii alien io.encodings.string ;
 IN: alien.strings.tests
 
 [ "\u0000ff" ]
@@ -28,3 +28,7 @@ unit-test
 ] unit-test
 
 [ f ] [ f utf8 alien>string ] unit-test
+
+[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
+
+[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test

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
@@ -89,10 +89,24 @@ nl
     . malloc calloc free memcpy
 } compile-uncompiled
 
+"." write flush
+
 { build-tree } compile-uncompiled
 
+"." write flush
+
 { optimize-tree } compile-uncompiled
 
+"." write flush
+
+{ optimize-cfg } compile-uncompiled
+
+"." write flush
+
+{ (compile) } compile-uncompiled
+
+"." write flush
+
 vocabs [ words compile-uncompiled "." write flush ] each
 
 " done" print flush

basis/bootstrap/image/image.factor

@@ -8,12 +8,19 @@ 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
 
+: arch ( os cpu -- arch )
+    {
+        { "ppc" [ "-ppc" append ] }
+        { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
+        [ nip ]
+    } case ;
+
 : my-arch ( -- arch )
-    cpu name>> 
+    os name>> cpu name>> arch ;
-    dup "ppc" = [ >r os name>> "-" r> 3append ] when ;
 
 : boot-image-name ( arch -- string )
     "boot." swap ".image" 3append ;
@@ -24,7 +31,7 @@ IN: bootstrap.image
 : images ( -- seq )
     {
         "x86.32"
-        "x86.64"
+        "winnt-x86.64" "unix-x86.64"
         "linux-ppc" "macosx-ppc"
     } ;
 
@@ -367,31 +374,35 @@ M: byte-array '
 
 M: tuple ' emit-tuple ;
 
-M: tuple-layout '
-    [
-        [
-            {
-                [ hashcode>> , ]
-                [ class>> , ]
-                [ size>> , ]
-                [ superclasses>> , ]
-                [ echelon>> , ]
-            } cleave
-        ] { } make [ ' ] map
-        \ tuple-layout type-number
-        object tag-number [ emit-seq ] emit-object
-    ] cache-object ;
-
 M: tombstone '
     state>> "((tombstone))" "((empty))" ?
     "hashtables.private" lookup def>> first
     [ emit-tuple ] cache-object ;
 
 ! Arrays
-M: array '
+: emit-array ( array -- offset )
     [ ' ] map array type-number object tag-number
     [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
 
+M: array ' emit-array ;
+
+! This is a hack. We need to detect arrays which are tuple
+! layout arrays so that they can be internalized, but making
+! them a built-in type is not worth it.
+PREDICATE: tuple-layout-array < array
+    dup length 5 >= [
+        [ first tuple-class? ]
+        [ second fixnum? ]
+        [ third fixnum? ]
+        tri and and
+    ] [ drop f ] if ;
+
+M: tuple-layout-array '
+    [
+        [ dup integer? [ <fake-bignum> ] when ] map
+        emit-array
+    ] cache-object ;
+
 ! Quotations
 
 M: quotation '
@@ -458,6 +469,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/bootstrap/random/random.factor

@@ -1,16 +0,0 @@
-USING: vocabs.loader sequences system
-random random.mersenne-twister combinators init
-namespaces random ;
-IN: bootstrap.random
-
-"random.mersenne-twister" require
-
-{
-    { [ os windows? ] [ "random.windows" require ] }
-    { [ os unix? ] [ "random.unix" require ] }
-} cond
-
-[
-    [ 32 random-bits ] with-system-random
-    <mersenne-twister> random-generator set-global
-] "bootstrap.random" add-init-hook

basis/bootstrap/stage2.factor

@@ -8,6 +8,8 @@ definitions assocs compiler.errors compiler.units
 math.parser generic sets debugger command-line ;
 IN: bootstrap.stage2
 
+SYMBOL: core-bootstrap-time
+
 SYMBOL: bootstrap-time
 
 : default-image-name ( -- string )
@@ -30,11 +32,15 @@ SYMBOL: bootstrap-time
 : count-words ( pred -- )
     all-words swap count number>string write ;
 
-: print-report ( time -- )
+: print-time ( time -- )
     1000 /i
     60 /mod swap
-    "Bootstrap completed in " write number>string write
+    number>string write
-    " minutes and " write number>string write " seconds." print
+    " minutes and " write number>string write " seconds." print ;
+
+: print-report ( -- )
+    "Core bootstrap completed in " write core-bootstrap-time get print-time
+    "Bootstrap completed in "      write bootstrap-time      get print-time
 
     [ compiled>> ] count-words " compiled words" print
     [ symbol? ] count-words " symbol words" print
@@ -46,11 +52,11 @@ SYMBOL: bootstrap-time
 
 [
     ! We time bootstrap
-    millis >r
+    millis
 
     default-image-name "output-image" set-global
 
-    "math compiler threads help io tools ui ui.tools random unicode handbook" "include" set-global
+    "math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
     "" "exclude" set-global
 
     parse-command-line
@@ -71,6 +77,8 @@ SYMBOL: bootstrap-time
     [
         load-components
 
+        millis over - core-bootstrap-time set-global
+
         run-bootstrap-init
     ] with-compiler-errors
     :errors
@@ -92,7 +100,7 @@ SYMBOL: bootstrap-time
             ] [ print-error 1 exit ] recover
         ] set-boot-quot
 
-        millis r> - dup bootstrap-time set-global
+        millis swap - bootstrap-time set-global
         print-report
 
         "output-image" get save-image-and-exit

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,297 @@
+! 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 ;
+
+: trivial-branch? ( nodes -- value ? )
+    dup length 1 = [
+        first dup #push? [ literal>> t ] [ drop f f ] if
+    ] [ drop f f ] if ;
+
+: trivial-if? ( #if -- ? )
+    children>> first2
+    [ trivial-branch? [ t eq? ] when ]
+    [ trivial-branch? [ f eq? ] when ] bi*
+    and ;
+
+: emit-trivial-if ( -- )
+    ds-pop \ f tag-number cc/= ^^compare-imm ds-push ;
+
+: trivial-not-if? ( #if -- ? )
+    children>> first2
+    [ trivial-branch? [ f eq? ] when ]
+    [ trivial-branch? [ t eq? ] when ] bi*
+    and ;
+
+: emit-trivial-not-if ( -- )
+    ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
+
+M: #if emit-node
+    {
+        { [ dup trivial-if? ] [ drop emit-trivial-if ] }
+        { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
+        [ ds-pop ##branch-t emit-if ]
+    } cond iterate-next ;
+
+! #dispatch
+: trivial-dispatch-branch? ( nodes -- ? )
+    dup length 1 = [
+        first dup #call? [
+            word>> "intrinsic" word-prop not
+        ] [ drop f ] if
+    ] [ drop f ] if ;
+
+: dispatch-branch ( nodes word -- label )
+    over trivial-dispatch-branch? [
+        drop first word>>
+    ] [
+        gensym [
+            [
+                V{ } clone node-stack set
+                ##prologue
+                begin-basic-block
+                emit-nodes
+                basic-block get [
+                    ##epilogue
+                    ##return
+                    end-basic-block
+                ] when
+            ] with-cfg-builder
+        ] keep
+    ] if ;
+
+: dispatch-branches ( node -- )
+    children>> [
+        current-word get dispatch-branch
+        ##dispatch-label
+    ] each ;
+
+: emit-dispatch ( node -- )
+    ##epilogue
+    ds-pop ^^offset>slot i ##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,46 @@
+! 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: ##string-nth defs-vregs [ dst>> ] [ temp>> ] bi 2array ;
+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: ##string-nth uses-vregs [ obj>> ] [ index>> ] 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,73 @@
+! 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
+: ^^string-nth ( obj index -- dst ) ^^i2 i ##string-nth ; 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,228 @@
+! 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 } ;
+
+! String element access
+INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
+
+! 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-fixnum? [
+        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 )
+    [ second ds-load ] [ ^^load-literal ] bi prefix ;
+
+: emit-<tuple-boa> ( node -- )
+    dup node-input-infos peek literal>>
+    dup array? [
+        nip
+        ds-drop
+        [ tuple-slot-regs ] [ second ^^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,66 @@
+! 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 ] [ \ f tag-number ] if* ]
+    [ ]
+    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-fixnum? [
+        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-fixnum?
+    [ (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,144 @@
+! 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: strings.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
+    strings.private:string-nth
+    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 ] }
+        { \ strings.private:string-nth [ drop emit-string-nth ] }
+        { \ 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,56 @@
+! 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-fixnum?
+        [ (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-fixnum?
+            [ (emit-set-slot-imm) ] [ (emit-set-slot) ] if
+        ] [ first class>> immediate class<= ] bi
+        [ drop ] [ i i ##write-barrier ] if
+    ] [ drop emit-primitive ] if ;
+
+: emit-string-nth ( -- )
+    2inputs swap ^^untag-fixnum ^^string-nth ^^tag-fixnum ds-push ;

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 [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
-    #! 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>> active-interval ] bi
-    over uses>> empty?
+    dup [ 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/debugger/debugger.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences sets arrays
+USING: accessors kernel sequences sets arrays math strings fry
-compiler.cfg.linear-scan.live-intervals
+prettyprint compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation ;
 IN: compiler.cfg.linear-scan.debugger
 
@@ -21,3 +21,16 @@ IN: compiler.cfg.linear-scan.debugger
 : check-linear-scan ( live-intervals machine-registers -- )
     [ [ clone ] map ] dip allocate-registers
     [ split-children ] map concat check-assigned ;
+
+: picture ( uses -- str )
+    dup peek 1 + CHAR: space <string>
+    [ '[ CHAR: * swap _ set-nth ] each ] keep ;
+
+: interval-picture ( interval -- str )
+    [ uses>> picture ]
+    [ copy-from>> unparse ]
+    [ vreg>> unparse ]
+    tri 3array ;
+
+: live-intervals. ( seq -- )
+    [ interval-picture ] map simple-table. ;

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

@@ -0,0 +1,80 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math accessors sequences namespaces make
+combinators classes
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.instructions ;
+IN: compiler.cfg.linearization
+
+! Convert CFG IR to machine IR.
+GENERIC: linearize-insn ( basic-block insn -- )
+
+: linearize-insns ( basic-block -- )
+    dup instructions>> [ linearize-insn ] with each ; inline
+
+M: insn linearize-insn , drop ;
+
+: useless-branch? ( basic-block successor -- ? )
+    #! If our successor immediately follows us in RPO, then we
+    #! don't need to branch.
+    [ number>> ] bi@ 1- = ; inline
+
+: branch-to-branch? ( successor -- ? )
+    #! A branch to a block containing just a jump return is cloned.
+    instructions>> dup length 2 = [
+        [ first ##epilogue? ]
+        [ second [ ##return? ] [ ##jump? ] bi or ] bi and
+    ] [ drop f ] if ;
+
+: emit-branch ( basic-block successor -- )
+    {
+        { [ 2dup useless-branch? ] [ 2drop ] }
+        { [ dup branch-to-branch? ] [ nip linearize-insns ] }
+        [ nip number>> _branch ]
+    } cond ;
+
+M: ##branch linearize-insn
+    drop dup successors>> first emit-branch ;
+
+: (binary-conditional)
+    [ dup successors>> first2 ]
+    [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
+
+: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
+    [ (binary-conditional) ]
+    [ drop dup successors>> first useless-branch? ] 2bi
+    [ [ number>> ] 3dip negate-cc ] [ [ swap number>> ] 3dip ] if ;
+
+M: ##compare-branch linearize-insn
+    binary-conditional _compare-branch emit-branch ;
+
+M: ##compare-imm-branch linearize-insn
+    binary-conditional _compare-imm-branch emit-branch ;
+
+M: ##compare-float-branch linearize-insn
+    binary-conditional _compare-float-branch emit-branch ;
+
+: gc? ( bb -- ? )
+    instructions>> [
+        class {
+            ##allot
+            ##integer>bignum
+            ##box-float
+            ##box-alien
+        } memq?
+    ] contains? ;
+
+: linearize-basic-block ( bb -- )
+    [ number>> _label ]
+    [ gc? [ _gc ] when ]
+    [ linearize-insns ]
+    tri ;
+
+: linearize-basic-blocks ( rpo -- insns )
+    [ [ linearize-basic-block ] each ] { } make ;
+
+: build-mr ( cfg -- mr )
+    [ entry>> reverse-post-order linearize-basic-blocks ]
+    [ word>> ] [ label>> ]
+    tri <mr> ;

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,43 +1,45 @@
 ! 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 classes words cpu.architecture
-compiler.cfg.registers ;
+compiler.cfg.instructions compiler.cfg.registers ;
 IN: compiler.cfg.stack-frame
 
 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*
-    drop frame-required? on ;
+    word>> sub-primitive>> [ frame-required? on ] unless ;
 
-M: _spill-float compute-stack-frame*
+M: _spill-counts compute-stack-frame*
-    drop frame-required? on ;
+    counts>> stack-frame get (>>spill-counts) ;
 
-M: insn compute-stack-frame* drop ;
+M: insn compute-stack-frame*
+    class frame-required? word-prop [
+        frame-required? on
+    ] when ;
+
+\ _gc t frame-required? set-word-prop
+\ _spill t frame-required? set-word-prop
 
 : 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,37 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math layouts make sequences combinators
+cpu.architecture namespaces compiler.cfg
+compiler.cfg.instructions ;
+IN: compiler.cfg.utilities
+
+: value-info-small-fixnum? ( value-info -- ? )
+    literal>> {
+        { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+        [ drop f ]
+    } cond ;
+
+: value-info-small-tagged? ( value-info -- ? )
+    dup literal?>> [
+        literal>> {
+            { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+            { [ dup not ] [ drop t ] }
+            [ drop f ]
+        } cond
+    ] [ drop f ] if ;
+
+: set-basic-block ( basic-block -- )
+    [ basic-block set ] [ instructions>> building set ] bi ;
+
+: begin-basic-block ( -- )
+    <basic-block> basic-block get [
+        dupd successors>> push
+    ] when*
+    set-basic-block ;
+
+: end-basic-block ( -- )
+    building off
+    basic-block off ;
+
+: emit-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,65 @@
+! 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: ##string-nth propagate
+    [ resolve ] change-obj
+    [ resolve ] change-index ;
+
+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,116 @@
+! 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>constant tag-bits get = ] [ drop f ] if ;
+
+: rewrite-tagged-comparison? ( insn -- ? )
+    #! Are we comparing two tagged fixnums? Then untag them.
+    [ src1>> vreg>expr tag-fixnum-expr? ]
+    [ src2>> tag-mask get bitand 0 = ]
+    bi and ; inline
+
+: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
+    [ src1>> vreg>expr in1>> vn>vreg ]
+    [ src2>> tag-bits get neg shift ]
+    [ cc>> ]
+    tri ; inline
+
+GENERIC: rewrite-tagged-comparison ( insn -- insn' )
+
+M: ##compare-imm-branch rewrite-tagged-comparison
+    (rewrite-tagged-comparison) f \ ##compare-imm-branch boa ;
+
+M: ##compare-imm rewrite-tagged-comparison
+    [ dst>> ] [ (rewrite-tagged-comparison) ] bi
+    f \ ##compare-imm boa ;
+
+M: ##compare-imm-branch rewrite
+    dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
+    dup ##compare-imm-branch? [
+        dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
+    ] when ;
+
+: flip-comparison? ( insn -- ? )
+    dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
+
+: flip-comparison ( insn -- insn' )
+    [ dst>> ]
+    [ src2>> ]
+    [ src1>> vreg>vn vn>constant ] tri
+    cc= f \ ##compare-imm boa ;
+
+M: ##compare rewrite
+    dup flip-comparison? [
+        flip-comparison
+        dup number-values
+        rewrite
+    ] when ;
+
+: rewrite-redundant-comparison? ( insn -- ? )
+    [ src1>> vreg>expr compare-expr? ]
+    [ src2>> \ f tag-number = ]
+    [ cc>> { cc= cc/= } memq? ]
+    tri and and ; inline
+
+: rewrite-redundant-comparison ( insn -- insn' )
+    [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
+        { \ ##compare [ >compare-expr< f \ ##compare boa ] }
+        { \ ##compare-imm [ >compare-imm-expr< f \ ##compare-imm boa ] }
+        { \ ##compare-float [ >compare-expr< f \ ##compare-float boa ] }
+    } case
+    swap cc= eq? [ [ negate-cc ] change-cc ] when ;
+
+M: ##compare-imm rewrite
+    dup rewrite-redundant-comparison? [
+        rewrite-redundant-comparison
+        dup number-values rewrite
+    ] when
+    dup ##compare-imm? [
+        dup rewrite-tagged-comparison? [
+            rewrite-tagged-comparison
+            dup number-values rewrite
+        ] when
+    ] 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,142 @@
+IN: compiler.cfg.value-numbering.tests
+USING: compiler.cfg.value-numbering compiler.cfg.instructions
+compiler.cfg.registers cpu.architecture tools.test kernel math ;
+[
+    {
+        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
+
+[
+    {
+        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##peek f V int-regs 2 D 0 }
+        T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
+        T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
+        T{ ##replace f V int-regs 4 D 0 }
+    }
+] [
+    {
+        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##peek f V int-regs 2 D 0 }
+        T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
+        T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
+        T{ ##replace f V int-regs 6 D 0 }
+    } value-numbering
+] unit-test
+
+[
+    {
+        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##peek f V int-regs 2 D 0 }
+        T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
+        T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
+        T{ ##replace f V int-regs 6 D 0 }
+    }
+] [
+    {
+        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##peek f V int-regs 2 D 0 }
+        T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
+        T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
+        T{ ##replace f V int-regs 6 D 0 }
+    } value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 8 D 0 }
+        T{ ##peek f V int-regs 9 D -1 }
+        T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
+        T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
+        T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
+        T{ ##compare-float f V int-regs 14 V double-float-regs 10 V double-float-regs 11 cc>= }
+        T{ ##replace f V int-regs 14 D 0 }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 8 D 0 }
+        T{ ##peek f V int-regs 9 D -1 }
+        T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
+        T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
+        T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
+        T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
+        T{ ##replace f V int-regs 14 D 0 }
+    } value-numbering
+] unit-test
+
+[
+    {
+        T{ ##peek f V int-regs 29 D -1 }
+        T{ ##peek f V int-regs 30 D -2 }
+        T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
+        T{ ##compare-branch f V int-regs 29 V int-regs 30 cc<= }
+    }
+] [
+    {
+        T{ ##peek f V int-regs 29 D -1 }
+        T{ ##peek f V int-regs 30 D -2 }
+        T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
+        T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
+    } 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

@@ -1,30 +1,28 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces make math math.parser sequences accessors
+USING: namespaces make math math.order 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,156 @@ 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 ;
+
+M: ##string-nth generate-insn
+    {
+        [ dst>> register ]
+        [ obj>> register ]
+        [ index>> register ]
+        [ temp>> register ]
+    } cleave %string-nth ;
 
 : dst/src ( insn -- dst src )
-    [ dst>> v>operand ] [ src>> v>operand ] bi ;
+    [ dst>> register ] [ src>> register ] bi ; inline
 
-M: ##copy generate-insn dst/src %copy ;
+: dst/src1/src2 ( insn -- dst src1 src2 )
+    [ dst>> register ]
+    [ src1>> register ]
+    [ src2>> ?register ] tri ; inline
 
-M: ##copy-float generate-insn dst/src %copy-float ;
+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     ;
 
-M: ##unbox-float generate-insn dst/src %unbox-float ;
+: dst/src/temp ( insn -- dst src temp )
+    [ dst/src ] [ temp>> register ] bi ; inline
 
-M: ##unbox-f generate-insn dst/src %unbox-f ;
+M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
+M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
 
-M: ##unbox-alien generate-insn dst/src %unbox-alien ;
+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: ##unbox-byte-array generate-insn dst/src %unbox-byte-array ;
+M: ##integer>float generate-insn dst/src %integer>float ;
+M: ##float>integer generate-insn dst/src %float>integer ;
 
-M: ##unbox-any-c-ptr generate-insn dst/src %unbox-any-c-ptr ;
+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: ##box-float generate-insn dst/src %box-float ;
+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: ##box-alien generate-insn dst/src %box-alien ;
+: >alien-setter< [ src>> register ] [ value>> register ] bi ; inline
+
+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: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
+M: ##set-alien-cell      generate-insn >alien-setter< %set-alien-cell      ;
+M: ##set-alien-float     generate-insn >alien-setter< %set-alien-float     ;
+M: ##set-alien-double    generate-insn >alien-setter< %set-alien-double    ;
 
 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 +224,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 ;
@@ -196,13 +234,26 @@ M: float-regs reg-class-variable drop float-regs ;
 
 GENERIC: inc-reg-class ( register-class -- )
 
-M: reg-class inc-reg-class
+: ?dummy-stack-params ( reg-class -- )
-    dup reg-class-variable inc
+    dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
-    fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
+
+: ?dummy-int-params ( reg-class -- )
+    dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
+
+: ?dummy-fp-params ( reg-class -- )
+    drop dummy-fp-params? [ float-regs inc ] when ;
+
+M: int-regs inc-reg-class
+    [ reg-class-variable inc ]
+    [ ?dummy-stack-params ]
+    [ ?dummy-fp-params ]
+    tri ;
 
 M: float-regs inc-reg-class
-    dup call-next-method
+    [ reg-class-variable inc ]
-    fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
+    [ ?dummy-stack-params ]
+    [ ?dummy-int-params ]
+    tri ;
 
 GENERIC: reg-class-full? ( class -- ? )
 
@@ -268,7 +319,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 +374,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 +450,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 +467,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/constants/constants.factor

@@ -1,49 +1,50 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel layouts system ;
+USING: math kernel layouts system strings ;
 IN: compiler.constants
 
 ! These constants must match vm/memory.h
-: card-bits 8 ;
+: card-bits 8 ; inline
-: deck-bits 18 ;
+: deck-bits 18 ; inline
-: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ;
+: card-mark ( -- n ) HEX: 40 HEX: 80 bitor ; inline
 
 ! These constants must match vm/layouts.h
-: header-offset ( -- n ) object tag-number neg ;
+: header-offset ( -- n ) object tag-number neg ; inline
-: float-offset ( -- n ) 8 float tag-number - ;
+: float-offset ( -- n ) 8 float tag-number - ; inline
-: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ;
+: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
-: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ;
+: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
-: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
-: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
-: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
+: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
-: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
+: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
-: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
+: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
-: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
+: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
-: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
+: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
-: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
+: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
-: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
+: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
-: compiled-header-size ( -- n ) 4 bootstrap-cells ;
+: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
 
 ! Relocation classes
-: rc-absolute-cell    0 ;
+: rc-absolute-cell    0 ; inline
-: rc-absolute         1 ;
+: rc-absolute         1 ; inline
-: rc-relative         2 ;
+: rc-relative         2 ; inline
-: rc-absolute-ppc-2/2 3 ;
+: rc-absolute-ppc-2/2 3 ; inline
-: rc-relative-ppc-2   4 ;
+: rc-relative-ppc-2   4 ; inline
-: rc-relative-ppc-3   5 ;
+: rc-relative-ppc-3   5 ; inline
-: rc-relative-arm-3   6 ;
+: rc-relative-arm-3   6 ; inline
-: rc-indirect-arm     7 ;
+: rc-indirect-arm     7 ; inline
-: rc-indirect-arm-pc  8 ;
+: rc-indirect-arm-pc  8 ; inline
 
 ! Relocation types
-: rt-primitive 0 ;
+: rt-primitive 0 ; inline
-: rt-dlsym     1 ;
+: rt-dlsym     1 ; inline
-: rt-literal   2 ;
+: rt-literal   2 ; inline
-: rt-dispatch  3 ;
+: rt-dispatch  3 ; inline
-: rt-xt        4 ;
+: rt-xt        4 ; inline
-: rt-here      5 ;
+: rt-here      5 ; inline
-: rt-label     6 ;
+: rt-label     6 ; inline
-: rt-immediate 7 ;
+: rt-immediate 7 ; inline
 
 : rc-absolute? ( n -- ? )
     [ rc-absolute-ppc-2/2 = ]

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

@@ -4,7 +4,8 @@ continuations sequences.private hashtables.private byte-arrays
 strings.private system random layouts vectors
 sbufs strings.private slots.private alien math.order
 alien.accessors alien.c-types alien.syntax alien.strings
-namespaces libc sequences.private io.encodings.ascii ;
+namespaces libc sequences.private io.encodings.ascii
+classes ;
 IN: compiler.tests
 
 ! Make sure that intrinsic ops compile to correct code.
@@ -27,7 +28,10 @@ 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
+
+[ { f f } ] [ 2 f <array> ] 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
@@ -37,13 +41,19 @@ IN: compiler.tests
 ! Write barrier hits on the wrong value were causing segfaults
 [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test
 
-! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test
+[ CHAR: a ] [ 0 "abc" [ string-nth ] compile-call ] unit-test
-! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test
+[ CHAR: a ] [ 0 [ "abc" string-nth ] compile-call ] unit-test
-! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test
+[ CHAR: a ] [ [ 0 "abc" string-nth ] compile-call ] unit-test
-! 
+[ CHAR: b ] [ 1 "abc" [ string-nth ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
+[ CHAR: b ] [ 1 [ "abc" string-nth ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
+[ CHAR: b ] [ [ 1 "abc" string-nth ] compile-call ] unit-test
-! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test
+
+[ HEX: 123456 ] [ 0 "\u123456bc" [ string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 0 [ "\u123456bc" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ [ 0 "\u123456bc" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 1 "a\u123456c" [ string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ 1 [ "a\u123456c" string-nth ] compile-call ] unit-test
+[ HEX: 123456 ] [ [ 1 "a\u123456c" string-nth ] compile-call ] unit-test
 
 [ ] [ [ 0 getenv ] compile-call drop ] unit-test
 [ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test
@@ -158,6 +168,10 @@ IN: compiler.tests
 [ 4 ] [ 1 [ 3 fixnum+fast ] compile-call ] unit-test
 [ 4 ] [ [ 1 3 fixnum+fast ] compile-call ] unit-test
 
+[ -2 ] [ 1 3 [ fixnum-fast ] compile-call ] unit-test
+[ -2 ] [ 1 [ 3 fixnum-fast ] compile-call ] unit-test
+[ -2 ] [ [ 1 3 fixnum-fast ] compile-call ] unit-test
+
 [ 30001 ] [ 1 [ 30000 fixnum+fast ] compile-call ] unit-test
 
 [ 6 ] [ 2 3 [ fixnum*fast ] compile-call ] unit-test
@@ -252,31 +266,36 @@ cell 8 = [
 ! Some randomized tests
 : compiled-fixnum* fixnum* ;
 
-: test-fixnum* ( -- )
+[ ] [
-    32 random-bits >fixnum 32 random-bits >fixnum
+    10000 [ 
-    2dup
+        32 random-bits >fixnum 32 random-bits >fixnum
-    [ fixnum* ] 2keep compiled-fixnum* =
+        2dup
-    [ 2drop ] [ "Oops" throw ] if ;
+        [ fixnum* ] 2keep compiled-fixnum* =
-
+        [ 2drop ] [ "Oops" throw ] if
-[ ] [ 10000 [ test-fixnum* ] times ] unit-test
+    ] times
+] unit-test
 
 : compiled-fixnum>bignum fixnum>bignum ;
 
-: test-fixnum>bignum ( -- )
+[ bignum ] [ 0 compiled-fixnum>bignum class ] unit-test
-    32 random-bits >fixnum
-    dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
-    [ drop ] [ "Oops" throw ] if ;
 
-[ ] [ 10000 [ test-fixnum>bignum ] times ] unit-test
+[ ] [
+    10000 [
+        32 random-bits >fixnum
+        dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
+        [ drop ] [ "Oops" throw ] if
+    ] times
+] unit-test
 
 : compiled-bignum>fixnum bignum>fixnum ;
 
-: test-bignum>fixnum ( -- )
+[ ] [
-    5 random [ drop 32 random-bits ] map product >bignum
+    10000 [
-    dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
+        5 random [ drop 32 random-bits ] map product >bignum
-    [ drop ] [ "Oops" throw ] if ;
+        dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
-
+        [ drop ] [ "Oops" throw ] if
-[ ] [ 10000 [ test-bignum>fixnum ] times ] unit-test
+    ] times
+] unit-test
 
 ! Test overflow check removal
 [ t ] [
@@ -377,25 +396,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 +478,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/peg-regression.factor

@@ -0,0 +1,26 @@
+! Calling the compiler at parse time and having it compile
+! generic words defined in the current compilation unit would
+! fail. This is a regression from the 'remake-generic'
+! optimization, which would batch generic word updates at the
+! end of a compilation unit.
+
+USING: kernel accessors peg.ebnf ;
+IN: compiler.tests
+
+TUPLE: pipeline-expr background ;
+
+GENERIC: blah ( a -- b )
+
+M: pipeline-expr blah ;
+
+: ast>pipeline-expr ( -- obj )
+    pipeline-expr new blah ;
+
+EBNF: expr
+pipeline = "hello" => [[ ast>pipeline-expr ]]
+;EBNF
+
+USE: tools.test
+
+[ t ] [ \ expr compiled>> ] unit-test
+[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test

basis/compiler/tests/redefine12.factor

@@ -0,0 +1,20 @@
+USING: kernel tools.test eval ;
+IN: compiler.tests.redefine12
+
+! A regression that came about when fixing the
+! 'no method on classes-intersect?' bug
+
+GENERIC: g ( a -- b )
+
+M: object g drop t ;
+
+: h ( a -- b ) dup [ g ] when ;
+
+[ f ] [ f h ] unit-test
+[ t ] [ "hi" h ] unit-test
+
+TUPLE: jeah ;
+
+[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
+
+[ f ] [ T{ jeah } h ] unit-test

basis/compiler/tests/redefine2.factor

@@ -3,16 +3,16 @@ USING: compiler compiler.units tools.test math parser kernel
 sequences sequences.private classes.mixin generic definitions
 arrays words assocs eval ;
 
-DEFER: blah
+DEFER: redefine2-test
 
-[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: blah ; M: blah nth 2drop 3 ; INSTANCE: blah sequence" eval ] unit-test
+[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
 
-[ t ] [ blah new sequence? ] unit-test
+[ t ] [ redefine2-test new sequence? ] unit-test
 
-[ 3 ] [ 0 blah new nth-unsafe ] unit-test
+[ 3 ] [ 0 redefine2-test new nth-unsafe ] unit-test
 
-[ ] [ [ blah sequence remove-mixin-instance ] with-compilation-unit ] unit-test
+[ ] [ [ redefine2-test sequence remove-mixin-instance ] with-compilation-unit ] unit-test
 
-[ f ] [ blah new sequence? ] unit-test
+[ f ] [ redefine2-test new sequence? ] unit-test
 
-[ 0 blah new nth-unsafe ] must-fail
+[ 0 redefine2-test new nth-unsafe ] must-fail

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/spilling.factor

@@ -0,0 +1,343 @@
+USING: math.private kernel combinators accessors arrays
+generalizations float-arrays tools.test ;
+IN: compiler.tests
+
+: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
+    {
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ dup float+ ]
+        [ 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
+
+! The above don't really test spilling...
+: spill-test-1 ( a -- b )
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast
+    dup 1 fixnum+fast fixnum>float
+    3array
+    3array [ 8 narray ] dip 2array
+    [ 8 narray [ 8 narray ] dip 2array ] dip 2array
+    2array ;
+
+[
+    {
+        1
+        {
+            { { 2 3 4 5 6 7 8 9 } { 10 11 12 13 14 15 16 17 } }
+            {
+                { 18 19 20 21 22 23 24 25 }
+                { 26 27 { 28 29 30.0 } }
+            }
+        }
+    }
+] [ 1 spill-test-1 ] unit-test
+
+: spill-test-2 ( a -- b )
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    dup 1.0 float+
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float*
+    float* ;
+
+[ t ] [ 1.0 spill-test-2 1.0 \ spill-test-2 def>> call = ] unit-test

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 float-arrays ;
 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 [
@@ -203,50 +206,6 @@ TUPLE: my-tuple ;
     ] compile-call
 ] unit-test
 
-: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
-    {
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-        [ dup float+ ]
-    } cleave ;
-
-[ t ] [ \ float-spill-bug compiled>> ] unit-test
-
 ! Regression
 : dispatch-alignment-regression ( -- c )
     { tuple vector } 3 slot { word } declare
@@ -255,3 +214,19 @@ 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
+
+! PowerPC regression
+TUPLE: id obj ;
+
+: (gc-check-bug) ( a b -- c )
+    { [ id boa ] [ id boa ] } dispatch ;
+
+: gc-check-bug ( -- )
+    10000000 [ "hi" 0 (gc-check-bug) drop ] times ;
+
+[ ] [ gc-check-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 grouping prettyprint
 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,18 @@ 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
+
+[ ] [
+    [ { null } declare [ 1 ] [ 2 ] if ]
+    build-tree normalize propagate cleanup check-nodes
+] unit-test
+
+[ t ] [
+    [ { array } declare 2 <groups> [ . . ] assoc-each ]
+    \ nth-unsafe inlined?
+] 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*
     {
@@ -103,7 +102,7 @@ M: #declare cleanup* drop f ;
     #! If only one branch is live we don't need to branch at
     #! all; just drop the condition value.
     dup live-children sift dup length {
-        { 0 [ 2drop f ] }
+        { 0 [ drop in-d>> #drop ] }
         { 1 [ first swap in-d>> #drop prefix ] }
         [ 2drop ]
     } case ;

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,8 +6,9 @@ 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
+compiler.tree.checker
 kernel.private ;
 
 \ escape-analysis must-infer
@@ -34,6 +35,7 @@ M: node count-unboxed-allocations* drop ;
     propagate
     cleanup
     escape-analysis
+    dup check-nodes
     0 swap [ count-unboxed-allocations* ] each-node ;
 
 [ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
@@ -307,7 +309,7 @@ C: <ro-box> ro-box
 : bleach-node ( quot: ( node -- ) -- )
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
 
-[ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
+[ 3 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test
 
 [ 0 ] [
     [ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ]

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/branches/branches.factor

@@ -40,8 +40,8 @@ M: #dispatch live-branches
 SYMBOL: infer-children-data
 
 : copy-value-info ( -- )
-    value-infos [ clone ] change
+    value-infos [ H{ } clone suffix ] change
-    constraints [ clone ] change ;
+    constraints [ H{ } clone suffix ] change ;
 
 : no-value-info ( -- )
     value-infos off

basis/compiler/tree/propagation/constraints/constraints.factor

@@ -32,7 +32,7 @@ TUPLE: true-constraint value ;
 
 M: true-constraint assume*
     [ \ f class-not <class-info> swap value>> refine-value-info ]
-    [ constraints get at [ assume ] when* ]
+    [ constraints get assoc-stack [ assume ] when* ]
     bi ;
 
 M: true-constraint satisfied?
@@ -44,7 +44,7 @@ TUPLE: false-constraint value ;
 
 M: false-constraint assume*
     [ \ f <class-info> swap value>> refine-value-info ]
-    [ constraints get at [ assume ] when* ]
+    [ constraints get assoc-stack [ assume ] when* ]
     bi ;
 
 M: false-constraint satisfied?
@@ -83,7 +83,7 @@ TUPLE: implication p q ;
 C: --> implication
 
 : assume-implication ( p q -- )
-    [ constraints get [ swap suffix ] change-at ]
+    [ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
 
 M: implication assume*

basis/compiler/tree/propagation/info/info-tests.factor

@@ -70,3 +70,7 @@ TUPLE: test-tuple { x read-only } ;
     f f 3 <literal-info> 3array test-tuple <tuple-info> dup
     object-info value-info-intersect =
 ] unit-test
+
+[ t ] [
+    null-info 3 <literal-info> value-info<=
+] unit-test

basis/compiler/tree/propagation/info/info.factor

@@ -34,7 +34,7 @@ slots ;
 
 : null-info T{ value-info f null empty-interval } ; inline
 
-: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline
+: object-info T{ value-info f object full-interval } ; inline
 
 : class-interval ( class -- interval )
     dup real class<=
@@ -43,7 +43,7 @@ slots ;
 : interval>literal ( class interval -- literal literal? )
     #! If interval has zero length and the class is sufficiently
     #! precise, we can turn it into a literal
-    dup empty-interval eq? [
+    dup special-interval? [
         2drop f f
     ] [
         dup from>> first {
@@ -243,7 +243,7 @@ DEFER: (value-info-union)
 : literals<= ( info1 info2 -- ? )
     {
         { [ dup literal?>> not ] [ 2drop t ] }
-        { [ over literal?>> not ] [ 2drop f ] }
+        { [ over literal?>> not ] [ drop class>> null-class? ] }
         [ [ literal>> ] bi@ eql? ]
     } cond ;
 
@@ -262,17 +262,19 @@ DEFER: (value-info-union)
         ]
     } cond ;
 
-! Current value --> info mapping
+! Assoc stack of current value --> info mapping
 SYMBOL: value-infos
 
 : value-info ( value -- info )
-    resolve-copy value-infos get at null-info or ;
+    resolve-copy value-infos get assoc-stack null-info or ;
 
 : set-value-info ( info value -- )
-    resolve-copy value-infos get set-at ;
+    resolve-copy value-infos get peek set-at ;
 
 : refine-value-info ( info value -- )
-    resolve-copy value-infos get [ value-info-intersect ] change-at ;
+    resolve-copy value-infos get
+    [ assoc-stack value-info-intersect ] 2keep
+    peek set-at ;
 
 : value-literal ( value -- obj ? )
     value-info >literal< ;
@@ -307,5 +309,5 @@ SYMBOL: value-infos
 : immutable-tuple-boa? ( #call -- ? )
     dup word>> \ <tuple-boa> eq? [
         dup in-d>> peek node-value-info
-        literal>> class>> immutable-tuple-class?
+        literal>> first immutable-tuple-class?
     ] [ drop f ] if ;

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -131,7 +131,7 @@ DEFER: (flat-length)
     ] bi* + + + + + ;
 
 : should-inline? ( #call word -- ? )
-    inlining-rank 5 >= ;
+    dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
 
 SYMBOL: history
 
@@ -164,7 +164,16 @@ SYMBOL: history
     first object swap eliminate-dispatch ;
 
 : do-inlining ( #call word -- ? )
+    #! If the generic was defined in an outer compilation unit,
+    #! then it doesn't have a definition yet; the definition
+    #! is built at the end of the compilation unit. We do not
+    #! attempt inlining at this stage since the stack discipline
+    #! is not finalized yet, so dispatch# might return an out
+    #! of bounds value. This case comes up if a parsing word
+    #! calls the compiler at parse time (doing so is
+    #! discouraged, but it should still work.)
     {
+        { [ dup deferred? ] [ 2drop f ] }
         { [ dup custom-inlining? ] [ inline-custom ] }
         { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }

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,12 +276,12 @@ 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>
+        literal>> dup array? [ first ] [ drop tuple ] if <class-info>
         [ clear ] dip
     ] "outputs" set-word-prop
 ] each