From c876d79b9d02db1536197651b408cc0183a3e61f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bj=C3=B6rn=20Lindqvist?= <bjourne@gmail.com>
Date: Thu, 16 Apr 2015 07:03:50 +0200
Subject: [PATCH] compiler.cfg.liveness: lots of more tests and some docs

---
 .../cfg/liveness/liveness-docs.factor         |  25 +++-
 .../cfg/liveness/liveness-tests.factor        | 121 +++++++++++++++++-
 basis/compiler/cfg/liveness/liveness.factor   |  30 ++---
 3 files changed, 144 insertions(+), 32 deletions(-)

diff --git a/basis/compiler/cfg/liveness/liveness-docs.factor b/basis/compiler/cfg/liveness/liveness-docs.factor
index 4318830b6a..7d1453f72c 100644
--- a/basis/compiler/cfg/liveness/liveness-docs.factor
+++ b/basis/compiler/cfg/liveness/liveness-docs.factor
@@ -1,9 +1,23 @@
-USING: assocs compiler.cfg compiler.cfg.instructions help.markup help.syntax ;
+USING: assocs compiler.cfg compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.representations help.markup help.syntax ;
 IN: compiler.cfg.liveness
 
+HELP: base-pointers
+{ $var-description "Mapping from vregs to base pointer vregs. If the vreg doesn't have a base pointer, then it will be mapped to " { $link f } "." }
+{ $see-also lookup-base-pointer } ;
+
 HELP: fill-gc-map
-{ $values { "live-set" "no idea" } { "insn" insn } }
-{ $description "Assigns values to the " { $slot "gc-roots" } " and " { $slot "derived-roots" } " slots of an instructions " { $link gc-map } "." } ;
+{ $values { "live-set" assoc } { "gc-map" gc-map } }
+{ $description "Assigns values to the " { $slot "gc-roots" } " and " { $slot "derived-roots" } " slots of the " { $link gc-map } ". Does nothing if the " { $link select-representations } " pass hasn't ran." } ;
+
+HELP: gen-uses
+{ $values { "live-set" assoc } { "insn" insn } }
+{ $description "Adds the vregs the instruction uses to the live set." }
+{ $see-also uses-vregs } ;
+
+HELP: kill-defs
+{ $values { "live-set" assoc } { "insn" insn } }
+{ $description "If liveness analysis is run after SSA destruction, we need to kill vregs that have been coalesced with others (they won't have been renamed from their original values in the CFG). Otherwise, we get a bunch of stray uses that wind up live-in/out when they shouldn't be.  However, we must take care to still report the original vregs in the live-sets, because they have information associated with them (like representations) that would get lost if we just used the leaders for everything." } ;
 
 HELP: live-in
 { $values { "bb" basic-block } { "set" assoc } }
@@ -13,6 +27,11 @@ HELP: live-in?
 { $values { "vreg" "virtual register" } { "bb" basic-block } { "?" "a boolean" } }
 { $description "Whether the vreg is live in the block or not." } ;
 
+HELP: lookup-base-pointer
+{ $values { "vreg" "vreg" } { "vreg/f" "vreg or " { $link f } } }
+{ $description "Tries to figure out what the base pointer for a vreg is. Can't use cache here because of infinite recursion inside the quotation passed to cache" }
+{ $see-also base-pointers } ;
+
 HELP: edge-live-ins
 { $var-description "Assoc mapping basic blocks to sequences of sets of vregs; each sequence is in correspondence with a predecessor." } ;
 
diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor
index 547985365b..efcb9251b3 100644
--- a/basis/compiler/cfg/liveness/liveness-tests.factor
+++ b/basis/compiler/cfg/liveness/liveness-tests.factor
@@ -1,18 +1,125 @@
-USING: compiler.cfg.liveness
+USING: accessors compiler.cfg.liveness
 compiler.cfg compiler.cfg.debugger compiler.cfg.instructions
-compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.utilities
-cpu.architecture accessors namespaces sequences kernel
-tools.test vectors alien math compiler.cfg.comparisons
-cpu.x86.assembler.operands assocs ;
+compiler.cfg.predecessors compiler.cfg.registers
+compiler.cfg.ssa.destruction.leaders compiler.cfg.utilities cpu.architecture
+namespaces sequences kernel tools.test vectors alien math
+compiler.cfg.comparisons cpu.x86.assembler.operands assocs ;
 IN: compiler.cfg.liveness.tests
 
-! visit-insn
+! compute-edge-live-in
+{ H{ } } [
+    { } 0 insns>block compute-edge-live-in
+] unit-test
+
 {
-    H{ }
+    H{
+        { "bl1" H{ { 7 7 } } }
+        { "bl2" H{ { 99 99 } } }
+    }
 } [
+    {
+        T{ ##phi
+           { dst 103 }
+           { inputs H{ { "bl1" 7 } { "bl2" 99 } } }
+        }
+    } 0 insns>block
+    compute-edge-live-in
+] unit-test
+
+{
+    H{
+        { "b-31" H{ { 192 192 } { 193 193 } { 194 194 } { 195 195 } } }
+        { "b-23" H{ { 181 181 } { 182 182 } { 183 183 } { 187 187 } } }
+        { "b-26" H{ { 188 188 } { 189 189 } { 190 190 } { 191 191 } } }
+    }
+} [
+    {
+        T{ ##phi
+           { dst 196 }
+           { inputs H{ { "b-26" 189 } { "b-23" 183 } { "b-31" 193 } } }
+        }
+        T{ ##phi
+           { dst 197 }
+           { inputs H{ { "b-26" 190 } { "b-23" 182 } { "b-31" 194 } } }
+        }
+        T{ ##phi
+           { dst 198 }
+           { inputs H{ { "b-26" 191 } { "b-23" 181 } { "b-31" 195 } } }
+        }
+        T{ ##phi
+           { dst 199 }
+           { inputs H{ { "b-26" 188 } { "b-23" 187 } { "b-31" 192 } } }
+        }
+    } 0 insns>block compute-edge-live-in
+] unit-test
+
+! fill-gc-map
+{ H{ } } [
+    f representations set
+    H{ } clone T{ gc-map } fill-gc-map
+] unit-test
+
+{
+    H{ { 48 48 } }
+    T{ gc-map { gc-roots { 48 } } { derived-roots V{ } } }
+} [
+    H{ { 48 tagged-rep } } representations set
+    H{ { 48 48  } } clone
+    T{ gc-map } [ fill-gc-map ] keep
+] unit-test
+
+! kill-defs
+{ H{ } } [
+    H{ } T{ ##peek f 37 D 0 0 } kill-defs
+] unit-test
+
+{ H{ { 3 3 } } } [
+    H{ { 37 99 } { 99 99 } { 2 99 } } leader-map set
+    H{ { 37 37 } { 3 3 } } T{ ##peek f 2 D 0 0 } kill-defs
+] unit-test
+
+{ t } [
+    H{ { 123 123 } } clone T{ ##peek f 7 D 0 } dupd kill-defs eq?
+] unit-test
+
+! lookup-base-pointer
+{ 84 } [
+    H{ { 84 84 } } clone base-pointers set 84 lookup-base-pointer
+] unit-test
+
+{ 15 } [
+    { T{ ##tagged>integer f 30 15 } } 0 insns>block block>cfg compute-live-sets
+    30 lookup-base-pointer
+] unit-test
+
+! lookup-base-pointer*
+{ f } [
+    456 T{ ##peek f 123 D 0 } lookup-base-pointer*
+] unit-test
+
+! visit-gc-root
+{ V{ } HS{ 48 } } [
+    H{ { 48 tagged-rep } } representations set
+    48 V{ } clone HS{ } clone [ visit-gc-root ] 2keep
+] unit-test
+
+! So the real root is 40?
+{ V{ { 48 40 } } HS{ 40 } } [
+    H{ { 48 40 } } base-pointers set
+    H{ { 48 int-rep } } representations set
+    48 V{ } clone HS{ } clone [ visit-gc-root ] 2keep
+] unit-test
+
+! visit-insn
+{ H{ } } [
     H{ } clone T{ ##peek f 0 D 0 } visit-insn
 ] unit-test
 
+{ H{ { 48 48 } { 37 37 } } } [
+    H{ { 48 tagged-rep } } representations set
+    H{ { 48 48  } } clone T{ ##replace f 37 D 1 6 } visit-insn
+] unit-test
+
 : test-liveness ( -- )
     1 get block>cfg compute-live-sets ;
 
diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor
index 093639fce1..ecb9c08164 100644
--- a/basis/compiler/cfg/liveness/liveness.factor
+++ b/basis/compiler/cfg/liveness/liveness.factor
@@ -28,25 +28,14 @@ SYMBOL: base-pointers
 
 GENERIC: visit-insn ( live-set insn -- live-set )
 
-! If liveness analysis is run after SSA destruction, we need to
-! kill vregs that have been coalesced with others (they won't
-! have been renamed from their original values in the CFG).
-! Otherwise, we get a bunch of stray uses that wind up
-! live-in/out when they shouldn't be.  However, we must take
-! care to still report the original vregs in the live-sets,
-! because they have information associated with them (like
-! representations) that would get lost if we just used the
-! leaders for everything.
-
 : kill-defs ( live-set insn -- live-set )
-    defs-vregs [
-        ?leader '[ drop ?leader _ eq? not ] assoc-filter!
-    ] each ; inline
+    defs-vregs [ ?leader ] map
+    '[ drop ?leader _ in? not ] assoc-filter! ; inline
 
 : gen-uses ( live-set insn -- live-set )
     uses-vregs [ over conjoin ] each ; inline
 
-M: vreg-insn visit-insn
+M: vreg-insn visit-insn ( live-set insn -- live-set )
     [ kill-defs ] [ gen-uses ] bi ;
 
 DEFER: lookup-base-pointer
@@ -81,16 +70,13 @@ M: ##sub lookup-base-pointer*
 
 M: vreg-insn lookup-base-pointer* 2drop f ;
 
-! Can't use cache here because of infinite recursion inside
-! the quotation passed to cache
-: lookup-base-pointer ( vreg -- vregs/f )
+: lookup-base-pointer ( vreg -- vreg/f )
     base-pointers get ?at [
         f over base-pointers get set-at
         [ dup ?leader insn-of lookup-base-pointer* ] keep
         dupd base-pointers get set-at
     ] unless ;
 
-
 :: visit-derived-root ( vreg derived-roots gc-roots -- )
     vreg lookup-base-pointer :> base
     base [
@@ -110,12 +96,12 @@ M: vreg-insn lookup-base-pointer* 2drop f ;
     [ '[ drop _ _ visit-gc-root ] assoc-each ] 2keep
     members ;
 
-: fill-gc-map ( live-set insn -- live-set )
+: fill-gc-map ( live-set gc-map -- live-set )
     [ representations get [ dup gc-roots ] [ f f ] if ] dip
-    gc-map>> [ gc-roots<< ] [ derived-roots<< ] bi ;
+    [ gc-roots<< ] [ derived-roots<< ] bi ;
 
-M: gc-map-insn visit-insn
-    [ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;
+M: gc-map-insn visit-insn ( live-set insn -- live-set )
+    [ kill-defs ] [ gc-map>> fill-gc-map ] [ gen-uses ] tri ;
 
 M: ##phi visit-insn kill-defs ;