compiler.cfg: Get inline GC checks working again, using a dataflow analysis to compute uninitialized stack locations in compiler.cfg.stacks.uninitialized. Re-enable intrinsics which use inline allocation

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

@@ -0,0 +1,26 @@
+IN: compiler.cfg.gc-checks.tests
+USING: compiler.cfg.gc-checks compiler.cfg.debugger
+compiler.cfg.registers compiler.cfg.instructions compiler.cfg
+compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
+namespaces accessors sequences ;
+
+: test-gc-checks ( -- )
+    cfg new 0 get >>entry
+    compute-predecessors
+    insert-gc-checks
+    drop ;
+
+V{
+    T{ ##inc-d f 3 }
+    T{ ##replace f V int-regs 0 D 1 }
+} 0 test-bb
+
+V{
+    T{ ##box-float f V int-regs 0 V int-regs 1 }
+} 1 test-bb
+
+0 get 1 get 1vector >>successors drop
+
+[ ] [ test-gc-checks ] unit-test
+
+[ V{ D 0 D 2 } ] [ 1 get instructions>> first uninitialized-locs>> ] unit-test

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

@@ -1,17 +1,27 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences assocs
-compiler.cfg.rpo compiler.cfg.instructions
-compiler.cfg.hats ;
+USING: accessors kernel sequences assocs fry
+compiler.cfg.rpo
+compiler.cfg.hats
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.stacks.uninitialized ;
 IN: compiler.cfg.gc-checks
 
-: gc? ( bb -- ? )
+: insert-gc-check? ( bb -- ? )
     instructions>> [ ##allocation? ] any? ;
 
-: insert-gc-check ( basic-block -- )
-    dup gc? [
-        [ i i f \ ##gc new-insn prefix ] change-instructions drop
-    ] [ drop ] if ;
+: blocks-with-gc ( cfg -- bbs )
+    post-order [ insert-gc-check? ] filter ;
+
+: insert-gc-check ( bb -- )
+    dup '[
+        i i f _ uninitialized-locs \ ##gc new-insn
+        prefix
+    ] change-instructions drop ;
 
 : insert-gc-checks ( cfg -- cfg' )
-    dup [ insert-gc-check ] each-basic-block ;
+    dup blocks-with-gc [
+        over compute-uninitialized-sets
+        [ insert-gc-check ] each
+    ] unless-empty ;

basis/compiler/cfg/instructions/instructions.factor

@@ -190,7 +190,7 @@ INSN: ##fixnum-add < ##fixnum-overflow ;
 INSN: ##fixnum-sub < ##fixnum-overflow ;
 INSN: ##fixnum-mul < ##fixnum-overflow ;
 
-INSN: ##gc temp1 temp2 live-values ;
+INSN: ##gc temp1 temp2 live-values uninitialized-locs ;
 
 ! Instructions used by machine IR only.
 INSN: _prologue stack-frame ;
@@ -219,7 +219,7 @@ INSN: _fixnum-mul < _fixnum-overflow ;
 
 TUPLE: spill-slot n ; C: <spill-slot> spill-slot
 
-INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size ;
+INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size uninitialized-locs ;
 
 ! These instructions operate on machine registers and not
 ! virtual registers

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics
     slots.private:set-slot
     strings.private:string-nth
     strings.private:set-string-nth-fast
-    ! classes.tuple.private:<tuple-boa>
-    ! arrays:<array>
-    ! byte-arrays:<byte-array>
-    ! byte-arrays:(byte-array)
-    ! kernel:<wrapper>
+    classes.tuple.private:<tuple-boa>
+    arrays:<array>
+    byte-arrays:<byte-array>
+    byte-arrays:(byte-array)
+    kernel:<wrapper>
     alien.accessors:alien-unsigned-1
     alien.accessors:set-alien-unsigned-1
     alien.accessors:alien-signed-1
@@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics
     alien.accessors:set-alien-unsigned-2
     alien.accessors:alien-signed-2
     alien.accessors:set-alien-signed-2
-    ! alien.accessors:alien-cell
+    alien.accessors:alien-cell
     alien.accessors:set-alien-cell
 } [ t "intrinsic" set-word-prop ] each
 
@@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics
         alien.accessors:set-alien-float
         alien.accessors:alien-double
         alien.accessors:set-alien-double
-    } drop f [ t "intrinsic" set-word-prop ] each ;
+    } [ t "intrinsic" set-word-prop ] each ;
 
 : enable-fixnum-log2 ( -- )
     \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;

basis/compiler/cfg/linearization/linearization.factor

@@ -98,15 +98,18 @@ M: ##dispatch linearize-insn
 
 M: ##gc linearize-insn
     nip
-    [ temp1>> ]
-    [ temp2>> ]
-    [
-        live-values>>
-        [ compute-gc-roots ]
-        [ count-gc-roots ]
-        [ gc-roots-size ]
-        tri
-    ] tri
+    {
+        [ temp1>> ]
+        [ temp2>> ]
+        [
+            live-values>>
+            [ compute-gc-roots ]
+            [ count-gc-roots ]
+            [ gc-roots-size ]
+            tri
+        ]
+        [ uninitialized-locs>> ]
+    } cleave
     _gc ;
 
 : linearize-basic-blocks ( cfg -- insns )

basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor

@@ -0,0 +1,61 @@
+IN: compiler.cfg.stacks.uninitialized.tests
+USING: compiler.cfg.stacks.uninitialized compiler.cfg.debugger
+compiler.cfg.registers compiler.cfg.instructions compiler.cfg
+compiler.cfg.predecessors cpu.architecture tools.test kernel vectors
+namespaces accessors sequences ;
+
+: test-uninitialized ( -- )
+    cfg new 0 get >>entry
+    compute-predecessors
+    compute-uninitialized-sets ;
+
+V{
+    T{ ##inc-d f 3 }
+} 0 test-bb
+
+V{
+    T{ ##replace f V int-regs 0 D 0 }
+    T{ ##replace f V int-regs 0 D 1 }
+    T{ ##replace f V int-regs 0 D 2 }
+    T{ ##inc-r f 1 }
+} 1 test-bb
+
+V{
+    T{ ##peek f V int-regs 0 D 0 }
+    T{ ##inc-d f 1 }
+} 2 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 1vector >>successors drop
+
+[ ] [ test-uninitialized ] unit-test
+
+[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test
+[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test
+
+! When merging, if a location is uninitialized in one branch and
+! initialized in another, we have to consider it uninitialized,
+! since it cannot be safely read from by a ##peek, or traced by GC.
+
+V{ } 0 test-bb
+
+V{
+    T{ ##inc-d f 1 }
+} 1 test-bb
+
+V{
+    T{ ##call f namestack }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##return }
+} 3 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+1 get 3 get 1vector >>successors drop
+2 get 3 get 1vector >>successors drop
+
+[ ] [ test-uninitialized ] unit-test
+
+[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test

basis/compiler/cfg/stacks/uninitialized/uninitialized.factor

@@ -0,0 +1,76 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences byte-arrays namespaces accessors classes math
+math.order fry arrays combinators compiler.cfg.registers
+compiler.cfg.instructions compiler.cfg.dataflow-analysis ;
+IN: compiler.cfg.stacks.uninitialized
+
+! Uninitialized stack location analysis.
+
+! Consider the following sequence of instructions:
+! ##inc-d 2
+! _gc
+! ##replace ... D 0
+! ##replace ... D 1
+! The GC check runs before stack locations 0 and 1 have been initialized,
+! and it needs to zero them out so that GC doesn't try to trace them.
+
+<PRIVATE
+
+GENERIC: visit-insn ( insn -- )
+
+: handle-inc ( n symbol -- )
+    [
+        swap {
+            { [ dup 0 < ] [ neg short tail ] }
+            { [ dup 0 > ] [ <byte-array> prepend ] }
+        } cond
+    ] change ;
+
+M: ##inc-d visit-insn n>> ds-loc handle-inc ;
+
+M: ##inc-r visit-insn n>> rs-loc handle-inc ;
+
+ERROR: uninitialized-peek insn ;
+
+M: ##peek visit-insn
+    dup loc>> [ n>> ] [ class get ] bi ?nth 0 =
+    [ uninitialized-peek ] [ drop ] if ;
+
+M: ##replace visit-insn
+    loc>> [ n>> ] [ class get ] bi
+    2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ;
+
+M: insn visit-insn drop ;
+
+: prepare ( pair -- )
+    [ first2 [ [ clone ] [ B{ } ] if* ] bi@ ] [ B{ } B{ } ] if*
+    [ ds-loc set ] [ rs-loc set ] bi* ;
+
+: visit-block ( bb -- ) instructions>> [ visit-insn ] each ;
+
+: finish ( -- pair ) ds-loc get rs-loc get 2array ;
+
+: (join-sets) ( seq1 seq2 -- seq )
+    2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ min ] 2map ;
+
+: (uninitialized-locs) ( seq quot -- seq' )
+    [ dup length [ drop 0 = ] pusher [ 2each ] dip ] dip map ; inline
+
+PRIVATE>
+
+FORWARD-ANALYSIS: uninitialized
+
+M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
+    drop [ prepare ] dip visit-block finish ;
+
+M: uninitialized-analysis join-sets ( sets analysis -- pair )
+    drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
+
+: uninitialized-locs ( bb -- locs )
+    uninitialized-in dup [
+        first2
+        [ [ <ds-loc> ] (uninitialized-locs) ]
+        [ [ <rs-loc> ] (uninitialized-locs) ]
+        bi* append
+    ] when ;

basis/compiler/codegen/codegen.factor

@@ -221,6 +221,7 @@ M: _gc generate-insn
         [ temp2>> ]
         [ gc-roots>> ]
         [ gc-root-count>> ]
+        [ uninitialized-locs>> ]
     } cleave %gc ;
 
 M: _loop-entry generate-insn drop %loop-entry ;

basis/cpu/architecture/architecture.factor

@@ -128,7 +128,7 @@ HOOK: %alien-global cpu ( dst symbol library -- )
 
 HOOK: %allot cpu ( dst size class temp -- )
 HOOK: %write-barrier cpu ( src card# table -- )
-HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots -- )
+HOOK: %gc cpu ( temp1 temp2 live-registers live-spill-slots uninitialized-locs -- )
 
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )

basis/cpu/x86/x86.factor

@@ -466,6 +466,10 @@ M:: word load-gc-root ( gc-root register temp -- )
 : load-gc-roots ( gc-roots temp -- )
     '[ _ load-gc-root ] assoc-each ;
 
+: wipe-locs ( locs -- )
+    ! See explanation in compiler.cfg.stacks.uninitialized
+    [ 0 ] dip [ %replace ] with each ;
+
 :: call-gc ( gc-root-count -- )
     ! Pass pointer to start of GC roots as first parameter
     param-reg-1 gc-root-base param@ LEA
@@ -475,11 +479,12 @@ M:: word load-gc-root ( gc-root register temp -- )
     %prepare-alien-invoke
     "inline_gc" f %alien-invoke ;
 
-M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count -- )
+M:: x86 %gc ( temp1 temp2 gc-roots gc-root-count uninitialized-locs -- )
     "end" define-label
     temp1 temp2 check-nursery
     "end" get JLE
     gc-roots temp1 save-gc-roots
+    uninitialized-locs wipe-locs
     gc-root-count call-gc
     gc-roots temp1 load-gc-roots
     "end" resolve-label ;