From 640759ffed177920d10974222b1900a23f88fbc2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bj=C3=B6rn=20Lindqvist?= <bjourne@gmail.com>
Date: Thu, 1 Jan 2015 11:12:58 +0100
Subject: [PATCH] compiler.cfg.*: new step in finalization: clear-uninitialized

this step is supposed to analyze the cfg, find where there are peeks
that can cause stack underflow, and insert replace-imm instructions so
that there are no uninitialized stack locations if they do. could fix #1187
---
 .../cfg/finalization/finalization.factor      |   6 +-
 .../cfg/stacks/clearing/clearing-tests.factor |  21 ++
 .../cfg/stacks/clearing/clearing.factor       |  25 ++
 .../cfg/stacks/vacant/vacant-docs.factor      |   4 +-
 .../cfg/stacks/vacant/vacant-tests.factor     | 268 +++++-------------
 .../compiler/cfg/stacks/vacant/vacant.factor  |  73 +----
 6 files changed, 135 insertions(+), 262 deletions(-)
 create mode 100644 basis/compiler/cfg/stacks/clearing/clearing-tests.factor
 create mode 100644 basis/compiler/cfg/stacks/clearing/clearing.factor

diff --git a/basis/compiler/cfg/finalization/finalization.factor b/basis/compiler/cfg/finalization/finalization.factor
index 3c1fab30af..785cb68108 100644
--- a/basis/compiler/cfg/finalization/finalization.factor
+++ b/basis/compiler/cfg/finalization/finalization.factor
@@ -3,7 +3,8 @@
 USING: compiler.cfg.build-stack-frame compiler.cfg.gc-checks
 compiler.cfg.linear-scan compiler.cfg.representations
 compiler.cfg.save-contexts compiler.cfg.ssa.destruction
-compiler.cfg.stacks.vacant compiler.cfg.utilities compiler.cfg.write-barrier ;
+compiler.cfg.stacks.clearing compiler.cfg.stacks.vacant compiler.cfg.utilities
+compiler.cfg.write-barrier ;
 IN: compiler.cfg.finalization
 
 : finalize-cfg ( cfg -- )
@@ -11,7 +12,8 @@ IN: compiler.cfg.finalization
         select-representations
         insert-gc-checks
         eliminate-write-barriers
-        compute-vacant-sets
+        clear-uninitialized
+        fill-gc-maps
         insert-save-contexts
         destruct-ssa
         linear-scan
diff --git a/basis/compiler/cfg/stacks/clearing/clearing-tests.factor b/basis/compiler/cfg/stacks/clearing/clearing-tests.factor
new file mode 100644
index 0000000000..a9ced5608f
--- /dev/null
+++ b/basis/compiler/cfg/stacks/clearing/clearing-tests.factor
@@ -0,0 +1,21 @@
+USING: compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.stacks.clearing tools.test ;
+IN: compiler.cfg.stacks.clearing.tests
+
+{ { } } [
+    { { 0 { } } { 0 { } } } state>replaces
+] unit-test
+
+{ t f } [
+    { { 0 { } } { 0 { } } } T{ ##peek { loc D 0 } } dangerous-insn?
+    { { 0 { } } { 0 { } } } T{ ##peek { loc D -1 } } dangerous-insn?
+] unit-test
+
+{
+    {
+        T{ ##replace-imm { src 17 } { loc D 0 } }
+        T{ ##replace-imm { src 17 } { loc D 1 } }
+    }
+} [
+    { { 2 { } } { 0 { } } } state>replaces
+] unit-test
diff --git a/basis/compiler/cfg/stacks/clearing/clearing.factor b/basis/compiler/cfg/stacks/clearing/clearing.factor
new file mode 100644
index 0000000000..93854902ae
--- /dev/null
+++ b/basis/compiler/cfg/stacks/clearing/clearing.factor
@@ -0,0 +1,25 @@
+USING: accessors arrays assocs combinators.short-circuit
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
+compiler.cfg.stacks.map kernel math sequences ;
+IN: compiler.cfg.stacks.clearing
+
+: state>replaces ( state -- replaces )
+    state>vacancies first2
+    [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi* append
+    [ 17 swap f ##replace-imm boa ] map ;
+
+: dangerous-insn? ( state insn -- ? )
+    { [ nip ##peek? ] [ dangerous-peek? ] } 2&& ;
+
+: clearing-replaces ( assoc insn -- insns' )
+    [ of ] keep 2dup dangerous-insn? [
+        drop state>replaces
+    ] [ 2drop { } ] if ;
+
+: visit-insns ( assoc insns -- insns' )
+    [ [ clearing-replaces ] keep suffix ] with map V{ } concat-as ;
+
+: clear-uninitialized ( cfg -- )
+    [ trace-stack-state ] keep [
+        [ visit-insns ] change-instructions drop
+    ] with each-basic-block ;
diff --git a/basis/compiler/cfg/stacks/vacant/vacant-docs.factor b/basis/compiler/cfg/stacks/vacant/vacant-docs.factor
index 1bab1d594a..fefe1d0d8e 100644
--- a/basis/compiler/cfg/stacks/vacant/vacant-docs.factor
+++ b/basis/compiler/cfg/stacks/vacant/vacant-docs.factor
@@ -12,8 +12,8 @@ ARTICLE: "compiler.cfg.stacks.vacant" "Uninitialized/overinitialized stack locat
 }
 "The GC check runs before stack locations 0 and 1 have been initialized, and so the GC needs to scrub them so that they don't get traced. This is achieved by computing uninitialized locations with a dataflow analysis, and recording the information in GC maps. The call_frame_slot_visitor object in vm/slot_visitor.hpp reads this information from GC maps and performs the scrubbing." ;
 
-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: 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>bits
 { $values
diff --git a/basis/compiler/cfg/stacks/vacant/vacant-tests.factor b/basis/compiler/cfg/stacks/vacant/vacant-tests.factor
index 0e4d0e4316..60b3bb06f1 100644
--- a/basis/compiler/cfg/stacks/vacant/vacant-tests.factor
+++ b/basis/compiler/cfg/stacks/vacant/vacant-tests.factor
@@ -5,59 +5,10 @@ compiler.cfg.utilities compiler.cfg.stacks.vacant kernel math sequences sorting
 tools.test vectors ;
 IN: compiler.cfg.stacks.vacant.tests
 
-! Utils
-: output-stack-map ( cfg -- map )
-    vacant-analysis run-dataflow-analysis
-    nip [ [ number>> ] dip ] assoc-map >alist natural-sort last second ;
-
-! Initially both the d and r stacks are empty.
 {
-    { { 0 { } } { 0 { } } }
-} [ V{ } insns>cfg output-stack-map ] unit-test
-
-! Raise d stack.
-{
-    { { 1 { } } { 0 { } } }
-} [ V{ T{ ##inc-d f 1 } } insns>cfg output-stack-map ] unit-test
-
-! Raise r stack.
-{
-    { { 0 { } } { 1 { } } }
-} [ V{ T{ ##inc-r f 1 } } insns>cfg output-stack-map ] unit-test
-
-! Uninitialized peeks
-[
-    V{
-        T{ ##inc-d f 1 }
-        T{ ##peek { dst 0 } { loc D 0 } }
-    } insns>cfg
-    compute-vacant-sets
-] [ vacant-peek? ] must-fail-with
-
-[
-    V{
-        T{ ##inc-r f 1 }
-        T{ ##peek { dst 0 } { loc R 0 } }
-    } insns>cfg
-    compute-vacant-sets
-] [ vacant-peek? ] must-fail-with
-
-
-! Here the peek refers to a parameter of the word.
-[ ] [
-    V{
-        T{ ##peek { dst 0 } { loc D 0 } }
-    } insns>cfg
-    compute-vacant-sets
-] unit-test
-
-! Replace -1 then peek is ok.
-[ ] [
-    V{
-        T{ ##replace { src 10 } { loc D -1 } }
-        T{ ##peek { dst 0 } { loc D -1 } }
-    } insns>cfg
-    compute-vacant-sets
+    { { { } { 0 0 0 } } { { } { 0 } } }
+} [
+    { { 4 { 3 2 1 -3 0 -2 -1 } } { 0 { -1 } } } state>gc-data
 ] unit-test
 
 ! Replace -1, then gc. Peek is ok here because the -1 should be
@@ -68,164 +19,99 @@ IN: compiler.cfg.stacks.vacant.tests
         T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
         T{ ##peek { dst 0 } { loc D -1 } }
     }
-    [ insns>cfg compute-vacant-sets ]
+    [ insns>cfg fill-in-gc-maps ]
     [ second gc-map>> check-d>> ] bi
 ] unit-test
 
-! Should be ok because the value was at 0 when the gc ran.
-{ { -1 { -1 } } } [
-    V{
-        T{ ##replace { src 10 } { loc D 0 } }
-        T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
-        T{ ##inc-d f -1 }
-        T{ ##peek { dst 0 } { loc D -1 } }
-    } insns>cfg output-stack-map first
-] unit-test
+! ! Replace -1, then gc. Peek is ok here because the -1 should be
+! ! checked.
+! { { 0 } } [
+!     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 } }
+!     }
+!     [ insns>cfg compute-vacant-sets ]
+!     [ second gc-map>> check-d>> ] bi
+! ] 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 } }
-    } insns>cfg
-    compute-vacant-sets
-] [ vacant-peek? ] must-fail-with
+! ! 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 } }
+!     } insns>cfg
+!     compute-vacant-sets
+! ] [ vacant-peek? ] must-fail-with
 
 ! visit-insn should set the gc info.
 { { 0 0 } { } } [
     { { 2 { } } { 0 { } } }
     T{ ##alien-invoke { gc-map T{ gc-map } } }
-    [ visit-insn drop ] keep gc-map>> [ scrub-d>> ] [ scrub-r>> ] bi
+    [ gc-map>> set-gc-map ] keep gc-map>> [ scrub-d>> ] [ scrub-r>> ] bi
 ] unit-test
 
-{
-    { { 0 { } } { 0 { } } }
-} [
-    V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } }
-    insns>cfg output-stack-map
-] unit-test
 
-{
-    { { 0 { 0 1 2 } } { 0 { } } }
-} [
-    V{
-        T{ ##replace { src 10 } { loc D 0 } }
-        T{ ##replace { src 10 } { loc D 1 } }
-        T{ ##replace { src 10 } { loc D 2 } }
-    } insns>cfg output-stack-map
-] unit-test
+! ! read-ok?
+! { t } [
+!     0 { 0 { 0 1 2 } } read-ok?
+! ] unit-test
 
-{
-    { { 1 { 1 0 } } { 0 { } } }
-} [
-    V{
-        T{ ##replace { src 10 } { loc D 0 } }
-        T{ ##inc-d f 1 }
-        T{ ##replace { src 10 } { loc D 0 } }
-    } insns>cfg output-stack-map
-] unit-test
+! { f } [
+!     2 { 3 { } } read-ok?
+! ] unit-test
 
-{
-    { 0 { 0 -1 } }
-} [
-    V{
-        T{ ##replace { src 10 } { loc D 0 } }
-        T{ ##inc-d f 1 }
-        T{ ##replace { src 10 } { loc D 0 } }
-        T{ ##inc-d f -1 }
-    } insns>cfg output-stack-map first
-] unit-test
+! { f } [
+!     -1 { 3 { } } read-ok?
+! ] unit-test
 
-{
-    { 0 { -1 } }
-} [
-    V{
-        T{ ##inc-d f 1 }
-        T{ ##replace { src 10 } { loc D 0 } }
-        T{ ##inc-d f -1 }
-    } insns>cfg output-stack-map first
-] unit-test
+! ! { f } [
+! !     4 { 3 { } } read-ok?
+! ! ] unit-test
 
-{
-    { { { } { 0 0 0 } } { { } { 0 } } }
-} [
-    { { 4 { 3 2 1 -3 0 -2 -1 } } { 0 { -1 } } } state>gc-data
-] unit-test
+! { t } [
+!     4 { 0 { } } read-ok?
+! ] unit-test
 
-! ##call clears the overinitialized slots.
-{
-    { -1 { } }
-} [
-    V{
-        T{ ##replace { src 10 } { loc D 0 } }
-        T{ ##inc-d f -1 }
-        T{ ##call }
-    } insns>cfg output-stack-map first
-] unit-test
+! { t } [
+!     4 { 1 { 0 } } read-ok?
+! ] unit-test
 
-: cfg1 ( -- cfg )
-    V{
-        T{ ##inc-d f 1 }
-        T{ ##replace { src 10 } { loc D 0 } }
-    } 0 insns>block
-    V{
-        T{ ##peek { dst 37 } { loc D 0 } }
-        T{ ##inc-d f -1 }
-    } 1 insns>block
-    1vector >>successors block>cfg ;
+! ! Uninitialized peeks
+! [
+!     V{
+!         T{ ##inc-d f 1 }
+!         T{ ##peek { dst 0 } { loc D 0 } }
+!     } insns>cfg
+!     compute-vacant-sets
+! ] [ vacant-peek? ] must-fail-with
 
-{ { 0 { -1 } } } [ cfg1 output-stack-map first ] unit-test
+! [
+!     V{
+!         T{ ##inc-r f 1 }
+!         T{ ##peek { dst 0 } { loc R 0 } }
+!     } insns>cfg
+!     compute-vacant-sets
+! ] [ vacant-peek? ] must-fail-with
 
-! Same cfg structure as the bug1021:run-test word but with
-! non-datastack instructions mostly omitted.
-: bug1021-cfg ( -- cfg )
-    {
-        { 0 V{ T{ ##safepoint } T{ ##prologue } T{ ##branch } } }
-        {
-            1 V{
-                T{ ##inc-d f 2 }
-                T{ ##replace { src 0 } { loc D 1 } }
-                T{ ##replace { src 0 } { loc D 0 } }
-            }
-        }
-        {
-            2 V{
-                T{ ##call { word <array> } }
-            }
-        }
-        {
-            3 V{
-                T{ ##inc-d f 2 }
-                T{ ##peek { dst 0 } { loc D 2 } }
-                T{ ##peek { dst 0 } { loc D 3 } }
-                T{ ##replace { src 0 } { loc D 2 } }
-                T{ ##replace { src 0 } { loc D 3 } }
-                T{ ##replace { src 0 } { loc D 1 } }
-            }
-        }
-        {
-            8 V{
-                T{ ##inc-d f 3 }
-                T{ ##peek { dst 0 } { loc D 5 } }
-                T{ ##replace { src 0 } { loc D 0 } }
-                T{ ##replace { src 0 } { loc D 3 } }
-                T{ ##peek { dst 0 } { loc D 4 } }
-                T{ ##replace { src 0 } { loc D 1 } }
-                T{ ##replace { src 0 } { loc D 2 } }
-            }
-        }
-        {
-            10 V{
+! ! Here again the peek refers to a parameter word, but there are
+! ! uninitialized stack locations. That probably isn't ok.
+! [
+!     V{
+!         T{ ##inc-d f 3 }
+!         T{ ##peek { dst 0 } { loc D 3 } }
+!     } insns>cfg
+!     compute-vacant-sets
+! ] [ vacant-peek? ] must-fail-with
 
-                T{ ##inc-d f -3 }
-                T{ ##peek { dst 0 } { loc D -3 } }
-                T{ ##alien-invoke { gc-map T{ gc-map { scrub-d { } } } } }
-            }
-        }
-    } [ over insns>block ] assoc-map dup
-    { { 0 1 } { 1 2 } { 2 3 } { 3 8 } { 8 10 } } make-edges 0 of block>cfg ;
 
-{ { 4 { 3 2 1 -3 0 -2 -1 } } } [
-    bug1021-cfg output-stack-map first
-] 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 } }
+! !     } insns>cfg
+! !     compute-map-sets
+! ! ] [ vacant-peek? ] must-fail-with
diff --git a/basis/compiler/cfg/stacks/vacant/vacant.factor b/basis/compiler/cfg/stacks/vacant/vacant.factor
index 7b6efb157f..002bbef51f 100644
--- a/basis/compiler/cfg/stacks/vacant/vacant.factor
+++ b/basis/compiler/cfg/stacks/vacant/vacant.factor
@@ -1,25 +1,11 @@
-USING: accessors arrays compiler.cfg.dataflow-analysis
-compiler.cfg.instructions compiler.cfg.registers fry kernel math
-math.order sequences sets ;
+USING: accessors arrays assocs compiler.cfg.instructions
+compiler.cfg.stacks.map fry kernel math sequences ;
 IN: compiler.cfg.stacks.vacant
 
-! Utils
+! ! 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 ;
-
-: adjust-stack ( n stack -- stack' )
-    first2 pick '[ _ + ] map [ + ] dip 2array ;
-
-: read-ok? ( n stack -- ? )
-    [ first >= ] [ second in? ] 2bi or ;
-
-: stack>vacant ( stack -- seq )
-    first2 [ 0 max iota ] dip diff ;
-
 : vacant>bits ( vacant --  bits )
     [ { } ] [
         dup supremum 1 + 1 <array>
@@ -40,57 +26,10 @@ IN: compiler.cfg.stacks.vacant
 : state>gc-data ( state -- gc-data )
     [ stack>scrub-and-check ] map ;
 
-CONSTANT: initial-state { { 0 { } } { 0 { } } }
-
-: insn>location ( insn -- n ds? )
-    loc>> [ n>> ] [ ds-loc? ] bi ;
-
-: visit-replace ( state insn -- state' )
-    [ first2 ] dip insn>location
-    [ rot register-write swap ] [ swap register-write ] if 2array ;
-
-ERROR: vacant-peek insn ;
-
-: peek-loc-ok? ( state insn -- ? )
-    insn>location 0 1 ? rot nth read-ok? ;
-
-GENERIC: visit-insn ( state insn -- state' )
-
-M: ##inc-d visit-insn ( state insn -- state' )
-    n>> swap first2 [ adjust-stack ] dip 2array ;
-
-M: ##inc-r visit-insn ( state insn -- state' )
-    n>> swap first2 swapd adjust-stack 2array ;
-
-M: ##replace-imm visit-insn visit-replace ;
-M: ##replace visit-insn visit-replace ;
-
-M: ##peek visit-insn ( state insn -- state' )
-    2dup peek-loc-ok? [ drop ] [ vacant-peek ] if ;
-
-M: ##call visit-insn ( state insn -- state' )
-    ! After a word call, we can't trust any overinitialized locations
-    ! to contain valid pointers anymore.
-    drop [ first2 [ 0 >= ] filter 2array ] map ;
-
 : 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 gc-map>> set-gc-map ;
-
-M: insn visit-insn ( state insn -- state' )
-    drop ;
-
-FORWARD-ANALYSIS: vacant
-
-M: vacant-analysis transfer-set ( in-set bb dfa -- out-set )
-    drop instructions>> swap [ visit-insn ] reduce ;
-
-M: vacant-analysis ignore-block? ( bb dfa -- ? )
-    2drop f ;
-
-! Picking the first means that a block will only be analyzed once.
-M: vacant-analysis join-sets ( sets bb dfa -- set )
-    2drop [ initial-state ] [ first ] if-empty ;
+: fill-gc-maps ( cfg -- )
+    trace-stack-state [ drop gc-map-insn? ] assoc-filter
+    [ swap gc-map>> set-gc-map ] assoc-each ;