compiler.tree.propagation.info: more docs and tests for the vocab

diff --git a/basis/compiler/tree/propagation/info/info-docs.factor b/basis/compiler/tree/propagation/info/info-docs.factor
index 8dcc9db3f992769f2fd65c8fce6d10416a6c5ead..40c5e7bb6dd436986c1e1decfa5b2fffa0a431f2 100644 (file)
--- a/basis/compiler/tree/propagation/info/info-docs.factor
+++ b/basis/compiler/tree/propagation/info/info-docs.factor
@@ -1,6 +1,20 @@
-USING: compiler.tree help.markup help.syntax math sequences ;
+USING: classes compiler.tree help.markup help.syntax kernel math math.intervals
+sequences ;
 IN: compiler.tree.propagation.info
 
+HELP: interval>literal
+{ $values
+  { "class" class }
+  { "interval" interval }
+  { "literal" "a literal value" }
+  { "literal?" boolean }
+}
+{ $description "If interval has zero length and the class is sufficiently precise, we can turn it into a literal." } ;
+
+HELP: literal-class
+{ $values { "obj" object } { "class" class } }
+{ $description "Handle forgotten tuples and singleton classes properly." } ;
+
 HELP: node-input-infos
 { $values { "node" node } { "seq" sequence } }
 { $description "Lists the value infos for the input variables of an SSA tree node." } ;
@@ -13,6 +27,10 @@ HELP: value-info
 { $values { "value" integer } { "info" value-info-state } }
 { $description "Gets the value info for the given SSA value. If none is found then a null empty interval is returned." } ;
 
+HELP: value-info<=
+{ $values { "info1" value-info } { "info2" value-info } { "?" boolean } }
+{ $description "Checks if the first value info is equal to, or smaller than the second one." } ;
+
 HELP: value-info-state
 { $class-description "Represents constraints the compiler knows about the input and output variables to an SSA tree node. It has the following slots:"
   { $table
@@ -34,6 +52,12 @@ ARTICLE: "compiler.tree.propagation.info" "Value info data type and operations"
   node-input-infos
   node-output-infos
   value-info
+}
+"Value info operations:"
+{ $subsections
+  value-info<=
+  value-info-union
+  value-infos-union
 } ;
 
 ABOUT: "compiler.tree.propagation.info"

diff --git a/basis/compiler/tree/propagation/info/info-tests.factor b/basis/compiler/tree/propagation/info/info-tests.factor
index 6a70361ae5003ba03595d560246eef56c694226e..23a6d0ae390625bb12d98ae3bdb92949961da65e 100644 (file)
--- a/basis/compiler/tree/propagation/info/info-tests.factor
+++ b/basis/compiler/tree/propagation/info/info-tests.factor
@@ -1,5 +1,5 @@
-USING: accessors math math.intervals sequences classes.algebra
-kernel tools.test compiler.tree.propagation.info arrays ;
+USING: accessors alien byte-arrays classes.struct math math.intervals sequences
+classes.algebra kernel tools.test compiler.tree.propagation.info arrays ;
 IN: compiler.tree.propagation.info.tests
 
 { f } [ 0.0 -0.0 eql? ] unit-test
@@ -64,10 +64,6 @@ TUPLE: test-tuple { x read-only } ;
     object-info value-info-intersect =
 ] unit-test
 
-{ t } [
-    null-info 3 <literal-info> value-info<=
-] unit-test
-
 { t t } [
     f <literal-info>
     fixnum 0 40 [a,b] <class/interval-info>
@@ -77,3 +73,39 @@ TUPLE: test-tuple { x read-only } ;
     [ class>> fixnum class= ]
     [ interval>> 0 40 [a,b] = ] bi
 ] unit-test
+
+! interval>literal
+{ 10 t } [
+    fixnum 10 10 [a,b]  interval>literal
+] unit-test
+
+STRUCT: self { s self* } ;
+
+! value-info<=
+{ t t t t t t } [
+    byte-array <class-info> c-ptr <class-info> value-info<=
+    null-info 3 <literal-info> value-info<=
+    null-info null-info value-info<=
+    alien <class-info> c-ptr <class-info> value-info<=
+
+    20 <literal-info> fixnum <class-info> value-info<=
+
+    ! A byte-array is a kind of c-ptr
+    f byte-array <class-info> 2array self <tuple-info>
+    f c-ptr <class-info> 2array self <tuple-info>
+    value-info<=
+] unit-test
+
+{ f f f f } [
+    ! Checking intervals
+    fixnum <class-info> 20 <literal-info> value-info<=
+
+    ! Mutable literals
+    [ "foo" ] <literal-info> [ "foo" ] <literal-info> value-info<=
+    ! Strings should be immutable but they aren't. :/
+    "hey" <literal-info> "hey" <literal-info> value-info<=
+
+    f c-ptr <class-info> 2array self <tuple-info>
+    f byte-array <class-info> 2array self <tuple-info>
+    value-info<=
+] unit-test

diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index 9d1ba98e4af59d28ca3285781b97db6b376e432a..e3637eb9f778a6b9622c0801d99fefe07d10ec4b 100644 (file)
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -23,19 +23,17 @@ M: float eql? over float? [ [ double>bits ] same? ] [ 2drop f ] if ;
 M: complex eql? over complex? [ = ] [ 2drop f ] if ;
 
 TUPLE: value-info-state
-class
-interval
-literal
-literal?
-slots ;
+    class
+    interval
+    literal
+    literal?
+    slots ;
 
 CONSTANT: null-info T{ value-info-state f null empty-interval }
 
 CONSTANT: object-info T{ value-info-state f object full-interval }
 
 : interval>literal ( class interval -- literal literal? )
-    ! If interval has zero length and the class is sufficiently
-    ! precise, we can turn it into a literal
     dup special-interval? [
         2drop f f
     ] [
@@ -60,7 +58,6 @@ DEFER: <literal-info>
 UNION: fixed-length array byte-array string ;
 
 : literal-class ( obj -- class )
-    ! Handle forgotten tuples and singleton classes properly
     dup singleton-class? [
         class-of dup class? [
             drop tuple