New GC checks work in progress

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

@@ -25,12 +25,10 @@ M: stack-frame-insn compute-stack-frame*
 
 M: ##call compute-stack-frame* drop frame-required? on ;
 
-M: ##gc compute-stack-frame*
+M: ##call-gc compute-stack-frame*
+    drop
     frame-required? on
-    stack-frame new
+    stack-frame new t >>calls-vm? request-stack-frame ;
-        swap tagged-values>> length cells >>gc-root-size
-        t >>calls-vm?
-    request-stack-frame ;
 
 M: _spill-area-size compute-stack-frame*
     n>> stack-frame get (>>spill-area-size) ;
@@ -40,6 +38,7 @@ M: insn compute-stack-frame*
         frame-required? on
     ] when ;
 
+! PowerPC backend sets frame-required? for ##integer>float!
 \ _spill t frame-required? set-word-prop
 \ ##unary-float-function t frame-required? set-word-prop
 \ ##binary-float-function t frame-required? set-word-prop

basis/compiler/cfg/cfg.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math vectors arrays accessors namespaces ;
 IN: compiler.cfg
@@ -8,7 +8,8 @@ TUPLE: basic-block < identity-tuple
 number
 { instructions vector }
 { successors vector }
-{ predecessors vector } ;
+{ predecessors vector }
+{ unlikely? boolean } ;
 
 : <basic-block> ( -- bb )
     basic-block new

basis/compiler/cfg/checker/checker.factor

@@ -25,15 +25,7 @@ ERROR: last-insn-not-a-jump bb ;
     dup instructions>> last {
         [ ##branch? ]
         [ ##dispatch? ]
-        [ ##compare-branch? ]
+        [ conditional-branch-insn? ]
-        [ ##compare-imm-branch? ]
-        [ ##compare-integer-branch? ]
-        [ ##compare-integer-imm-branch? ]
-        [ ##compare-float-ordered-branch? ]
-        [ ##compare-float-unordered-branch? ]
-        [ ##fixnum-add? ]
-        [ ##fixnum-sub? ]
-        [ ##fixnum-mul? ]
         [ ##no-tco? ]
     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
 

basis/compiler/cfg/comparisons/comparisons.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs math.order sequences ;
 IN: compiler.cfg.comparisons
@@ -12,6 +12,8 @@ SYMBOLS:
 SYMBOLS:
     vcc-all vcc-notall vcc-any vcc-none ;
 
+SYMBOLS: cc-o cc/o ;
+
 : negate-cc ( cc -- cc' )
     H{
         { cc<    cc/<   }
@@ -28,6 +30,8 @@ SYMBOLS:
         { cc/=   cc=    } 
         { cc/<>  cc<>   } 
         { cc/<>= cc<>=  }
+        { cc-o   cc/o   }
+        { cc/o   cc-o   }
     } at ;
 
 : negate-vcc ( cc -- cc' )

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs arrays classes combinators
 compiler.units fry generalizations generic kernel locals
@@ -19,6 +19,10 @@ M: insn uses-vregs drop { } ;
 
 M: ##phi uses-vregs inputs>> values ;
 
+M: _conditional-branch defs-vreg insn>> defs-vreg ;
+
+M: _conditional-branch uses-vregs insn>> uses-vregs ;
+
 <PRIVATE
 
 : slot-array-quot ( slots -- quot )
@@ -55,7 +59,7 @@ PRIVATE>
 [
     insn-classes get
     [ [ define-defs-vreg-method ] each ]
-    [ { ##phi } diff [ define-uses-vregs-method ] each ]
+    [ { ##phi _conditional-branch } diff [ define-uses-vregs-method ] each ]
     [ [ define-temp-vregs-method ] each ]
     tri
 ] with-compilation-unit

basis/compiler/cfg/gc-checks/gc-checks-tests.factor

@@ -1,14 +1,14 @@
-USING: compiler.cfg.gc-checks compiler.cfg.debugger
+USING: arrays compiler.cfg.gc-checks
+compiler.cfg.gc-checks.private compiler.cfg.debugger
 compiler.cfg.registers compiler.cfg.instructions compiler.cfg
-compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
+compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
-namespaces accessors sequences ;
+tools.test kernel vectors namespaces accessors sequences alien
+memory classes make combinators.short-circuit byte-arrays ;
 IN: compiler.cfg.gc-checks.tests
 
 : test-gc-checks ( -- )
     H{ } clone representations set
-    cfg new 0 get >>entry
+    cfg new 0 get >>entry cfg set ;
-    insert-gc-checks
-    drop ;
 
 V{
     T{ ##inc-d f 3 }
@@ -23,4 +23,149 @@ V{
 
 [ ] [ test-gc-checks ] unit-test
 
-[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test
+[ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
+
+[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
+
+2 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##load-tagged f 3 0 }
+        T{ ##replace f 3 D 0 }
+        T{ ##replace f 3 R 3 }
+    }
+] [ [ { D 0 R 3 } wipe-locs ] V{ } make ] unit-test
+
+: gc-check? ( bb -- ? )
+    instructions>>
+    {
+        [ length 1 = ]
+        [ first ##check-nursery-branch? ]
+    } 1&& ;
+
+[ t ] [ 100 <gc-check> gc-check? ] unit-test
+
+2 \ vreg-counter set-global
+
+[
+    V{
+        T{ ##save-context f 3 4 }
+        T{ ##load-tagged f 5 0 }
+        T{ ##replace f 5 D 0 }
+        T{ ##replace f 5 R 3 }
+        T{ ##call-gc f { 0 1 2 } }
+        T{ ##branch }
+    }
+]
+[
+    { D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
+] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##branch }
+} 4 test-bb
+
+0 { 1 2 } edges
+1 3 edge
+2 3 edge
+3 4 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get needs-predecessors drop ] unit-test
+
+[ ] [ 31337 { D 1 R 2 } { 10 20 } 3 get (insert-gc-check) ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 2 get successors>> first gc-check? ] unit-test
+
+[ t ] [ 3 get predecessors>> first gc-check? ] unit-test
+
+30 \ vreg-counter set-global
+
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 2 D 0 }
+    T{ ##inc-d f 3 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##allot f 1 64 byte-array }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##replace f 2 D 1 }
+    T{ ##branch }
+} 4 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 5 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 5 edge
+
+[ ] [ test-gc-checks ] unit-test
+
+H{
+    { 2 tagged-rep }
+} representations set
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[ 2 ] [ 2 get predecessors>> length ] unit-test
+
+[ t ] [ 1 get successors>> first gc-check? ] unit-test
+
+[ 64 ] [ 1 get successors>> first instructions>> first size>> ] unit-test
+
+[ t ] [ 2 get predecessors>> first gc-check? ] unit-test
+
+[
+    V{
+        T{ ##save-context f 33 34 }
+        T{ ##load-tagged f 35 0 }
+        T{ ##replace f 35 D 0 }
+        T{ ##replace f 35 D 1 }
+        T{ ##replace f 35 D 2 }
+        T{ ##call-gc f { 2 } }
+        T{ ##branch }
+    }
+] [ 2 get predecessors>> second instructions>> ] unit-test
+
+! Don't forget to invalidate RPO after inserting basic blocks!
+[ 8 ] [ cfg get reverse-post-order length ] unit-test

basis/compiler/cfg/gc-checks/gc-checks.factor

@@ -1,15 +1,25 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs fry math
+USING: accessors assocs combinators fry kernel layouts locals
-cpu.architecture layouts namespaces
+math make namespaces sequences cpu.architecture
+compiler.cfg
 compiler.cfg.rpo
+compiler.cfg.hats
 compiler.cfg.registers
+compiler.cfg.utilities
+compiler.cfg.comparisons
 compiler.cfg.instructions
+compiler.cfg.predecessors
+compiler.cfg.liveness
+compiler.cfg.liveness.ssa
 compiler.cfg.stacks.uninitialized ;
 IN: compiler.cfg.gc-checks
 
-! Garbage collection check insertion. This pass runs after representation
+<PRIVATE
-! selection, so it must keep track of representations.
+
+! Garbage collection check insertion. This pass runs after
+! representation selection, since it needs to know which vregs
+! can contain tagged pointers.
 
 : insert-gc-check? ( bb -- ? )
     instructions>> [ ##allocation? ] any? ;
@@ -17,6 +27,48 @@ IN: compiler.cfg.gc-checks
 : blocks-with-gc ( cfg -- bbs )
     post-order [ insert-gc-check? ] filter ;
 
+! A GC check for bb consists of two new basic blocks, gc-check
+! and gc-call:
+!
+!    gc-check
+!   /      \
+!  |     gc-call
+!   \      /
+!      bb
+
+: <gc-check> ( size -- bb )
+    [ <basic-block> ] dip
+    [
+        cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+        ##check-nursery-branch
+    ] V{ } make >>instructions ;
+
+: wipe-locs ( uninitialized-locs -- )
+    '[
+        int-rep next-vreg-rep
+        [ 0 ##load-tagged ]
+        [ '[ [ _ ] dip ##replace ] each ] bi
+    ] unless-empty ;
+
+: <gc-call> ( uninitialized-locs gc-roots -- bb )
+    [ <basic-block> ] 2dip
+    [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
+    >>instructions t >>unlikely? ;
+
+:: insert-guard ( check body bb -- )
+    bb predecessors>> check (>>predecessors)
+    V{ bb body }      check (>>successors)
+
+    V{ check }        body (>>predecessors)
+    V{ bb }           body (>>successors)
+
+    V{ check body }   bb (>>predecessors)
+
+    check predecessors>> [ bb check update-successors ] each ;
+
+: (insert-gc-check) ( size uninitialized-locs gc-roots bb -- )
+    [ [ <gc-check> ] 2dip <gc-call> ] dip insert-guard ;
+
 GENERIC: allocation-size* ( insn -- n )
 
 M: ##allot allocation-size* size>> ;
@@ -30,20 +82,27 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
     [ ##allocation? ] filter
     [ allocation-size* data-alignment get align ] map-sum ;
 
+: live-tagged ( bb -- vregs )
+    live-in keys [ rep-of tagged-rep? ] filter ;
+
 : insert-gc-check ( bb -- )
-    dup dup '[
+    {
-        tagged-rep next-vreg-rep
+        [ allocation-size ]
-        tagged-rep next-vreg-rep
+        [ uninitialized-locs ]
-        _ allocation-size
+        [ live-tagged ]
-        f
+        [ ]
-        f
+    } cleave
-        _ uninitialized-locs
+    (insert-gc-check) ;
-        \ ##gc new-insn
+
-        prefix
+PRIVATE>
-    ] change-instructions drop ;
 
 : insert-gc-checks ( cfg -- cfg' )
     dup blocks-with-gc [
-        over compute-uninitialized-sets
+        [
+            needs-predecessors
+            dup compute-ssa-live-sets
+            dup compute-uninitialized-sets
+        ] dip
         [ insert-gc-check ] each
+        cfg-changed
     ] unless-empty ;

basis/compiler/cfg/instructions/instructions.factor

@@ -682,23 +682,30 @@ temp: temp/int-rep ;
 ! Overflowing arithmetic
 INSN: ##fixnum-add
 def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
 
 INSN: ##fixnum-sub
 def: dst/tagged-rep
-use: src1/tagged-rep src2/tagged-rep ;
+use: src1/tagged-rep src2/tagged-rep
+literal: cc ;
 
 INSN: ##fixnum-mul
 def: dst/tagged-rep
-use: src1/tagged-rep src2/int-rep ;
+use: src1/tagged-rep src2/int-rep
-
+literal: cc ;
-INSN: ##gc
-temp: temp1/int-rep temp2/int-rep
-literal: size data-values tagged-values uninitialized-locs ;
 
 INSN: ##save-context
 temp: temp1/int-rep temp2/int-rep ;
 
+! GC checks
+INSN: ##check-nursery-branch
+literal: size cc
+temp: temp1/int-rep temp2/int-rep ;
+
+INSN: ##call-gc
+literal: gc-roots ;
+
 ! Instructions used by machine IR only.
 INSN: _prologue
 literal: stack-frame ;
@@ -714,48 +721,11 @@ literal: label ;
 
 INSN: _loop-entry ;
 
-INSN: _dispatch
-use: src
-temp: temp ;
-
 INSN: _dispatch-label
 literal: label ;
 
-INSN: _compare-branch
+INSN: _conditional-branch
-literal: label
+literal: label insn ;
-use: src1 src2
-literal: cc ;
-
-INSN: _compare-imm-branch
-literal: label
-use: src1
-literal: src2 cc ;
-
-INSN: _compare-float-unordered-branch
-literal: label
-use: src1 src2
-literal: cc ;
-
-INSN: _compare-float-ordered-branch
-literal: label
-use: src1 src2
-literal: cc ;
-
-! Overflowing arithmetic
-INSN: _fixnum-add
-literal: label
-def: dst
-use: src1 src2 ;
-
-INSN: _fixnum-sub
-literal: label
-def: dst
-use: src1 src2 ;
-
-INSN: _fixnum-mul
-literal: label
-def: dst
-use: src1 src2 ;
 
 TUPLE: spill-slot { n integer } ;
 C: <spill-slot> spill-slot
@@ -771,18 +741,31 @@ literal: rep src ;
 INSN: _spill-area-size
 literal: n ;
 
-! For GC check insertion
 UNION: ##allocation
 ##allot
 ##box-alien
 ##box-displaced-alien ;
 
+UNION: conditional-branch-insn
+##compare-branch
+##compare-imm-branch
+##compare-integer-branch
+##compare-integer-imm-branch
+##compare-float-ordered-branch
+##compare-float-unordered-branch
+##test-vector-branch
+##check-nursery-branch
+##fixnum-add
+##fixnum-sub
+##fixnum-mul ;
+
 ! For alias analysis
 UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
 UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
 
-! Instructions that kill all live vregs but cannot trigger GC
+! Instructions that clobber registers
-UNION: partial-sync-insn
+UNION: clobber-insn
+##call-gc
 ##unary-float-function
 ##binary-float-function ;
 

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

@@ -4,6 +4,7 @@ USING: sequences accessors layouts kernel math math.intervals
 namespaces combinators fry arrays
 cpu.architecture
 compiler.tree.propagation.info
+compiler.cfg
 compiler.cfg.hats
 compiler.cfg.stacks
 compiler.cfg.instructions
@@ -55,7 +56,7 @@ IN: compiler.cfg.intrinsics.fixnum
 : emit-fixnum-overflow-op ( quot word -- )
     ! Inputs to the final instruction need to be copied because
     ! of loc>vreg sync
-    [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
+    [ [ (2inputs) [ any-rep ^^copy ] bi@ cc/o ] dip call ] dip
     [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
     emit-conditional ; inline
 

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

@@ -63,18 +63,19 @@ M: sync-point handle ( sync-point -- )
 
 : smallest-heap ( heap1 heap2 -- heap )
     ! If heap1 and heap2 have the same key, favors heap1.
-    [ [ heap-peek nip ] bi@ <= ] most ;
+    {
+        { [ dup heap-empty? ] [ drop ] }
+        { [ over heap-empty? ] [ nip ] }
+        [ [ [ heap-peek nip ] bi@ <= ] most ]
+    } cond ;
 
 : (allocate-registers) ( -- )
-    {
+    ! If a live interval begins at the same location as a sync point,
-        { [ unhandled-intervals get heap-empty? ] [ unhandled-sync-points get ] }
+    ! process the sync point before the live interval. This ensures that the
-        { [ unhandled-sync-points get heap-empty? ] [ unhandled-intervals get ] }
+    ! return value of C function calls doesn't get spilled and reloaded
-        ! If a live interval begins at the same location as a sync point,
+    ! unnecessarily.
-        ! process the sync point before the live interval. This ensures that the
+    unhandled-sync-points get unhandled-intervals get smallest-heap
-        ! return value of C function calls doesn't get spilled and reloaded
+    dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
-        ! unnecessarily.
-        [ unhandled-sync-points get unhandled-intervals get smallest-heap ]
-    } cond dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
 
 : finish-allocation ( -- )
     active-intervals inactive-intervals

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

@@ -126,39 +126,9 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 M: vreg-insn assign-registers-in-insn
     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 
-: trace-on-gc ( assoc -- assoc' )
+M: ##call-gc assign-registers-in-insn
-    ! When a GC occurs, virtual registers which contain tagged data
-    ! are traced by the GC. Outputs a sequence physical registers.
-    [ drop rep-of tagged-rep eq? ] { } assoc-filter-as values ;
-
-: spill-on-gc? ( vreg reg -- ? )
-    [ rep-of tagged-rep? not ] [ spill-slot? not ] bi* and ;
-
-: spill-on-gc ( assoc -- assoc' )
-    ! When a GC occurs, virtual registers which contain untagged data,
-    ! and are stored in physical registers, are saved to their spill
-    ! slots. Outputs sequence of triples:
-    ! - physical register
-    ! - spill slot
-    ! - representation
-    [
-        [
-            2dup spill-on-gc?
-            [ swap [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if
-        ] assoc-each
-    ] { } make ;
-
-: gc-root-offsets ( registers -- alist )
-    ! Outputs a sequence of { offset register/spill-slot } pairs
-    [ length iota [ cell * ] map ] keep zip ;
-
-M: ##gc assign-registers-in-insn
-    ! Since ##gc is always the first instruction in a block, the set of
-    ! values live at the ##gc is just live-in.
     dup call-next-method
-    basic-block get register-live-ins get at
+    [ [ vreg>reg ] map ] change-gc-roots drop ;
-    [ trace-on-gc gc-root-offsets >>tagged-values ] [ spill-on-gc >>data-values ] bi
-    drop ;
 
 M: insn assign-registers-in-insn drop ;
 

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

@@ -1444,49 +1444,3 @@ test-diamond
 [ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
 
 [ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
-
-V{
-    T{ ##peek f 0 D 0 }
-    T{ ##peek f 1 D 1 }
-    T{ ##replace f 1 D 1 }
-    T{ ##branch }
-} 0 test-bb
-
-V{
-    T{ ##gc f 2 3 }
-    T{ ##branch }
-} 1 test-bb
-
-V{
-    T{ ##replace f 0 D 0 }
-    T{ ##return }
-} 2 test-bb
-
-0 1 edge
-1 2 edge
-
-[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-
-[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test
-
-V{
-    T{ ##peek f 0 D 0 }
-    T{ ##peek f 1 D 1 }
-    T{ ##compare-imm-branch f 1 5 cc= }
-} 0 test-bb
-
-V{
-    T{ ##gc f 2 3 }
-    T{ ##replace f 0 D 0 }
-    T{ ##return }
-} 1 test-bb
-
-V{
-    T{ ##return }
-} 2 test-bb
-
-0 { 1 2 } edges
-
-[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
-
-[ { { 0 1 } } ] [ 1 get instructions>> first tagged-values>> ] unit-test

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

@@ -102,7 +102,7 @@ M: vreg-insn compute-live-intervals*
     [ dup temp-vregs [ handle-temp ] with each ]
     tri ;
 
-M: partial-sync-insn compute-live-intervals*
+M: clobber-insn compute-live-intervals*
     [ dup defs-vreg [ +use+ handle-output ] with when* ]
     [ dup uses-vregs [ +memory+ handle-input ] with each ]
     [ dup temp-vregs [ handle-temp ] with each ]
@@ -122,7 +122,7 @@ SYMBOL: sync-points
 
 GENERIC: compute-sync-points* ( insn -- )
 
-M: partial-sync-insn compute-sync-points*
+M: clobber-insn compute-sync-points*
     insn#>> <sync-point> sync-points get push ;
 
 M: insn compute-sync-points* drop ;

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

@@ -57,6 +57,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
 [
     {
         T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
+        T{ ##branch }
     }
 ] [
     { { T{ location f 1 int-rep int-regs } T{ location f 2 int-rep int-regs } } }
@@ -67,6 +68,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
     {
         T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 0 } } }
         T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 1 } } }
+        T{ ##branch }
     }
 ] [
     {
@@ -80,6 +82,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
     {
         T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
         T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+        T{ ##branch }
     }
 ] [
     {
@@ -93,6 +96,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
     {
         T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
         T{ _reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
+        T{ ##branch }
     }
 ] [
     {
@@ -115,11 +119,13 @@ H{ } clone spill-temps set
             T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
             T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
             T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
+            T{ ##branch }
         }
         {
             T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
             T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
             T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
+            T{ ##branch }
         }
     } member?
 ] unit-test

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

@@ -78,11 +78,11 @@ SYMBOL: temp
 
 : mapping-instructions ( alist -- insns )
     [ swap ] H{ } assoc-map-as
-    [ temp [ swap >insn ] parallel-mapping ] { } make ;
+    [ temp [ swap >insn ] parallel-mapping ##branch ] { } make ;
 
 : perform-mappings ( bb to mappings -- )
     dup empty? [ 3drop ] [
-        mapping-instructions insert-simple-basic-block
+        mapping-instructions insert-basic-block
         cfg get cfg-changed drop
     ] if ;
 

basis/compiler/cfg/linearization/linearization.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math accessors sequences namespaces make
 combinators assocs arrays locals layouts hashtables
@@ -19,14 +19,8 @@ SYMBOL: numbers
 
 : number-blocks ( bbs -- ) [ 2array ] map-index >hashtable numbers set ;
 
-! Convert CFG IR to machine IR.
 GENERIC: linearize-insn ( basic-block insn -- )
 
-: linearize-basic-block ( bb -- )
-    [ block-number _label ]
-    [ dup instructions>> [ linearize-insn ] with each ]
-    bi ;
-
 M: insn linearize-insn , drop ;
 
 : useless-branch? ( basic-block successor -- ? )
@@ -40,68 +34,29 @@ M: insn linearize-insn , drop ;
 M: ##branch linearize-insn
     drop dup successors>> first emit-branch ;
 
-: successors ( bb -- first second ) successors>> first2 ; inline
+GENERIC: negate-insn-cc ( insn -- )
 
-:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label etc... )
+M: conditional-branch-insn negate-insn-cc
-    bb insn
+    [ negate-cc ] change-cc drop ;
-    conditional-quot
-    [ drop dup successors>> second useless-branch? ] 2bi
-    [ [ swap block-number ] n ndip ]
-    [ [ block-number ] n ndip negate-cc-quot call ] if ; inline
 
-: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
+M: ##test-vector-branch negate-insn-cc
-    [ dup successors ]
+    [ negate-vcc ] change-vcc drop ;
-    [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
 
-: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
+M:: conditional-branch-insn linearize-insn ( bb insn -- )
-    3 [ (binary-conditional) ] [ negate-cc ] conditional ;
+    bb successors>> first2 :> ( first second )
-
+    bb second useless-branch?
-: (test-vector-conditional) ( bb insn -- bb successor1 successor2 src1 temp rep vcc )
+    [ bb second first ]
-    [ dup successors ]
+    [ bb first second insn negate-insn-cc ] if
-    [ { [ src1>> ] [ temp>> ] [ rep>> ] [ vcc>> ] } cleave ] bi* ; inline
+    block-number insn _conditional-branch
-
+    emit-branch ;
-: test-vector-conditional ( bb insn -- bb successor label src1 temp rep vcc )
-    4 [ (test-vector-conditional) ] [ negate-vcc ] conditional ;
-
-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-integer-branch linearize-insn
-    binary-conditional _compare-branch emit-branch ;
-
-M: ##compare-integer-imm-branch linearize-insn
-    binary-conditional _compare-imm-branch emit-branch ;
-
-M: ##compare-float-ordered-branch linearize-insn
-    binary-conditional _compare-float-ordered-branch emit-branch ;
-
-M: ##compare-float-unordered-branch linearize-insn
-    binary-conditional _compare-float-unordered-branch emit-branch ;
-
-M: ##test-vector-branch linearize-insn
-    test-vector-conditional _test-vector-branch emit-branch ;
-
-: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
-    [ dup successors block-number ]
-    [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
-
-M: ##fixnum-add linearize-insn
-    overflow-conditional _fixnum-add emit-branch ;
-
-M: ##fixnum-sub linearize-insn
-    overflow-conditional _fixnum-sub emit-branch ;
-
-M: ##fixnum-mul linearize-insn
-    overflow-conditional _fixnum-mul emit-branch ;
 
 M: ##dispatch linearize-insn
-    swap
+    , successors>> [ block-number _dispatch-label ] each ;
-    [ [ src>> ] [ temp>> ] bi _dispatch ]
+
-    [ successors>> [ block-number _dispatch-label ] each ]
+: linearize-basic-block ( bb -- )
-    bi* ;
+    [ block-number _label ]
+    [ dup instructions>> [ linearize-insn ] with each ]
+    bi ;
 
 : linearize-basic-blocks ( cfg -- insns )
     [

basis/compiler/cfg/linearization/order/order.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs deques dlists kernel make sorting
 namespaces sequences combinators combinators.short-circuit
@@ -8,7 +8,8 @@ sets hash-sets ;
 FROM: namespaces => set ;
 IN: compiler.cfg.linearization.order
 
-! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
+! This is RPO except loops are rotated and unlikely blocks go
+! at the end. Based on SBCL's src/compiler/control.lisp
 
 <PRIVATE
 
@@ -68,7 +69,9 @@ SYMBOLS: work-list loop-heads visited ;
 : (linearization-order) ( cfg -- bbs )
     init-linearization-order
 
-    [ work-list get [ process-block ] slurp-deque ] { } make ;
+    [ work-list get [ process-block ] slurp-deque ] { } make
+    ! [ unlikely?>> not ] partition append
+    ;
 
 PRIVATE>
 

basis/compiler/cfg/liveness/ssa/ssa.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces deques accessors sets sequences assocs fry
 hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
@@ -48,14 +48,14 @@ SYMBOL: work-list
         [ predecessors>> add-to-work-list ] [ drop ] if
     ] [ drop ] if ;
 
-: compute-ssa-live-sets ( cfg -- cfg' )
+: compute-ssa-live-sets ( cfg -- )
     needs-predecessors
 
     <hashed-dlist> work-list set
     H{ } clone live-ins set
     H{ } clone phi-live-ins set
     H{ } clone live-outs set
-    dup post-order add-to-work-list
+    post-order add-to-work-list
     work-list get [ liveness-step ] slurp-deque ;
 
 : live-in? ( vreg bb -- ? ) live-in key? ;

basis/compiler/cfg/mr/mr.factor

@@ -1,14 +1,11 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel namespaces accessors compiler.cfg
-compiler.cfg.linearization compiler.cfg.gc-checks
+compiler.cfg.linearization compiler.cfg.linear-scan
-compiler.cfg.save-contexts compiler.cfg.linear-scan
 compiler.cfg.build-stack-frame ;
 IN: compiler.cfg.mr
 
 : build-mr ( cfg -- mr )
-    insert-gc-checks
-    insert-save-contexts
     linear-scan
     flatten-cfg
     build-stack-frame ;

basis/compiler/cfg/optimizer/optimizer.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors combinators namespaces
 compiler.cfg.tco
@@ -12,6 +12,8 @@ compiler.cfg.copy-prop
 compiler.cfg.dce
 compiler.cfg.write-barrier
 compiler.cfg.representations
+compiler.cfg.gc-checks
+compiler.cfg.save-contexts
 compiler.cfg.ssa.destruction
 compiler.cfg.empty-blocks
 compiler.cfg.checker ;
@@ -36,6 +38,8 @@ SYMBOL: check-optimizer?
     eliminate-dead-code
     eliminate-write-barriers
     select-representations
+    insert-gc-checks
+    insert-save-contexts
     destruct-ssa
     delete-empty-blocks
     ?check ;

basis/compiler/cfg/save-contexts/save-contexts.factor

@@ -10,6 +10,7 @@ IN: compiler.cfg.save-contexts
 : needs-save-context? ( insns -- ? )
     [
         {
+            [ ##call-gc? ]
             [ ##unary-float-function? ]
             [ ##binary-float-function? ]
             [ ##alien-invoke? ]

basis/compiler/cfg/ssa/destruction/destruction.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs fry kernel namespaces
 sequences sequences.deep
@@ -93,25 +93,32 @@ M: ##phi prepare-insn
         [ 2drop ] [ eliminate-copy ] if
     ] assoc-each ;
 
-: useless-copy? ( ##copy -- ? )
+GENERIC: rename-insn ( insn -- keep? )
-    dup ##copy? [ [ dst>> ] [ src>> ] bi eq? ] [ drop f ] if ;
+
+M: vreg-insn rename-insn
+    [ rename-insn-defs ] [ rename-insn-uses ] bi t ;
+
+M: ##copy rename-insn
+    [ call-next-method drop ]
+    [ [ dst>> ] [ src>> ] bi eq? not ] bi ;
+
+M: ##phi rename-insn drop f ;
+
+M: ##call-gc rename-insn
+    [ renamings get '[ _ at ] map members ] change-gc-roots drop t ;
+
+M: insn rename-insn drop t ;
 
 : perform-renaming ( cfg -- )
     leader-map get keys [ dup leader ] H{ } map>assoc renamings set
-    [
+    [ instructions>> [ rename-insn ] filter! drop ] each-basic-block ;
-        instructions>> [
-            [ rename-insn-defs ]
-            [ rename-insn-uses ]
-            [ [ useless-copy? ] [ ##phi? ] bi or not ] tri
-        ] filter! drop
-    ] each-basic-block ;
 
 : destruct-ssa ( cfg -- cfg' )
     needs-dominance
 
     dup construct-cssa
     dup compute-defs
-    compute-ssa-live-sets
+    dup compute-ssa-live-sets
     dup compute-live-ranges
     dup prepare-coalescing
     process-copies

basis/compiler/cfg/ssa/interference/interference-tests.factor

@@ -9,7 +9,7 @@ IN: compiler.cfg.ssa.interference.tests
 
 : test-interference ( -- )
     cfg new 0 get >>entry
-    compute-ssa-live-sets
+    dup compute-ssa-live-sets
     dup compute-defs
     compute-live-ranges ;
 

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

@@ -1,4 +1,4 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math math.order namespaces accessors kernel layouts combinators
 combinators.smart assocs sequences cpu.architecture ;
@@ -8,7 +8,6 @@ TUPLE: stack-frame
 { params integer }
 { return integer }
 { total-size integer }
-{ gc-root-size integer }
 { spill-area-size integer }
 { calls-vm? boolean } ;
 
@@ -19,19 +18,9 @@ TUPLE: stack-frame
 : spill-offset ( n -- offset )
     param-base + ;
 
-: gc-root-base ( -- n )
-    stack-frame get spill-area-size>> param-base + ;
-
-: gc-root-offset ( n -- n' ) gc-root-base + ;
-
 : (stack-frame-size) ( stack-frame -- n )
     [
-        {
+        [ params>> ] [ return>> ] [ spill-area-size>> ] tri
-            [ params>> ]
-            [ return>> ]
-            [ gc-root-size>> ]
-            [ spill-area-size>> ]
-        } cleave
     ] sum-outputs ;
 
 : max-stack-frame ( frame1 frame2 -- frame3 )
@@ -39,6 +28,5 @@ TUPLE: stack-frame
     {
         [ [ params>> ] bi@ max >>params ]
         [ [ return>> ] bi@ max >>return ]
-        [ [ gc-root-size>> ] bi@ max >>gc-root-size ]
         [ [ calls-vm?>> ] bi@ or >>calls-vm? ]
     } 2cleave ;

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -44,8 +44,8 @@ ERROR: bad-peek dst loc ;
     ! If both blocks are subroutine calls, don't bother
     ! computing anything.
     2dup [ kill-block? ] both? [ 2drop ] [
-        2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
+        2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ##branch ] V{ } make
-        [ 2drop ] [ insert-simple-basic-block ] if-empty
+        [ 2drop ] [ insert-basic-block ] if-empty
     ] if ;
 
 : visit-block ( bb -- )

basis/compiler/cfg/utilities/utilities.factor

@@ -37,11 +37,24 @@ SYMBOL: visited
 : skip-empty-blocks ( bb -- bb' )
     H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
 
-:: insert-basic-block ( froms to bb -- )
+:: update-predecessors ( from to bb -- )
-    bb froms V{ } like >>predecessors drop
+    ! Update 'to' predecessors for insertion of 'bb' between
-    bb to 1vector >>successors drop
+    ! 'from' and 'to'.
-    to predecessors>> [ dup froms member-eq? [ drop bb ] when ] map! drop
+    to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
-    froms [ successors>> [ dup to eq? [ drop bb ] when ] map! drop ] each ;
+
+:: update-successors ( from to bb -- )
+    ! Update 'from' successors for insertion of 'bb' between
+    ! 'from' and 'to'.
+    from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
+
+:: insert-basic-block ( from to insns -- )
+    ! Insert basic block on the edge between 'from' and 'to'.
+    <basic-block> :> bb
+    insns V{ } like bb (>>instructions)
+    V{ from } bb (>>predecessors)
+    V{ to } bb (>>successors)
+    from to bb update-predecessors
+    from to bb update-successors ;
 
 : add-instructions ( bb quot -- )
     [ instructions>> building ] dip '[
@@ -50,15 +63,6 @@ SYMBOL: visited
         ,
     ] with-variable ; inline
 
-: <simple-block> ( insns -- bb )
-    <basic-block>
-    swap >vector
-    \ ##branch new-insn over push
-    >>instructions ;
-
-: insert-simple-basic-block ( from to insns -- )
-    [ 1vector ] 2dip <simple-block> insert-basic-block ;
-
 : has-phis? ( bb -- ? )
     instructions>> first ##phi? ;
 

basis/compiler/codegen/codegen.factor

@@ -30,6 +30,9 @@ GENERIC: generate-insn ( insn -- )
 ! Mapping _label IDs to label instances
 SYMBOL: labels
 
+: lookup-label ( id -- label )
+    labels get [ drop <label> ] cache ;
+
 : generate ( mr -- code )
     dup label>> [
         H{ } clone labels set
@@ -40,17 +43,9 @@ SYMBOL: labels
         ] each
     ] with-fixup ;
 
-: lookup-label ( id -- label )
-    labels get [ drop <label> ] cache ;
-
 ! Special cases
 M: ##no-tco generate-insn drop ;
 
-M: _dispatch-label generate-insn
-    label>> lookup-label
-    cell 0 <repetition> %
-    rc-absolute-cell label-fixup ;
-
 M: _prologue generate-insn
     stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
 
@@ -76,6 +71,7 @@ M: _spill-area-size generate-insn drop ;
 SYNTAX: CODEGEN:
     scan-word [ \ generate-insn create-method-in ] keep scan-word
     codegen-method-body define ;
+
 >>
 
 CODEGEN: ##load-integer %load-immediate
@@ -203,67 +199,45 @@ CODEGEN: ##save-context %save-context
 CODEGEN: ##vm-field %vm-field
 CODEGEN: ##set-vm-field %set-vm-field
 CODEGEN: ##alien-global %alien-global
+CODEGEN: ##call-gc %call-gc
+
+CODEGEN: ##dispatch %dispatch
+
+: %dispatch-label ( label -- )
+    cell 0 <repetition> %
+    rc-absolute-cell label-fixup ;
 
-CODEGEN: _fixnum-add %fixnum-add
-CODEGEN: _fixnum-sub %fixnum-sub
-CODEGEN: _fixnum-mul %fixnum-mul
 CODEGEN: _label resolve-label
+CODEGEN: _dispatch-label %dispatch-label
 CODEGEN: _branch %jump-label
-CODEGEN: _compare-branch %compare-branch
-CODEGEN: _compare-imm-branch %compare-imm-branch
-CODEGEN: _compare-float-ordered-branch %compare-float-ordered-branch
-CODEGEN: _compare-float-unordered-branch %compare-float-unordered-branch
-CODEGEN: _test-vector-branch %test-vector-branch
-CODEGEN: _dispatch %dispatch
 CODEGEN: _spill %spill
 CODEGEN: _reload %reload
 CODEGEN: _loop-entry %loop-entry
 
-! ##gc
+GENERIC: generate-conditional-insn ( label insn -- )
-: wipe-locs ( locs temp -- )
-    '[
-        _
-        [ 0 %load-immediate ]
-        [ swap [ %replace ] with each ] bi
-    ] unless-empty ;
 
-GENERIC# save-gc-root 1 ( gc-root operand temp -- )
+<<
 
-M:: spill-slot save-gc-root ( gc-root operand temp -- )
+SYNTAX: CONDITIONAL:
-    temp int-rep operand %reload
+    scan-word [ \ generate-conditional-insn create-method-in ] keep scan-word
-    gc-root temp %save-gc-root ;
+    codegen-method-body define ;
 
-M: object save-gc-root drop %save-gc-root ;
+>>
 
-: save-gc-roots ( gc-roots temp -- ) '[ _ save-gc-root ] assoc-each ;
+CONDITIONAL: ##compare-branch %compare-branch
+CONDITIONAL: ##compare-imm-branch %compare-imm-branch
+CONDITIONAL: ##compare-integer-branch %compare-branch
+CONDITIONAL: ##compare-integer-imm-branch %compare-imm-branch
+CONDITIONAL: ##compare-float-ordered-branch %compare-float-ordered-branch
+CONDITIONAL: ##compare-float-unordered-branch %compare-float-unordered-branch
+CONDITIONAL: ##test-vector-branch %test-vector-branch
+CONDITIONAL: ##check-nursery-branch %check-nursery-branch
+CONDITIONAL: ##fixnum-add %fixnum-add
+CONDITIONAL: ##fixnum-sub %fixnum-sub
+CONDITIONAL: ##fixnum-mul %fixnum-mul
 
-: save-data-regs ( data-regs -- ) [ first3 %spill ] each ;
+M: _conditional-branch generate-insn
-
+    [ label>> lookup-label ] [ insn>> ] bi generate-conditional-insn ;
-GENERIC# load-gc-root 1 ( gc-root operand temp -- )
-
-M:: spill-slot load-gc-root ( gc-root operand temp -- )
-    gc-root temp %load-gc-root
-    temp int-rep operand %spill ;
-
-M: object load-gc-root drop %load-gc-root ;
-
-: load-gc-roots ( gc-roots temp -- ) '[ _ load-gc-root ] assoc-each ;
-
-: load-data-regs ( data-regs -- ) [ first3 %reload ] each ;
-
-M: ##gc generate-insn
-    "no-gc" define-label
-    {
-        [ [ "no-gc" get ] dip [ size>> ] [ temp1>> ] [ temp2>> ] tri %check-nursery ]
-        [ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
-        [ data-values>> save-data-regs ]
-        [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
-        [ [ temp1>> ] [ temp2>> ] bi %save-context ]
-        [ [ tagged-values>> length ] [ temp1>> ] bi %call-gc ]
-        [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
-        [ data-values>> load-data-regs ]
-    } cleave
-    "no-gc" resolve-label ;
 
 ! ##alien-invoke
 GENERIC: next-fastcall-param ( rep -- )

basis/cpu/architecture/architecture.factor

@@ -272,9 +272,9 @@ HOOK: %copy cpu ( dst src rep -- )
 
 : %tagged>integer ( dst src -- ) int-rep %copy ;
 
-HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
+HOOK: %fixnum-add cpu ( label dst src1 src2 cc -- )
-HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
+HOOK: %fixnum-sub cpu ( label dst src1 src2 cc -- )
-HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
+HOOK: %fixnum-mul cpu ( label dst src1 src2 cc -- )
 
 HOOK: %add-float cpu ( dst src1 src2 -- )
 HOOK: %sub-float cpu ( dst src1 src2 -- )
@@ -463,10 +463,8 @@ HOOK: %write-barrier cpu ( src slot scale tag temp1 temp2 -- )
 HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- )
 
 ! GC checks
-HOOK: %check-nursery cpu ( label size temp1 temp2 -- )
+HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
-HOOK: %save-gc-root cpu ( gc-root register -- )
+HOOK: %call-gc cpu ( gc-roots -- )
-HOOK: %load-gc-root cpu ( gc-root register -- )
-HOOK: %call-gc cpu ( gc-root-count temp1 -- )
 
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )

basis/cpu/x86/32/32.factor

@@ -344,11 +344,10 @@ M: x86.32 stack-cleanup ( params -- n )
 M: x86.32 %cleanup ( params -- )
     stack-cleanup [ ESP swap SUB ] unless-zero ;
 
-M:: x86.32 %call-gc ( gc-root-count temp -- )
+M:: x86.32 %call-gc ( gc-roots -- )
-    temp gc-root-base special@ LEA
+    4 save-vm-ptr
-    8 save-vm-ptr
+    EAX gc-roots gc-root-offsets %load-reference
-    4 stack@ gc-root-count MOV
+    0 stack@ EAX MOV
-    0 stack@ temp MOV
     "inline_gc" f %alien-invoke ;
 
 M: x86.32 dummy-stack-params? f ;

basis/cpu/x86/64/64.factor

@@ -267,14 +267,9 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
     func "libm" load-library %alien-invoke
     dst float-function-return ;
 
-M:: x86.64 %call-gc ( gc-root-count temp -- )
+M:: x86.64 %call-gc ( gc-roots -- )
-    ! Pass pointer to start of GC roots as first parameter
+    param-reg-0 gc-roots gc-root-offsets %load-reference
-    param-reg-0 gc-root-base param@ LEA
+    param-reg-1 %mov-vm-ptr
-    ! Pass number of roots as second parameter
-    param-reg-1 gc-root-count MOV
-    ! Pass VM ptr as third parameter
-    param-reg-2 %mov-vm-ptr
-    ! Call GC
     "inline_gc" f %alien-invoke ;
 
 M: x86.64 struct-return-pointer-type void* ;

basis/cpu/x86/assembler/assembler.factor

@@ -334,7 +334,7 @@ PRIVATE>
 : SAR ( dst n -- ) BIN: 111 (SHIFT) ;
 
 : IMUL2 ( dst src -- )
-    swap OCT: 257 extended-opcode (2-operand) ;
+    OCT: 257 extended-opcode (2-operand) ;
 
 : IMUL3 ( dst src imm -- )
     dup fits-in-byte? [

basis/cpu/x86/bootstrap.factor

@@ -465,7 +465,7 @@ big-endian off
     ! multiply
     temp0 temp1 IMUL2
     ! push result
-    ds-reg [] temp1 MOV
+    ds-reg [] temp0 MOV
 ] \ fixnum*fast define-sub-primitive
 
 [ \ AND jit-math ] \ fixnum-bitand define-sub-primitive

basis/cpu/x86/x86.factor

@@ -33,17 +33,19 @@ HOOK: extra-stack-space cpu ( stack-frame -- n )
 
 : stack@ ( n -- op ) stack-reg swap [+] ;
 
-: special@ ( n -- op )
+: special-offset ( m -- n )
     stack-frame get extra-stack-space +
-    reserved-stack-space +
+    reserved-stack-space + ;
-    stack@ ;
+
+: special@ ( n -- op ) special-offset stack@ ;
 
 : spill@ ( n -- op ) spill-offset special@ ;
 
-: gc-root@ ( n -- op ) gc-root-offset special@ ;
-
 : param@ ( n -- op ) reserved-stack-space + stack@ ;
 
+: gc-root-offsets ( seq -- seq' )
+    [ n>> special-offset ] map f like ;
+
 : decr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
 
@@ -133,7 +135,7 @@ M: x86 %add     2over eq? [ nip ADD ] [ [+] LEA ] if ;
 M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ;
 M: x86 %sub     int-rep two-operand SUB ;
 M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ;
-M: x86 %mul     int-rep two-operand swap IMUL2 ;
+M: x86 %mul     int-rep two-operand IMUL2 ;
 M: x86 %mul-imm IMUL3 ;
 M: x86 %and     int-rep two-operand AND ;
 M: x86 %and-imm int-rep two-operand AND ;
@@ -175,14 +177,21 @@ M: x86 %copy ( dst src rep -- )
         2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
     ] if ;
 
-M: x86 %fixnum-add ( label dst src1 src2 -- )
+: fixnum-overflow ( label dst src1 src2 cc quot -- )
-    int-rep two-operand ADD JO ;
+    swap [ [ int-rep two-operand ] dip call ] dip
+    {
+        { cc-o [ JO ] }
+        { cc/o [ JNO ] }
+    } case ; inline
 
-M: x86 %fixnum-sub ( label dst src1 src2 -- )
+M: x86 %fixnum-add ( label dst src1 src2 cc -- )
-    int-rep two-operand SUB JO ;
+    [ ADD ] fixnum-overflow ;
 
-M: x86 %fixnum-mul ( label dst src1 src2 -- )
+M: x86 %fixnum-sub ( label dst src1 src2 cc -- )
-    int-rep two-operand swap IMUL2 JO ;
+    [ SUB ] fixnum-overflow ;
+
+M: x86 %fixnum-mul ( label dst src1 src2 cc -- )
+    [ IMUL2 ] fixnum-overflow ;
 
 M: x86 %unbox-alien ( dst src -- )
     alien-offset [+] MOV ;
@@ -453,19 +462,15 @@ M:: x86 %write-barrier-imm ( src slot tag temp1 temp2 -- )
     temp1 src slot tag (%slot-imm) LEA
     temp1 temp2 (%write-barrier) ;
 
-M:: x86 %check-nursery ( label size temp1 temp2 -- )
+M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- )
     temp1 load-zone-offset
-    ! Load 'here' into temp2
     temp2 temp1 [] MOV
     temp2 size ADD
-    ! Load 'end' into temp1
+    temp2 temp1 2 cells [+] CMP
-    temp1 temp1 2 cells [+] MOV
+    cc {
-    temp2 temp1 CMP
+        { cc<= [ label JLE ] }
-    label JLE ;
+        { cc/<= [ label JG ] }
-
+    } case ;
-M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
-
-M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
 
 M: x86 %alien-global ( dst symbol library -- )
     [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;    

vm/gc.cpp

@@ -215,16 +215,34 @@ void factor_vm::primitive_compact_gc()
 		true /* trace contexts? */);
 }
 
-void factor_vm::inline_gc(cell *data_roots_base, cell data_roots_size)
+void factor_vm::inline_gc(cell gc_roots_)
 {
-	data_roots.push_back(data_root_range(data_roots_base,data_roots_size));
+	cell stack_pointer = (cell)ctx->callstack_top + sizeof(cell);
-	primitive_minor_gc();
+
-	data_roots.pop_back();
+	if(to_boolean(gc_roots_))
+	{
+		tagged<array> gc_roots(gc_roots_);
+
+		cell capacity = array_capacity(gc_roots.untagged());
+		for(cell i = 0; i < capacity; i++)
+		{
+			cell spill_slot = untag_fixnum(array_nth(gc_roots.untagged(),i));
+			cell *address = (cell *)(spill_slot + stack_pointer);
+			data_roots.push_back(data_root_range(address,1));
+		}
+
+		primitive_minor_gc();
+
+		for(cell i = 0; i < capacity; i++)
+			data_roots.pop_back();
+	}
+	else
+		primitive_minor_gc();
 }
 
-VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent)
+VM_C_API void inline_gc(cell gc_roots, factor_vm *parent)
 {
-	parent->inline_gc(data_roots_base,data_roots_size);
+	parent->inline_gc(gc_roots);
 }
 
 /*

vm/gc.hpp

@@ -52,6 +52,6 @@ struct gc_state {
 	void start_again(gc_op op_, factor_vm *parent);
 };
 
-VM_C_API void inline_gc(cell *data_roots_base, cell data_roots_size, factor_vm *parent);
+VM_C_API void inline_gc(cell gc_roots, factor_vm *parent);
 
 }

vm/vm.hpp

@@ -320,7 +320,7 @@ struct factor_vm
 	void primitive_minor_gc();
 	void primitive_full_gc();
 	void primitive_compact_gc();
-	void inline_gc(cell *data_roots_base, cell data_roots_size);
+	void inline_gc(cell gc_roots);
 	void primitive_enable_gc_events();
 	void primitive_disable_gc_events();
 	object *allot_object(cell type, cell size);