working on type inference

library/bootstrap/boot-stage1.factor

@@ -90,6 +90,7 @@ parser prettyprint sequences io vectors words ;
         "/library/inference/words.factor"
         "/library/inference/stack.factor"
         "/library/inference/partial-eval.factor"
+        "/library/inference/class-infer.factor"
         "/library/inference/optimizer.factor"
         "/library/inference/print-dataflow.factor"
         

library/bootstrap/boot-stage2.factor

@@ -4,8 +4,6 @@ USING: alien assembler command-line compiler generic hashtables
 kernel lists memory namespaces parser sequences io unparser
 words ;
 
-\ fiber? t "inline" set-word-prop
-
 : pull-in ( ? list -- )
     swap [
         [

library/generic/builtin.factor

@@ -24,13 +24,9 @@ builtin 50 "priority" set-word-prop
 ! All builtin types are equivalent in ordering
 builtin [ 2drop t ] "class<" set-word-prop
 
-: builtin-predicate ( class -- )
-    dup "predicate" word-prop car
-    dup t "inline" set-word-prop
-    swap
-    [
-        \ type , "builtin-type" word-prop , \ eq? ,
-    ] make-list
+: builtin-predicate ( class predicate -- )
+    2dup register-predicate
+    [ \ type , swap "builtin-type" word-prop , \ eq? , ] make-list
     define-compound ;
 
 : register-builtin ( class -- )
@@ -41,8 +37,7 @@ builtin [ 2drop t ] "class<" set-word-prop
     dup intern-symbol
     dup r> "builtin-type" set-word-prop
     dup builtin define-class
-    dup r> unit "predicate" set-word-prop
-    dup builtin-predicate
+    dup r> builtin-predicate
     dup r> intern-slots 2dup "slots" set-word-prop
     define-slots
     register-builtin ;

library/generic/generic.factor

@@ -8,23 +8,12 @@ math-internals ;
 ! A simple single-dispatch generic word system.
 
 : predicate-word ( word -- word )
-    word-name "?" append create-in
-    dup t "inline" set-word-prop ;
+    word-name "?" append create-in ;
 
-! Terminology:
-! - type: a datatype built in to the runtime, eg fixnum, word
-! cons. All objects have exactly one type, new types cannot be
-! defined, and types are disjoint.
-! - class: a user defined way of differentiating objects, either
-! based on type, or some combination of type, predicate, or
-! method map.
-! - metaclass: a metaclass is a symbol with a handful of word
-! properties: "builtin-supertypes" "priority" "add-method"
-! "class<"
+: register-predicate ( class predicate -- )
+    2dup unit "predicate" set-word-prop
+    swap "predicating" set-word-prop ;
 
-! So far, only tuples can have delegates, which also must be
-! tuples (the UI uses numbers as delegates in a couple of places
-! but this is Unsupported(tm)).
 GENERIC: delegate
 GENERIC: set-delegate
 

library/generic/tuple.factor

@@ -18,8 +18,6 @@ hashtables errors sequences vectors ;
     #! specifying an incorrect size.
     <tuple> [ 2 set-slot ] keep ;
 
-: class-tuple 2 slot ; inline
-
 IN: generic
 
 DEFER: tuple?
@@ -30,18 +28,15 @@ M: tuple set-delegate 3 set-slot ;
 
 : class ( obj -- class )
     #! The class of an object.
-    dup tuple? [ class-tuple ] [ type builtin-type ] ifte ;
+    dup tuple? [ 2 slot ] [ type builtin-type ] ifte ; inline
 
 : tuple-predicate ( word -- )
     #! Make a foo? word for testing the tuple class at the top
     #! of the stack.
-    dup predicate-word 2dup unit "predicate" set-word-prop
-    swap [
-        [ dup tuple? ] %
-        [ \ class-tuple , literal, \ eq? , ] make-list ,
-        [ drop f ] ,
-        \ ifte ,
-    ] make-list define-compound ;
+    dup predicate-word
+    2dup register-predicate
+    swap [ \ class , literal, \ eq? , ] make-list
+    define-compound ;
 
 : forget-tuple ( class -- )
     dup forget "predicate" word-prop car [ forget ] when* ;
@@ -136,7 +131,7 @@ M: tuple set-delegate 3 set-slot ;
     #! for methods defined on the given generic.
     dup default-tuple-method \ drop swons
     over tuple-methods hash>quot
-    >r "picker" word-prop [ class-tuple ] r> append3 ;
+    >r "picker" word-prop [ class ] r> append3 ;
 
 : add-tuple-dispatch ( word vtable -- )
     >r tuple-dispatch-quot tuple r> set-vtable ;

library/inference/class-infer.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: generic hashtables kernel namespaces sequences words ;
+USING: generic hashtables kernel namespaces sequences vectors
+words ;
 
 ! Infer possible classes of values in a dataflow IR.
 
@@ -10,54 +11,121 @@ USING: generic hashtables kernel namespaces sequences words ;
 ! Current value --> class mapping
 SYMBOL: value-classes
 
-TUPLE: possibility value class ;
+! Current value --> literal mapping
+SYMBOL: value-literals
 
-! Maps possibilities to possibilities.
-SYMBOL: possible-classes
+GENERIC: apply-tie ( tie -- )
+
+M: f apply-tie ( f -- ) drop ;
+
+TUPLE: class-tie value class ;
+
+: set-value-class ( class value -- )
+    2dup swap <class-tie> ties get hash [ apply-tie ] when*
+    value-classes get set-hash ;
+
+M: class-tie apply-tie ( tie -- )
+    dup class-tie-class swap class-tie-value
+    set-value-class ;
+
+TUPLE: literal-tie value literal ;
+
+: set-value-literal ( literal value -- )
+    over class over set-value-class
+    2dup swap <literal-tie> ties get hash [ apply-tie ] when*
+    value-literals get set-hash ;
+
+M: literal-tie apply-tie ( tie -- )
+    dup literal-tie-literal swap literal-tie-value
+    set-value-literal ;
+
+! Maps ties to ties
+SYMBOL: ties
 
 GENERIC: infer-classes* ( node -- )
 
+M: node infer-classes* ( node -- ) drop ;
+
+! For conditionals, a map of child node # --> possibility
+GENERIC: child-ties ( node -- seq )
+
+M: node child-ties ( node -- seq )
+    node-children length f <repeated> ;
+
 : value-class ( value -- class )
     value-classes get hash [ object ] unless* ;
 
+: value-literal ( value -- class )
+    value-literals get hash ;
+
 : annotate-node ( node -- )
     #! Annotate the node with the currently-inferred set of
     #! value classes.
-    dup node-values [ value-class ] map>hash
-    swap set-node-classes ;
-
-M: node infer-classes* ( node -- ) drop ;
+    dup node-values ( 2dup )
+    [ value-class ] map>hash swap set-node-classes
+    ( [ value-literal ] map>hash swap set-node-literals ) ;
 
 : assume-classes ( classes values -- )
-    [ value-classes get set-hash ] 2each ;
+    [ set-value-class ] 2each ;
+
+: assume-literals ( literals values -- )
+    [ set-value-literal ] 2each ;
 
 : intersect-classes ( classes values -- )
     [ [ value-class class-and ] 2map ] keep assume-classes ;
 
+: create-ties ( #call -- )
+    #! If the node is calling a class test predicate, create a
+    #! tie.
+    dup node-param "predicating" word-prop dup [
+        >r dup node-in-d first r> <class-tie>
+        swap node-out-d first general-t <class-tie>
+        ties get set-hash
+    ] [
+        2drop
+    ] ifte ;
+
 M: #call infer-classes* ( node -- )
+    dup create-ties
     dup node-param "infer-effect" word-prop 2unseq
     pick node-out-d assume-classes
     swap node-in-d intersect-classes ;
 
 M: #push infer-classes* ( node -- )
-    node-out-d [
-        dup safe-literal? [
-            [ literal-value class ] keep
-            value-classes get set-hash
-        ] [
-            drop
-        ] ifte
-    ] each ;
+    node-out-d [ safe-literal? ] subset
+    dup [ literal-value ] map
+    swap assume-literals ;
+
+M: #ifte child-ties ( node -- seq )
+    node-in-d first dup general-t <class-tie>
+    swap f <literal-tie> 2vector ;
+
+M: #dispatch child-ties ( node -- seq )
+    dup node-in-d first
+    swap node-children length [ <literal-tie> ] map-with ;
+
+DEFER: (infer-classes)
+
+: infer-children ( node -- )
+    dup node-children swap child-ties [
+        [
+            value-classes [ clone ] change
+            ties [ clone ] change
+            apply-tie
+            (infer-classes)
+        ] with-scope
+    ] 2each ;
 
 : (infer-classes) ( node -- )
     dup infer-classes*
     dup annotate-node
-    dup node-children [ (infer-classes) ] each
+    dup infer-children
     node-successor [ (infer-classes) ] when* ;
 
 : infer-classes ( node -- )
     [
         <namespace> value-classes set
-        <namespace> possible-classes set
+        <namespace> value-literals set
+        <namespace> ties set
         (infer-classes)
     ] with-scope ;

library/inference/dataflow.factor

@@ -9,12 +9,12 @@ sequences vectors words ;
 ! code with stack flow information and types.
 
 TUPLE: node param in-d out-d in-r out-r
-       classes successor children ;
+       classes literals successor children ;
 
 M: node = eq? ;
 
 : make-node ( param in-d out-d in-r out-r node -- node )
-    [ >r f f f <node> r> set-delegate ] keep ;
+    [ >r f f f f <node> r> set-delegate ] keep ;
 
 : param-node ( label) f f f f ;
 : in-d-node ( inputs) >r f r> f f f ;

library/inference/optimizer.factor

@@ -92,7 +92,7 @@ M: f can-kill* ( literal node -- ? )
     2drop t ;
 
 M: node can-kill* ( literal node -- ? )
-    uses-value? ;
+    uses-value? not ;
 
 M: node kill-node* ( literals node -- )
     2drop ;

library/inference/print-dataflow.factor

@@ -14,7 +14,7 @@ M: annotation prettyprint* ( ann -- )
     swap annotation-node object. ;
 
 : value-str ( classes values -- str )
-    [ swap ?hash [ [ object ] ] unless* ] map-with
+    [ swap ?hash [ object ] unless* ] map-with
     [ word-name ] map
     " " join ;
 

library/test/gadgets/gradients.factor

@@ -5,18 +5,18 @@ USING: gadgets namespaces styles test ;
     0 x set
     0 y set
     
-    [ [ 255 0 0 ] ] [ { 1 0 0 } red green <gradient> 0 gradient-color ] unit-test
-    [ [ 0 255 0 ] ] [ { 1 0 0 } red green <gradient> 1 gradient-color ] unit-test
+    [ { 255 0 0 } ] [ { 1 0 0 } red green <gradient> 0 gradient-color ] unit-test
+    [ { 0 255 0 } ] [ { 1 0 0 } red green <gradient> 1 gradient-color ] unit-test
     
-    [ 0 100 0 [ 255 0 0 ] ]
+    [ 0 100 0 { 255 0 0 } ]
     [ { 0 1 0 } red green <gradient> { 100 200 0 } 0 (gradient-x) ] unit-test
     
     [ 0 100 100 [ 255/2 255/2 0 ] ]
     [ { 0 1 0 } red green <gradient> { 100 200 0 } 100 (gradient-x) ] unit-test
     
-    [ 0 0 200 [ 255 0 0 ] ]
+    [ 0 0 200 { 255 0 0 } ]
     [ { 1 0 0 } red green <gradient> { 100 200 0 } 0 (gradient-y) ] unit-test
     
-    [ 50 0 200 [ 255/2 255/2 0 ] ]
+    [ 50 0 200 { 255/2 255/2 0 } ]
     [ { 1 0 0 } red green <gradient> { 100 200 0 } 50 (gradient-y) ] unit-test
 ] with-scope

library/test/lists/combinators.factor

@@ -8,7 +8,6 @@ USE: strings
 USE: sequences
 
 [ { [ 3 2 1 ] [ 5 4 3 ] [ 6 ] } ]
-[ [ 1 2 3 ] [ 3 4 5 ] [ 6 ] 3vector [ reverse ] map ] unit-test
 
 [ [ "a" 43 [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test
 

library/test/redefine.factor

@@ -8,4 +8,4 @@ USE: test
 : foo 1 2 3 ;
 
 [ 1 2 3 1 2 3 ] [ bar ] unit-test
-[ [ [ ] [ fixnum fixnum fixnum ] ] ] [ [ foo ] infer ] unit-test
+[ [ [ 0 3 ] ] ] [ [ foo ] infer ] unit-test

library/test/sequences.factor

@@ -69,3 +69,5 @@ unit-test
 [ { 1 2 3 } ] [ 1 2 3 3vector ] unit-test
 
 [ { } ] [ { } seq-transpose ] unit-test
+
+[ [ 1 2 3 ] [ 3 4 5 ] [ 6 ] 3vector [ reverse ] map ] unit-test