Class inference improvements

TODO.FACTOR.txt

@@ -1,6 +1,5 @@
 + 0.84:
 
-- EOF kills a port
 - mach_signal not working, right now
 - fix contribs: boids, automata
 - sometimes darcs get fails with the httpd
@@ -20,7 +19,6 @@
   treats words in the recompile set as if they were not compiled
 - see if alien calls can be made faster
 - faster sequence= for UI
-- type inference at branch merge points
 - remove literal table
 - generic 'define ( asset def -- )'
 
@@ -99,6 +97,7 @@
 
 + misc:
 
+- EOF kills a port
 - make a word to do '0 swap set-length'
 - slice: if sequence or seq start is changed, abstraction violation
 - hashed generic method dispatch

contrib/all.factor

@@ -1,7 +1,7 @@
 USING: kernel modules words ;
 
 REQUIRES: automata boids cairo calendar concurrency coroutines
-crypto dlists embedded gap-buffer hexdump httpd math postgresql
+crypto dlists embedded gap-buffer hexdump httpd lambda math postgresql
 process random-tester slate splay-trees sqlite topology units
 vars ;
 

library/collections/sequence-combinators.factor

@@ -163,7 +163,7 @@ IN: sequences
 
 : copy-into-check ( start to from -- start to from )
     pick over length + pick 2dup length >
-    [ set-length ] [ 2drop ] if ;
+    [ set-length ] [ 2drop ] if ; inline
 
 : copy-into ( start to from -- )
     copy-into-check dup length

library/compiler/optimizer/call-optimizers.factor

@@ -17,7 +17,7 @@ math math-internals sequences words ;
 
 : partial-eval? ( #call -- ? )
     dup node-param "foldable" word-prop [
-        dup node-in-d [ node-value-literal? ] all-with?
+        dup node-in-d [ node-literal? ] all-with?
     ] [
         drop f
     ] if ;

library/compiler/optimizer/class-infer.factor

@@ -5,12 +5,8 @@ USING: arrays generic hashtables inference kernel
 kernel-internals math namespaces sequences words ;
 
 ! Infer possible classes of values in a dataflow IR.
-
-: node-class ( value node -- class )
-    node-classes ?hash [ object ] unless* ;
-
 : node-class# ( node n -- class )
-    swap [ node-in-d <reversed> ?nth ] keep node-class ;
+    over node-in-d <reversed> ?nth node-class ;
 
 ! Variables used by the class inferencer
 
@@ -158,11 +154,30 @@ DEFER: (infer-classes)
         ] with-scope
     ] 2each ;
 
+: merge-value-class ( # nodes -- class )
+    [ tuck node-in-d ?nth node-class ] map-with
+    null [ class-or ] reduce ;
+
+: annotate-merge ( nodes values -- )
+    dup length
+    [ pick merge-value-class swap set-value-class* ] 2each
+    drop ;
+
+: merge-children ( node -- )
+    dup node-successor dup #merge? [
+        node-out-d
+        >r node-children [ last-node ] map r>
+        annotate-merge
+    ] [
+        2drop
+    ] if ;
+
 : (infer-classes) ( node -- )
     [
         dup infer-classes*
         dup annotate-node
         dup infer-children
+        dup merge-children
         node-successor (infer-classes)
     ] when* ;
 

library/compiler/optimizer/optimizer.factor

@@ -79,31 +79,46 @@ M: #return optimize-node* ( node -- node/t )
     set-node-successor ;
 
 ! Constant branch folding
-: node-value-literal? ( node value -- ? )
+: node-literal? ( node value -- ? )
     dup value?
     [ 2drop t ] [ swap node-literals ?hash* nip ] if ;
 
-: node-value-literal ( node value -- obj )
+: node-literal ( node value -- obj )
     dup value?
     [ nip value-literal ] [ swap node-literals ?hash ] if ;
 
+: node-class ( node value -- class )
+    dup value? [
+        nip value-literal class
+    ] [
+        swap node-classes ?hash [ object ] unless*
+    ] if ;
+
 : fold-branch ( node branch# -- node )
     over drop-inputs >r
     >r dup node-successor r> rot node-children nth
     [ subst-node ] keep r> [ set-node-successor ] keep ;
 
 ! #if
-M: #if optimize-node* ( node -- node/t )
-    dup dup node-in-d first 2dup node-value-literal? [
-        node-value-literal 0 1 ? fold-branch
+: known-boolean-value? ( node value -- value ? )
+    2dup node-literal? [
+        node-literal t
     ] [
-        3drop t
+        node-class {
+            { [ dup general-t class< ] [ drop t t ] }
+            { [ dup \ f class< ] [ drop f t ] }
+            { [ t ] [ drop f f ] }
+        } cond
     ] if ;
 
+M: #if optimize-node* ( node -- node/t )
+    dup dup node-in-d first known-boolean-value?
+    [ 0 1 ? fold-branch ] [ 2drop t ] if ;
+
 ! #dispatch
 M: #dispatch optimize-node* ( node -- node/t )
-    dup dup node-in-d first 2dup node-value-literal? [
-        node-value-literal fold-branch
+    dup dup node-in-d first 2dup node-literal? [
+        node-literal fold-branch
     ] [
         3drop t
     ] if ;

library/compiler/optimizer/print-dataflow.factor

@@ -12,7 +12,7 @@ TUPLE: comment node text ;
 M: comment pprint* ( ann -- )
     "( " over comment-text " )" append3
     swap comment-node presented associate
-    [ text ] with-style ;
+    styled-text ;
 
 : comment, ( ? node text -- )
     rot [ <comment> , ] [ 2drop ] if ;

library/generic/classes.factor

@@ -91,8 +91,18 @@ SYMBOL: class<cache
 
 : types* ( class -- hash ) types [ type>class dup ] map>hash ;
 
+: (class-or) ( class class -- class )
+    [ flatten-class ] 2apply hash-union lookup-union ;
+
+: class-or ( class class -- class )
+    {
+        { [ 2dup class< ] [ nip ] }
+        { [ 2dup swap class< ] [ drop ] }
+        { [ t ] [ (class-or) ] }
+    } cond ;
+
 : (class-and) ( class class -- class )
-    [ types* ] 2apply hash-intersect lookup-union ;
+    [ flatten-class ] 2apply hash-intersect lookup-union ;
 
 : class-and ( class class -- class )
     {

library/generic/classes.facts

@@ -91,9 +91,9 @@ HELP: lookup-union "( classes -- class )"
 { $values { "classes" "a hashtable where keys are classes and values equal keys" } { "class" "a class word" } }
 { $description "Outputs a class that is the union of the given classes. If no precise match is found, outputs " { $link object } ", even if the given set is not an exhaustive cover all classes." } ;
 
-HELP: types* "( class -- classes )"
-{ $values { "class" "a class word" } { "classes" "a hashtable where keys are classes and values equal keys" } }
-{ $description "Outputs a sequence of builtin classes whose instances can possibly be instances of the given class." } ;
+HELP: class-or "( class1 class2 -- class )"
+{ $values { "class1" "a class word" } { "class2" "a class word" } { "class" "a class word" } }
+{ $description "Outputs a class whose instances are instances of either one of the two input classes. If the union is non-empty but no class with those members is defined, outputs " { $link object } "." } ;
 
 HELP: class-and "( class1 class2 -- class )"
 { $values { "class1" "a class word" } { "class2" "a class word" } { "class" "a class word" } }