compiler.cfg.instructions: added check-d and check-r slots to gc-map

the data is output from compiler.cfg.stacks.vacant in a reasonable
format but not yet used for code generation.

basis/compiler/cfg/instructions/instructions.factor

@@ -855,7 +855,7 @@ factor-call-insn ;
 M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;
 
 ! Each one has a gc-map slot
-TUPLE: gc-map scrub-d scrub-r gc-roots derived-roots ;
+TUPLE: gc-map scrub-d check-d scrub-r check-r gc-roots derived-roots ;
 
 : <gc-map> ( -- gc-map ) gc-map new ;
 

basis/compiler/cfg/stacks/vacant/vacant-docs.factor

@@ -15,12 +15,12 @@ ARTICLE: "compiler.cfg.stacks.vacant" "Uninitialized/overinitialized stack locat
 HELP: initial-state
 { $description "Initially the stack bottom is at 0 for both the data and retain stacks and no replaces have been registered." } ;
 
-HELP: vacant>bit-pattern
+HELP: vacant>bits
 { $values
   { "vacant" "sequence of uninitialized stack locations" }
-  { "bit-pattern" "sequence of 1:s and 0:s" }
+  { "bits" "sequence of 1:s and 0:s" }
 }
-{ $description "Converts a sequence of uninitialized stack locations to the pattern of 1:s and 0:s that can be put in the " { $slot "scrub-d" } " and " { $slot "scrub-r" } " slots of a " { $link gc-map } "." }
+{ $description "Converts a sequence of uninitialized stack locations to the pattern of 1:s and 0:s that can be put in the " { $slot "scrub-d" } " and " { $slot "scrub-r" } " slots of a " { $link gc-map } ". 0:s are uninitialized locations and 1:s are initialized." }
 { $examples
   { $example
     "USING: compiler.cfg.stacks.vacant prettyprint ;"
@@ -29,4 +29,11 @@ HELP: vacant>bit-pattern
   }
 } ;
 
+HELP: overinitialized>bits
+{ $values
+  { "overinitialized" "sequence of overinitialized stack locations" }
+  { "bits" "sequence of 1:s and 0:s" }
+}
+{ $description "Converts a sequence of overinitialized stack locations to the pattern of 1:s and 0:s that can be put in the " { $slot "check-d" } " and " { $slot "check-r" } " slots of a " { $link gc-map } ". 0:s are empty locations and 1:s are initialized. First element is stack location -1,second -2 and so on." } ;
+
 ABOUT: "compiler.cfg.stacks.vacant"

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

@@ -34,21 +34,21 @@ IN: compiler.cfg.stacks.vacant.tests
 } [ V{ T{ ##inc-r f 1 } } create-cfg output-stack-map ] unit-test
 
 ! Uninitialized peeks
-! [
-!     V{
-!         T{ ##inc-d f 1 }
-!         T{ ##peek { dst 0 } { loc D 0 } }
-!     } create-cfg
-!     compute-vacant-sets
-! ] [ vacant-peek? ] must-fail-with
+[
+    V{
+        T{ ##inc-d f 1 }
+        T{ ##peek { dst 0 } { loc D 0 } }
+    } create-cfg
+    compute-vacant-sets
+] [ vacant-peek? ] must-fail-with
 
-! [
-!     V{
-!         T{ ##inc-r f 1 }
-!         T{ ##peek { dst 0 } { loc R 0 } }
-!     } create-cfg
-!     compute-vacant-sets
-! ] [ vacant-peek? ] must-fail-with
+[
+    V{
+        T{ ##inc-r f 1 }
+        T{ ##peek { dst 0 } { loc R 0 } }
+    } create-cfg
+    compute-vacant-sets
+] [ vacant-peek? ] must-fail-with
 
 
 ! Here the peek refers to a parameter of the word.
@@ -68,15 +68,17 @@ IN: compiler.cfg.stacks.vacant.tests
     compute-vacant-sets
 ] unit-test
 
-! Replace -1, then gc, then peek is not ok.
-! [
-!     V{
-!         T{ ##replace { src 10 } { loc D -1 } }
-!         T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
-!         T{ ##peek { dst 0 } { loc D -1 } }
-!     } create-cfg
-!     compute-vacant-sets
-! ] [ vacant-peek? ] must-fail-with
+! Replace -1, then gc. Peek is ok here because the -1 should be
+! checked.
+{ { 1 } } [
+    V{
+        T{ ##replace { src 10 } { loc D -1 } }
+        T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
+        T{ ##peek { dst 0 } { loc D -1 } }
+    }
+    [ create-cfg compute-vacant-sets ]
+    [ second gc-map>> check-d>> ] bi
+] unit-test
 
 ! Should be ok because the value was at 0 when the gc ran.
 { { -1 { -1 } } } [
@@ -89,14 +91,14 @@ IN: compiler.cfg.stacks.vacant.tests
 ] unit-test
 
 ! Should not be ok because the value wasn't initialized when gc ran.
-! [
-!     V{
-!         T{ ##inc-d f 1 }
-!         T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
-!         T{ ##peek { dst 0 } { loc D 0 } }
-!     } create-cfg
-!     compute-vacant-sets
-! ] [ vacant-peek? ] must-fail-with
+[
+    V{
+        T{ ##inc-d f 1 }
+        T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
+        T{ ##peek { dst 0 } { loc D 0 } }
+    } create-cfg
+    compute-vacant-sets
+] [ vacant-peek? ] must-fail-with
 
 ! visit-insn should set the gc info.
 { { 0 0 } { } } [
@@ -105,7 +107,9 @@ IN: compiler.cfg.stacks.vacant.tests
     [ visit-insn drop ] keep gc-map>> [ scrub-d>> ] [ scrub-r>> ] bi
 ] unit-test
 
-{ { { 0 { } } { 0 { } } } } [
+{
+    { { 0 { } } { 0 { } } }
+} [
     V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } }
     create-cfg output-stack-map
 ] unit-test
@@ -141,8 +145,9 @@ IN: compiler.cfg.stacks.vacant.tests
     } create-cfg output-stack-map first
 ] unit-test
 
-{ { 0 { -1 } } }
-[
+{
+    { 0 { -1 } }
+} [
     V{
         T{ ##inc-d f 1 }
         T{ ##replace { src 10 } { loc D 0 } }
@@ -150,6 +155,12 @@ IN: compiler.cfg.stacks.vacant.tests
     } create-cfg output-stack-map first
 ] unit-test
 
+{
+    { { { } { 1 1 1 } } { { } { 1 } } }
+} [
+    { { 4 { 3 2 1 -3 0 -2 -1 } } { 0 { -1 } } } state>gc-data
+] unit-test
+
 : cfg1 ( -- cfg )
     V{
         T{ ##inc-d f 1 }
@@ -219,4 +230,6 @@ IN: compiler.cfg.stacks.vacant.tests
     } [ over create-block ] assoc-map dup
     { { 0 1 } { 1 2 } { 2 3 } { 3 8 } { 8 10 } } make-edges 0 of block>cfg ;
 
-{ { 4 { 3 2 1 0 } } } [ bug1021-cfg output-stack-map first ] unit-test
+{ { 4 { 3 2 1 -3 0 -2 -1 } } } [
+    bug1021-cfg output-stack-map first
+] unit-test

basis/compiler/cfg/stacks/vacant/vacant.factor

@@ -1,8 +1,12 @@
-USING: accessors arrays compiler.cfg.dataflow-analysis
+USING: accessors arrays assocs classes.tuple compiler.cfg.dataflow-analysis
 compiler.cfg.instructions compiler.cfg.registers fry kernel math math.order
 sequences sets ;
 IN: compiler.cfg.stacks.vacant
 
+! Utils
+: write-slots ( tuple values slots -- )
+    [ execute( x y -- z ) ] 2each drop ;
+
 ! Operations on the stack info
 : register-write ( n stack -- stack' )
     first2 rot suffix members 2array ;
@@ -13,28 +17,31 @@ IN: compiler.cfg.stacks.vacant
 : read-ok? ( n stack -- ? )
     [ first >= ] [ second in? ] 2bi or ;
 
-! After a gc, negative writes have been erased.
-: register-gc ( stack -- stack' )
-    first2 [ 0 >= ] filter 2array ;
-
 : stack>vacant ( stack -- seq )
     first2 [ 0 max iota ] dip diff ;
 
-: vacant>bit-pattern ( vacant --  bit-pattern )
+: vacant>bits ( vacant --  bits )
     [ { } ] [
         dup supremum 1 + 1 <array>
         [ '[ _ 0 -rot set-nth ] each ] keep
     ] if-empty ;
 
+: stack>overinitialized ( stack -- seq )
+    second [ 0 < ] filter ;
+
+: overinitialized>bits ( overinitialized -- bits )
+    [ neg 1 - ] map vacant>bits [ 1 = 0 1 ? ] map ;
+
+: stack>scrub-and-check ( stack -- pair )
+    [ stack>vacant vacant>bits ]
+    [ stack>overinitialized overinitialized>bits ] bi 2array ;
+
 ! Operations on the analysis state
-: state>gc-map ( state -- pair )
-    [ stack>vacant vacant>bit-pattern ] map ;
+: state>gc-data ( state -- gc-data )
+    [ stack>scrub-and-check ] map ;
 
 CONSTANT: initial-state { { 0 { } } { 0 { } } }
 
-: insn>gc-map ( insn -- pair )
-    gc-map>> [ scrub-d>> ] [ scrub-r>> ] bi 2array ;
-
 : insn>location ( insn -- n ds? )
     loc>> [ n>> ] [ ds-loc? ] bi ;
 
@@ -58,17 +65,15 @@ M: ##inc-r visit-insn ( state insn -- state' )
 M: ##replace-imm visit-insn visit-replace ;
 M: ##replace visit-insn visit-replace ;
 
-! Disabled for now until support is added for tracking overinitialized
-! stack locations.
 M: ##peek visit-insn ( state insn -- state' )
-    drop ;
-    ! 2dup peek-loc-ok? [ drop ] [ vacant-peek ] if ;
+    2dup peek-loc-ok? [ drop ] [ vacant-peek ] if ;
 
-: set-gc-map ( state insn -- )
-    gc-map>> swap state>gc-map first2 [ >>scrub-d ] [ >>scrub-r ] bi* drop ;
+: set-gc-map ( state gc-map -- )
+    swap state>gc-data concat
+    { >>scrub-d >>check-d >>scrub-r >>check-r } write-slots ;
 
 M: gc-map-insn visit-insn ( state insn -- state' )
-    dupd set-gc-map [ register-gc ] map ;
+    dupd gc-map>> set-gc-map ;
 
 M: insn visit-insn ( state insn -- state' )
     drop ;

basis/compiler/codegen/gc-maps/gc-maps-tests.factor

@@ -19,12 +19,16 @@ M: fake-cpu gc-root-offset ;
 
         50 <byte-array> %
 
-        T{ gc-map f B{ } B{ } V{ } } gc-map-here
+        <gc-map> gc-map-here
 
         50 <byte-array> %
 
-        T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } V{ { 2 4 } } } gc-map-here
-
+        T{ gc-map
+           { scrub-d { 0 1 1 1 0 } }
+           { scrub-r { 1 0 } }
+           { gc-roots V{ 1 3 } }
+           { derived-roots V{ { 2 4 } } }
+        } gc-map-here
         emit-gc-maps
     ] B{ } make
     "result" set