FFI rewrite part 6: deconcatenatize

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

@@ -287,3 +287,75 @@ IN: compiler.cfg.alias-analysis.tests
         T{ ##compare f 6 5 1 cc= }
     } test-alias-analysis
 ] unit-test
+
+! We can't make any assumptions about heap-ac between alien
+! calls, since they might callback into Factor code
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##alien-invoke f "free" }
+        T{ ##slot-imm f 2 0 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##alien-invoke f "free" }
+        T{ ##slot-imm f 2 0 1 0 }
+    } test-alias-analysis
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+        T{ ##alien-invoke f "free" }
+        T{ ##slot-imm f 2 0 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+        T{ ##alien-invoke f "free" }
+        T{ ##slot-imm f 2 0 1 0 }
+    } test-alias-analysis
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+        T{ ##alien-invoke f "free" }
+        T{ ##set-slot-imm f 2 0 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##peek f 1 D 1 }
+        T{ ##peek f 2 D 2 }
+        T{ ##set-slot-imm f 1 0 1 0 }
+        T{ ##alien-invoke f "free" }
+        T{ ##set-slot-imm f 2 0 1 0 }
+    } test-alias-analysis
+] unit-test
+
+[
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##alien-invoke f "free" }
+        T{ ##set-slot-imm f 1 0 1 0 }
+    }
+] [
+    V{
+        T{ ##peek f 0 D 0 }
+        T{ ##slot-imm f 1 0 1 0 }
+        T{ ##alien-invoke f "free" }
+        T{ ##set-slot-imm f 1 0 1 0 }
+    } test-alias-analysis
+] unit-test

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

@@ -186,6 +186,15 @@ SYMBOL: heap-ac
         slot# vreg kill-constant-set-slot
     ] [ vreg kill-computed-set-slot ] if ;
 
+: init-alias-analysis ( -- )
+    H{ } clone vregs>acs set
+    H{ } clone acs>vregs set
+    H{ } clone live-slots set
+    H{ } clone copies set
+    H{ } clone recent-stores set
+    HS{ } clone dead-stores set
+    0 ac-counter set ;
+
 GENERIC: insn-slot# ( insn -- slot#/f )
 GENERIC: insn-object ( insn -- vreg )
 
@@ -277,22 +286,6 @@ M: ##compare analyze-aliases
         analyze-aliases
     ] when ;
 
-GENERIC: eliminate-dead-stores ( insn -- ? )
-
-M: ##set-slot-imm eliminate-dead-stores
-    insn#>> dead-stores get in? not ;
-
-M: insn eliminate-dead-stores drop t ;
-
-: init-alias-analysis ( -- )
-    H{ } clone vregs>acs set
-    H{ } clone acs>vregs set
-    H{ } clone live-slots set
-    H{ } clone copies set
-    H{ } clone recent-stores set
-    HS{ } clone dead-stores set
-    0 ac-counter set ;
-
 : reset-alias-analysis ( -- )
     recent-stores get clear-assoc
     vregs>acs get clear-assoc
@@ -305,6 +298,19 @@ M: insn eliminate-dead-stores drop t ;
     \ ##vm-field set-new-ac
     \ ##alien-global set-new-ac ;
 
+M: factor-call-insn analyze-aliases
+    heap-ac get ac>vregs [
+        [ live-slots get at clear-assoc ]
+        [ recent-stores get at clear-assoc ] bi
+    ] each ;
+
+GENERIC: eliminate-dead-stores ( insn -- ? )
+
+M: ##set-slot-imm eliminate-dead-stores
+    insn#>> dead-stores get in? not ;
+
+M: insn eliminate-dead-stores drop t ;
+
 : alias-analysis-step ( insns -- insns' )
     reset-alias-analysis
     [ local-live-in [ set-heap-ac ] each ]

basis/compiler/cfg/branch-splitting/branch-splitting.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2009, 2010 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.short-circuit kernel
-math math.order sequences assocs namespaces vectors fry arrays
+locals math math.order sequences assocs namespaces vectors fry
-splitting compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
+arrays splitting compiler.cfg.def-use compiler.cfg
-compiler.cfg.predecessors compiler.cfg.renaming
+compiler.cfg.rpo compiler.cfg.predecessors compiler.cfg.renaming
 compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.branch-splitting
 
@@ -29,24 +29,18 @@ IN: compiler.cfg.branch-splitting
         1vector >>predecessors
     ] with map ;
 
-: update-predecessor-successor ( pred copy old-bb -- )
-    '[
-        [ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
-    ] change-successors drop ;
-
 : update-predecessor-successors ( copies old-bb -- )
     [ predecessors>> swap ] keep
-    '[ _ update-predecessor-successor ] 2each ;
+    '[ [ _ ] 2dip update-predecessors ] 2each ;
 
-: update-successor-predecessor ( copies old-bb succ -- )
+:: update-successor-predecessor ( copies old-bb succ -- )
-    [
+    succ
-        swap 1array split swap join V{ } like
+    [ { old-bb } split copies join V{ } like ] change-predecessors
-    ] change-predecessors drop ;
+    drop ;
 
 : update-successor-predecessors ( copies old-bb -- )
-    dup successors>> [
+    dup successors>>
-        update-successor-predecessor
+    [ update-successor-predecessor ] with with each ;
-    ] with with each ;
 
 : split-branch ( bb -- )
     [ new-blocks ] keep

basis/compiler/cfg/builder/alien/alien.factor

@@ -1,25 +1,26 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs arrays layouts math math.order math.parser
+USING: accessors assocs arrays layouts math math.order
-combinators combinators.short-circuit fry make sequences
+math.parser combinators combinators.short-circuit fry make
-sequences.generalizations alien alien.private alien.strings
+sequences sequences.generalizations alien alien.private
-alien.c-types alien.libraries classes.struct namespaces kernel
+alien.strings alien.c-types alien.libraries classes.struct
-strings libc locals quotations words cpu.architecture
+namespaces kernel strings libc locals quotations words
-compiler.utilities compiler.tree compiler.cfg
+cpu.architecture compiler.utilities compiler.tree compiler.cfg
 compiler.cfg.builder compiler.cfg.builder.alien.params
 compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
 compiler.cfg.instructions compiler.cfg.stack-frame
-compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
+compiler.cfg.stacks compiler.cfg.stacks.local
+compiler.cfg.registers compiler.cfg.hats ;
 FROM: compiler.errors => no-such-symbol no-such-library ;
 IN: compiler.cfg.builder.alien
 
 : unbox-parameters ( parameters -- vregs reps )
     [
         [ length iota <reversed> ] keep
-        [ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
+        [ [ <ds-loc> peek-loc ] [ base-type ] bi* unbox-parameter ]
         2 2 mnmap [ concat ] bi@
     ]
-    [ length neg ##inc-d ] bi ;
+    [ length neg inc-d ] bi ;
 
 : prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
     dup large-struct? [
@@ -54,7 +55,7 @@ IN: compiler.cfg.builder.alien
     struct-return-area set ;
 
 : box-return* ( node -- )
-    return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
+    return>> [ ] [ base-type box-return ds-push ] if-void ;
 
 GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
 
@@ -83,49 +84,38 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
     [ library>> load-library ]
     bi 2dup check-dlsym ;
 
-: alien-node-height ( params -- )
-    [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
-
-: emit-alien-block ( node quot: ( params -- ) -- )
-    '[
-        make-kill-block
-        params>>
-        _ [ alien-node-height ] bi
-    ] emit-trivial-block ; inline
-
 : emit-stack-frame ( stack-size params -- )
     [ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
     [ drop ##stack-frame ]
     2bi ;
 
 M: #alien-invoke emit-node
-    [
+    params>>
-        {
+    {
-            [ caller-parameters ]
+        [ caller-parameters ]
-            [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
+        [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
-            [ emit-stack-frame ]
-            [ box-return* ]
-        } cleave
-    ] emit-alien-block ;
-
-M:: #alien-indirect emit-node ( node -- )
-    node [
-        D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
-        [ caller-parameters src <gc-map> ##alien-indirect ]
         [ emit-stack-frame ]
         [ box-return* ]
-        tri
+    } cleave ;
-    ] emit-alien-block ;
+
+M: #alien-indirect emit-node ( node -- )
+    params>>
+    [
+        ds-pop ^^unbox-any-c-ptr
+        [ caller-parameters ] dip
+        <gc-map> ##alien-indirect
+    ]
+    [ emit-stack-frame ]
+    [ box-return* ]
+    tri ;
 
 M: #alien-assembly emit-node
-    [
+    params>> {
-        {
+        [ caller-parameters ]
-            [ caller-parameters ]
+        [ quot>> <gc-map> ##alien-assembly ]
-            [ quot>> ##alien-assembly ]
+        [ emit-stack-frame ]
-            [ emit-stack-frame ]
+        [ box-return* ]
-            [ box-return* ]
+    } cleave ;
-        } cleave
-    ] emit-alien-block ;
 
 : callee-parameter ( rep on-stack? -- dst insn )
     [ next-vreg dup ] 2dip
@@ -148,13 +138,7 @@ M: #alien-assembly emit-node
     bi ;
 
 : box-parameters ( vregs reps params -- )
-    ##begin-callback
+    ##begin-callback [ box-parameter ds-push ] 3each ;
-    next-vreg next-vreg ##restore-context
-    [
-        next-vreg next-vreg ##save-context
-        box-parameter
-        1 ##inc-d D 0 ##replace
-    ] 3each ;
 
 : callee-parameters ( params -- stack-size )
     [ abi>> ] [ return>> ] [ parameters>> ] tri
@@ -174,25 +158,29 @@ M: #alien-assembly emit-node
     cfg get t >>frame-pointer? drop ;
 
 M: #alien-callback emit-node
-    dup params>> xt>> dup
+    params>> dup xt>> dup
     [
         needs-frame-pointer
 
-        ##prologue
+        begin-word
-        [
+
-            {
+        {
-                [ callee-parameters ]
+            [ callee-parameters ]
-                [ quot>> ##alien-callback ]
+            [
                 [
-                    return>> [ ##end-callback ] [
+                    make-kill-block
-                        [ D 0 ^^peek ] dip
+                    quot>> ##alien-callback
-                        ##end-callback
+                ] emit-trivial-block
-                        base-type unbox-return
+            ]
-                    ] if-void
+            [
-                ]
+                return>> [ ##end-callback ] [
-                [ callback-stack-cleanup ]
+                    [ ds-pop ] dip
-            } cleave
+                    ##end-callback
-        ] emit-alien-block
+                    base-type unbox-return
-        ##epilogue
+                ] if-void
-        ##return
+            ]
+            [ callback-stack-cleanup ]
+        } cleave
+
+        end-word
     ] with-cfg-builder ;

basis/compiler/cfg/builder/builder.factor

@@ -198,17 +198,17 @@ M: #shuffle emit-node
     dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
 
 ! #return
-: emit-return ( -- )
+: end-word ( -- )
     ##branch
     begin-basic-block
     make-kill-block
     ##epilogue
     ##return ;
 
-M: #return emit-node drop emit-return ;
+M: #return emit-node drop end-word ;
 
 M: #return-recursive emit-node
-    label>> id>> loops get key? [ emit-return ] unless ;
+    label>> id>> loops get key? [ end-word ] unless ;
 
 ! #terminate
 M: #terminate emit-node drop ##no-tco end-basic-block ;

basis/compiler/cfg/finalization/finalization.factor

@@ -9,7 +9,7 @@ IN: compiler.cfg.finalization
 
 : finalize-cfg ( cfg -- cfg' )
     select-representations
-    schedule-instructions
+    ! schedule-instructions
     insert-gc-checks
     dup compute-uninitialized-sets
     insert-save-contexts

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

@@ -3,9 +3,85 @@ compiler.cfg.gc-checks.private compiler.cfg.debugger
 compiler.cfg.registers compiler.cfg.instructions compiler.cfg
 compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
 tools.test kernel vectors namespaces accessors sequences alien
-memory classes make combinators.short-circuit byte-arrays ;
+memory classes make combinators.short-circuit byte-arrays
+compiler.cfg.comparisons ;
 IN: compiler.cfg.gc-checks.tests
 
+[ { } ] [
+    V{
+        T{ ##inc-d }
+        T{ ##peek }
+        T{ ##add }
+        T{ ##branch }
+    } gc-check-offsets
+] unit-test
+
+[ { } ] [
+    V{
+        T{ ##inc-d }
+        T{ ##peek }
+        T{ ##alien-invoke }
+        T{ ##add }
+        T{ ##branch }
+    } gc-check-offsets
+] unit-test
+
+[ { 0 } ] [
+    V{
+        T{ ##inc-d }
+        T{ ##peek }
+        T{ ##allot }
+        T{ ##alien-invoke }
+        T{ ##add }
+        T{ ##branch }
+    } gc-check-offsets
+] unit-test
+
+[ { 0 } ] [
+    V{
+        T{ ##inc-d }
+        T{ ##peek }
+        T{ ##allot }
+        T{ ##allot }
+        T{ ##add }
+        T{ ##branch }
+    } gc-check-offsets
+] unit-test
+
+[ { 0 4 } ] [
+    V{
+        T{ ##inc-d }
+        T{ ##peek }
+        T{ ##allot }
+        T{ ##alien-invoke }
+        T{ ##allot }
+        T{ ##add }
+        T{ ##sub }
+        T{ ##branch }
+    } gc-check-offsets
+] unit-test
+
+[ { 3 } ] [
+    V{
+        T{ ##inc-d }
+        T{ ##peek }
+        T{ ##alien-invoke }
+        T{ ##allot }
+        T{ ##add }
+        T{ ##branch }
+    } gc-check-offsets
+] unit-test
+
+[ { { "a" } } ] [ { "a" } { } split-instructions ] unit-test
+
+[ { { } { "a" } } ] [ { "a" } { 0 } split-instructions ] unit-test
+
+[ { { "a" } { } } ] [ { "a" } { 1 } split-instructions ] unit-test
+
+[ { { "a" } { "b" } } ] [ { "a" "b" } { 1 } split-instructions ] unit-test
+
+[ { { } { "a" } { "b" "c" } } ] [ { "a" "b" "c" } { 0 1 } split-instructions ] unit-test
+
 : test-gc-checks ( -- )
     H{ } clone representations set
     cfg new 0 get >>entry cfg set ;
@@ -25,7 +101,7 @@ V{
 
 [ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
 
-[ ] [ 1 get allocation-size 123 <alien> size assert= ] unit-test
+[ ] [ 1 get instructions>> allocation-size 123 <alien> size assert= ] unit-test
 
 2 \ vreg-counter set-global
 
@@ -36,58 +112,16 @@ V{
         [ first ##check-nursery-branch? ]
     } 1&& ;
 
-[ t ] [ V{ } 100 <gc-check> gc-check? ] unit-test
+: gc-call? ( bb -- ? )
-
+    instructions>>
-4 \ vreg-counter set-global
-
-[
     V{
         T{ ##call-gc f T{ gc-map } }
         T{ ##branch }
-    }
+    } = ;
-]
-[
-    <gc-call> instructions>>
-] unit-test
 
-30 \ vreg-counter set-global
+4 \ vreg-counter set-global
 
-V{
+[ t ] [ <gc-call> gc-call? ] unit-test
-    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
-
-[ ] [ V{ } 31337 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
 
@@ -135,6 +169,8 @@ H{
 
 [ ] [ cfg get insert-gc-checks drop ] unit-test
 
+[ ] [ 1 get successors>> first successors>> first 2 set ] unit-test
+
 [ 2 ] [ 2 get predecessors>> length ] unit-test
 
 [ t ] [ 1 get successors>> first gc-check? ] unit-test
@@ -187,5 +223,148 @@ H{
 } representations set
 
 [ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ 1 get successors>> first successors>> first 3 set ] unit-test
 [ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
 [ 2 ] [ 3 get instructions>> length ] unit-test
+
+! GC check in a block that is its own successor
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##allot f 1 64 byte-array }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 { 1 2 } edges
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[ ] [
+    0 get successors>> first predecessors>>
+    [ first 0 get assert= ]
+    [ second 1 get [ instructions>> ] bi@ assert= ] bi
+] unit-test
+
+[ ] [
+    0 get successors>> first successors>>
+    [ first 1 get [ instructions>> ] bi@ assert= ]
+    [ second gc-call? t assert= ] bi
+] unit-test
+
+[ ] [
+    2 get predecessors>> first predecessors>>
+    [ first gc-check? t assert= ]
+    [ second gc-call? t assert= ] bi
+] unit-test
+
+! Brave new world of calls in the middle of BBs
+
+! call then allot
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##alien-invoke f "malloc" f T{ gc-map } }
+    T{ ##allot f 1 64 byte-array }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+2 \ vreg-counter set-global
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+! The GC check should come after the alien-invoke
+[
+    V{
+        T{ ##alien-invoke f "malloc" f T{ gc-map } }
+        T{ ##check-nursery-branch f 64 cc<= 3 4 }
+    }
+] [ 0 get successors>> first instructions>> ] unit-test
+
+! call then allot then call then allot
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##alien-invoke f "malloc" f T{ gc-map } }
+    T{ ##allot f 1 64 byte-array }
+    T{ ##alien-invoke f "malloc" f T{ gc-map } }
+    T{ ##allot f 2 64 byte-array }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 2 test-bb
+
+0 1 edge
+1 2 edge
+
+2 \ vreg-counter set-global
+
+[ ] [ test-gc-checks ] unit-test
+
+[ ] [ cfg get insert-gc-checks drop ] unit-test
+
+[
+    V{
+        T{ ##alien-invoke f "malloc" f T{ gc-map } }
+        T{ ##check-nursery-branch f 64 cc<= 3 4 }
+    }
+] [
+    0 get
+    successors>> first
+    instructions>>
+] unit-test
+
+[
+    V{
+        T{ ##allot f 1 64 byte-array }
+        T{ ##alien-invoke f "malloc" f T{ gc-map } }
+        T{ ##check-nursery-branch f 64 cc<= 5 6 }
+    }
+] [
+    0 get
+    successors>> first
+    successors>> first
+    instructions>>
+] unit-test
+
+[
+    V{
+        T{ ##allot f 2 64 byte-array }
+        T{ ##branch }
+    }
+] [
+    0 get
+    successors>> first
+    successors>> first
+    successors>> first
+    instructions>>
+] unit-test

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

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators fry kernel layouts locals
+USING: accessors assocs combinators fry grouping kernel layouts
-math make namespaces sequences cpu.architecture
+locals math make namespaces sequences cpu.architecture
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.hats
@@ -12,12 +12,12 @@ compiler.cfg.instructions
 compiler.cfg.predecessors ;
 IN: compiler.cfg.gc-checks
 
-<PRIVATE
-
 ! Garbage collection check insertion. This pass runs after
 ! representation selection, since it needs to know which vregs
 ! can contain tagged pointers.
 
+<PRIVATE
+
 : insert-gc-check? ( bb -- ? )
     dup kill-block?>>
     [ drop f ] [ instructions>> [ ##allocation? ] any? ] if ;
@@ -25,46 +25,38 @@ 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
+GENERIC# gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index seen-allocation? )
-! and gc-call:
-!
-!    gc-check
-!   /      \
-!  |     gc-call
-!   \      /
-!      bb
 
-! Any ##phi instructions at the start of bb are transplanted
+:: gc-check-here ( call-index seen-allocation? insn insn-index -- call-index seen-allocation? )
-! into the gc-check block.
+    seen-allocation? [ call-index , ] when
+    insn-index 1 + f ;
 
-: <gc-check> ( phis size -- bb )
+M: ##phi gc-check-offsets* gc-check-here ;
-    [ <basic-block> ] 2dip
+M: gc-map-insn gc-check-offsets* gc-check-here ;
+M: ##allocation gc-check-offsets* 3drop t ;
+M: insn gc-check-offsets* 2drop ;
+
+: gc-check-offsets ( insns -- seq )
+    ! A basic block is divided into sections by call and phi
+    ! instructions. For every section with at least one
+    ! allocation, record the offset of its first instruction
+    ! in a sequence.
     [
-        [ % ]
+        [ 0 f ] dip
-        [
+        [ gc-check-offsets* ] each-index
-            cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+        [ , ] [ drop ] if
-            ##check-nursery-branch
+    ] { } make ;
-        ] bi*
-    ] V{ } make >>instructions ;
 
-: <gc-call> ( -- bb )
+:: split-instructions ( insns seq -- insns-seq )
-    <basic-block>
+    ! Divide a basic block into sections, where every section
-    [ <gc-map> ##call-gc ##branch ] V{ } make
+    ! other than the first requires a GC check.
-    >>instructions t >>unlikely? ;
+    [
-
+        insns 0 seq [| insns from to |
-:: insert-guard ( body check bb -- )
+            from to insns subseq ,
-    bb predecessors>> check predecessors<<
+            insns to
-    V{ bb body }      check successors<<
+        ] each
-
+        tail ,
-    V{ check }        body predecessors<<
+    ] { } make ;
-    V{ bb }           body successors<<
-
-    V{ check body }   bb predecessors<<
-
-    check predecessors>> [ bb check update-successors ] each ;
-
-: (insert-gc-check) ( phis size bb -- )
-    [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
 
 GENERIC: allocation-size* ( insn -- n )
 
@@ -74,22 +66,75 @@ M: ##box-alien allocation-size* drop 5 cells ;
 
 M: ##box-displaced-alien allocation-size* drop 5 cells ;
 
-: allocation-size ( bb -- n )
+: allocation-size ( insns -- n )
-    instructions>>
     [ ##allocation? ] filter
     [ allocation-size* data-alignment get align ] map-sum ;
 
-: remove-phis ( bb -- phis )
+: add-gc-checks ( insns-seq -- )
-    [ [ ##phi? ] partition ] change-instructions drop ;
+    ! Insert a GC check at the end of every chunk but the last
+    ! one. This ensures that every section other than the first
+    ! has a GC check in the section immediately preceeding it.
+    2 <clumps> [
+        first2 allocation-size
+        cc<= int-rep next-vreg-rep int-rep next-vreg-rep
+        \ ##check-nursery-branch new-insn
+        swap push
+    ] each ;
 
-: insert-gc-check ( bb -- )
+: make-blocks ( insns-seq -- bbs )
-    [ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ;
+    [ <basic-block> swap >>instructions ] map ;
+
+: <gc-call> ( -- bb )
+    <basic-block>
+    [ <gc-map> ##call-gc ##branch ] V{ } make
+    >>instructions t >>unlikely? ;
+
+:: connect-gc-checks ( bbs -- )
+    ! Every basic block but the last has two successors:
+    ! the next block, and a GC call.
+    ! Every basic block but the first has two predecessors:
+    ! the previous block, and the previous block's GC call.
+    bbs length 1 - :> len
+    len [ <gc-call> ] replicate :> gc-calls
+    len [| n |
+        n bbs nth :> bb
+        n 1 + bbs nth :> next-bb
+        n gc-calls nth :> gc-call
+        V{ next-bb gc-call } bb successors<<
+        V{ next-bb } gc-call successors<<
+        V{ bb } gc-call predecessors<<
+        V{ bb gc-call } next-bb predecessors<<
+    ] each-integer ;
+
+:: update-predecessor-phis ( from to bb -- )
+    to [
+        [
+            [
+                [ dup from eq? [ drop bb ] when ] dip
+            ] assoc-map
+        ] change-inputs drop
+    ] each-phi ;
+
+:: (insert-gc-checks) ( bb bbs -- )
+    bb predecessors>> bbs first predecessors<<
+    bb successors>> bbs last successors<<
+    bb predecessors>> [ bb bbs first update-successors ] each
+    bb successors>> [
+        [ bb ] dip bbs last
+        [ update-predecessors ]
+        [ update-predecessor-phis ] 3bi
+    ] each ;
+
+: process-block ( bb -- )
+    dup instructions>> dup gc-check-offsets split-instructions
+    [ add-gc-checks ] [ make-blocks dup connect-gc-checks ] bi
+    (insert-gc-checks) ;
 
 PRIVATE>
 
 : insert-gc-checks ( cfg -- cfg' )
     dup blocks-with-gc [
         [ needs-predecessors ] dip
-        [ insert-gc-check ] each
+        [ process-block ] each
         cfg-changed
     ] unless-empty ;

basis/compiler/cfg/instructions/instructions.factor

@@ -694,7 +694,7 @@ use: src/int-rep
 literal: gc-map ;
 
 INSN: ##alien-assembly
-literal: quot ;
+literal: quot gc-map ;
 
 INSN: ##begin-callback ;
 
@@ -812,9 +812,6 @@ literal: cc ;
 INSN: ##save-context
 temp: temp1/int-rep temp2/int-rep ;
 
-INSN: ##restore-context
-temp: temp1/int-rep temp2/int-rep ;
-
 ! GC checks
 INSN: ##check-nursery-branch
 literal: size cc
@@ -858,15 +855,21 @@ UNION: conditional-branch-insn
 UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
 UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
 
+! Instructions that contain subroutine calls to functions which
+! can callback arbitrary Factor code
+UNION: factor-call-insn
+##alien-invoke
+##alien-indirect
+##alien-assembly ;
+
 ! Instructions that contain subroutine calls to functions which
 ! allocate memory
 UNION: gc-map-insn
 ##call-gc
-##alien-invoke
-##alien-indirect
 ##box
 ##box-long-long
-##allot-byte-array ;
+##allot-byte-array
+factor-call-insn ;
 
 M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;
 

basis/compiler/cfg/liveness/liveness.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs sequences sets
+USING: kernel accessors assocs namespaces sequences sets
 compiler.cfg.def-use compiler.cfg.dataflow-analysis
 compiler.cfg.instructions compiler.cfg.registers
 cpu.architecture ;
@@ -24,7 +24,12 @@ GENERIC: visit-insn ( live-set insn -- live-set )
 M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
 
 : fill-gc-map ( live-set insn -- live-set )
-    gc-map>> over keys [ rep-of tagged-rep? ] filter >>gc-roots drop ;
+    representations get [
+        gc-map>> over keys
+        [ rep-of tagged-rep? ] filter
+        >>gc-roots
+    ] when
+    drop ;
 
 M: gc-map-insn visit-insn
     [ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;

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

@@ -1,6 +1,7 @@
 USING: accessors compiler.cfg.debugger
 compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.save-contexts kernel namespaces tools.test ;
+compiler.cfg.save-contexts kernel namespaces tools.test
+cpu.x86.assembler.operands cpu.architecture ;
 IN: compiler.cfg.save-contexts.tests
 
 0 vreg-counter set-global
@@ -38,3 +39,34 @@ V{
 ] [
     0 get instructions>>
 ] unit-test
+
+4 vreg-counter set-global
+
+V{
+    T{ ##inc-d f 3 }
+    T{ ##load-reg-param f 0 RCX int-rep }
+    T{ ##load-reg-param f 1 RDX int-rep }
+    T{ ##load-reg-param f 2 R8 int-rep }
+    T{ ##begin-callback }
+    T{ ##box f 4 3 "from_signed_4" int-rep
+        T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
+    }
+} 0 test-bb
+
+0 get insert-save-context
+
+[
+    V{
+        T{ ##inc-d f 3 }
+        T{ ##load-reg-param f 0 RCX int-rep }
+        T{ ##load-reg-param f 1 RDX int-rep }
+        T{ ##load-reg-param f 2 R8 int-rep }
+        T{ ##save-context f 5 6 }
+        T{ ##begin-callback }
+        T{ ##box f 4 3 "from_signed_4" int-rep
+            T{ gc-map { scrub-d B{ 0 0 0 } } { scrub-r B{ } } { gc-roots { } } }
+        }
+    }
+] [
+    0 get instructions>>
+] unit-test

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

@@ -1,30 +1,44 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit
+USING: accessors compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.instructions compiler.cfg.registers
 compiler.cfg.rpo cpu.architecture kernel sequences vectors ;
 IN: compiler.cfg.save-contexts
 
 ! Insert context saves.
 
-: needs-save-context? ( insns -- ? )
+GENERIC: needs-save-context? ( insn -- ? )
-    [
+
-        {
+M: ##unary-float-function needs-save-context? drop t ;
-            [ ##unary-float-function? ]
+M: ##binary-float-function needs-save-context? drop t ;
-            [ ##binary-float-function? ]
+M: gc-map-insn needs-save-context? drop t ;
-            [ ##alien-invoke? ]
+M: insn needs-save-context? drop f ;
-            [ ##alien-indirect? ]
+
-            [ ##alien-assembly? ]
+: bb-needs-save-context? ( insn -- ? )
-        } 1||
+    instructions>> [ needs-save-context? ] any? ;
-    ] any? ;
+
+GENERIC: modifies-context? ( insn -- ? )
+
+M: ##inc-d modifies-context? drop t ;
+M: ##inc-r modifies-context? drop t ;
+M: ##load-reg-param modifies-context? drop t ;
+M: insn modifies-context? drop f ;
+
+: save-context-offset ( bb -- n )
+    ! ##save-context must be placed after instructions that
+    ! modify the context, or instructions that read parameter
+    ! registers.
+    instructions>> [ modifies-context? not ] find drop ;
 
 : insert-save-context ( bb -- )
-    dup instructions>> dup needs-save-context? [
+    dup bb-needs-save-context? [
-        tagged-rep next-vreg-rep
+        [
-        tagged-rep next-vreg-rep
+            int-rep next-vreg-rep
-        \ ##save-context new-insn prefix
+            int-rep next-vreg-rep
-        >>instructions drop
+            \ ##save-context new-insn
-    ] [ 2drop ] if ;
+        ] dip
+        [ save-context-offset ] keep
+        [ insert-nth ] change-instructions drop
+    ] [ drop ] if ;
 
 : insert-save-contexts ( cfg -- cfg' )
     dup [ insert-save-context ] each-basic-block ;

basis/compiler/cfg/utilities/utilities.factor

@@ -32,13 +32,13 @@ SYMBOL: visited
     H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
 
 :: update-predecessors ( from to bb -- )
-    ! Update 'to' predecessors for insertion of 'bb' between
+    ! Whenever 'from' appears in the list of predecessors of 'to'
-    ! 'from' and 'to'.
+    ! replace it with 'bb'.
     to predecessors>> [ dup from eq? [ drop bb ] when ] map! drop ;
 
 :: update-successors ( from to bb -- )
-    ! Update 'from' successors for insertion of 'bb' between
+    ! Whenever 'to' appears in the list of successors of 'from'
-    ! 'from' and 'to'.
+    ! replace it with 'bb'.
     from successors>> [ dup to eq? [ drop bb ] when ] map! drop ;
 
 :: insert-basic-block ( from to insns -- )

basis/compiler/codegen/codegen.factor

@@ -254,7 +254,6 @@ CODEGEN: ##compare-integer-imm %compare-integer-imm
 CODEGEN: ##compare-float-ordered %compare-float-ordered
 CODEGEN: ##compare-float-unordered %compare-float-unordered
 CODEGEN: ##save-context %save-context
-CODEGEN: ##restore-context %restore-context
 CODEGEN: ##vm-field %vm-field
 CODEGEN: ##set-vm-field %set-vm-field
 CODEGEN: ##alien-global %alien-global
@@ -304,4 +303,5 @@ CODEGEN: ##begin-callback %begin-callback
 CODEGEN: ##alien-callback %alien-callback
 CODEGEN: ##end-callback %end-callback
 
-M: ##alien-assembly generate-insn quot>> call( -- ) ;
+M: ##alien-assembly generate-insn
+    [ gc-map>> gc-map set ] [ quot>> call( -- ) ] bi ;

basis/cpu/architecture/architecture.factor

@@ -602,8 +602,6 @@ HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- )
 
 HOOK: %allot-byte-array cpu ( dst size gc-map -- )
 
-HOOK: %restore-context cpu ( temp1 temp2 -- )
-
 HOOK: %save-context cpu ( temp1 temp2 -- )
 
 HOOK: %prepare-var-args cpu ( -- )

basis/cpu/x86/32/bootstrap.factor

@@ -25,6 +25,7 @@ IN: bootstrap.x86
 : nv-reg ( -- reg ) ESI ;
 : ds-reg ( -- reg ) ESI ;
 : rs-reg ( -- reg ) EDI ;
+: link-reg ( -- reg ) EBX ;
 : fixnum>slot@ ( -- ) temp0 2 SAR ;
 : rex-length ( -- n ) 0 ;
 
@@ -90,15 +91,9 @@ IN: bootstrap.x86
     ESP 4 [+] EAX MOV
     "begin_callback" jit-call
 
-    jit-load-vm
-    jit-load-context
-    jit-restore-context
-
     jit-call-quot
 
     jit-load-vm
-    jit-save-context
-
     ESP [] vm-reg MOV
     "end_callback" jit-call
 ] \ c-to-factor define-sub-primitive

basis/cpu/x86/64/bootstrap.factor

@@ -20,6 +20,7 @@ IN: bootstrap.x86
 : nv-reg ( -- reg ) RBX ;
 : stack-reg ( -- reg ) RSP ;
 : frame-reg ( -- reg ) RBP ;
+: link-reg ( -- reg ) R11 ;
 : ctx-reg ( -- reg ) R12 ;
 : vm-reg ( -- reg ) R13 ;
 : ds-reg ( -- reg ) R14 ;
@@ -84,15 +85,10 @@ IN: bootstrap.x86
     arg1 vm-reg MOV
     "begin_callback" jit-call
 
-    jit-load-context
-    jit-restore-context
-
     ! call the quotation
     arg1 return-reg MOV
     jit-call-quot
 
-    jit-save-context
-
     arg1 vm-reg MOV
     "end_callback" jit-call
 ] \ c-to-factor define-sub-primitive

basis/cpu/x86/bootstrap.factor

@@ -38,15 +38,17 @@ big-endian off
     ! Save C callstack pointer
     nv-reg context-callstack-save-offset [+] stack-reg MOV
 
-    ! Load Factor callstack pointer
+    ! Load Factor stack pointers
     stack-reg nv-reg context-callstack-bottom-offset [+] MOV
-
     nv-reg jit-update-tib
     jit-install-seh
 
+    rs-reg nv-reg context-retainstack-offset [+] MOV
+    ds-reg nv-reg context-datastack-offset [+] MOV
+
     ! Call into Factor code
-    nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
+    link-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
-    nv-reg CALL
+    link-reg CALL
 
     ! Load VM into vm-reg; only needed on x86-32, but doesn't
     ! hurt on x86-64

basis/cpu/x86/x86.factor

@@ -614,14 +614,6 @@ M: x86 %alien-indirect ( src gc-map -- )
 
 M: x86 %loop-entry 16 alignment [ NOP ] times ;
 
-M:: x86 %restore-context ( temp1 temp2 -- )
-    #! Load Factor stack pointers on entry from C to Factor.
-    temp1 %context
-    temp2 stack-reg cell neg [+] LEA
-    temp1 "callstack-top" context-field-offset [+] temp2 MOV
-    ds-reg temp1 "datastack" context-field-offset [+] MOV
-    rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
-
 M:: x86 %save-context ( temp1 temp2 -- )
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace