type inference work

TODO.FACTOR.txt

@@ -13,12 +13,12 @@
 - ffi unicode strings: null char security hole
 - utf16 string boxing
 - more accurate types for various words
+- declarations
 - write read: write should flush
 
 + compiler/ffi:
 
 - #jump-f #jump-f-label
-- declarations
 - value type structs
 - out parameters
 - is signed -vs- unsigned pointers an issue?

library/bootstrap/boot-stage2.factor

@@ -97,6 +97,7 @@ IN: alien : add-library 3drop ;
         "/library/inference/conditions.factor"
         "/library/inference/dataflow.factor"
         "/library/inference/inference.factor"
+        "/library/inference/ties.factor"
         "/library/inference/branches.factor"
         "/library/inference/words.factor"
         "/library/inference/stack.factor"

library/inference/branches.factor

@@ -80,7 +80,7 @@ SYMBOL: cloned
     #! Clone an object if it hasn't already been cloned in this
     #! with-deep-clone scope.
     dup cloned get assq [
-        clone [ dup cloned [ acons ] change ] keep
+        dup clone [ swap cloned [ acons ] change ] keep
     ] ?unless ;
 
 : deep-clone-vector ( vector -- vector )
@@ -96,19 +96,12 @@ SYMBOL: cloned
     d-in [ deep-clone-vector ] change
     dataflow-graph off ;
 
-: propagate-type ( [[ value class ]] -- )
-    #! Type propagation is chained.
-    [
-        unswons 2dup set-value-class
-        value-type-prop assoc propagate-type
-    ] when* ;
-
 : infer-branch ( value -- namespace )
     #! Return a namespace with inferencer variables:
     #! meta-d, meta-r, d-in. They are set to f if
     #! terminate was called.
     <namespace> [
-        uncons propagate-type
+        uncons pull-tie
         dup value-recursion recursive-state set
         copy-inference
         literal-value dup infer-quot
@@ -187,8 +180,8 @@ SYMBOL: cloned
     #! unify.
     2list >r 1 meta-d get vector-tail* \ ifte r>
     pop-d [
-        dup \ general-t cons ,
-        \ f cons ,
+        dup \ general-t <class-tie> ,
+        \ f <class-tie> ,
     ] make-list zip ( condition )
     infer-branches ;
 
@@ -209,13 +202,20 @@ SYMBOL: cloned
     dup value-recursion swap literal-value vector>list
     [ over <literal> ] map nip ;
 
+: <dispatch-index> ( value -- value )
+    value-literal-ties
+    0 recursive-state get <literal>
+    [ set-value-literal-ties ] keep ;
+
 USE: kernel-internals
 : infer-dispatch ( -- )
     #! Infer effects for all branches, unify.
     [ object vector ] ensure-d
     dataflow-drop, pop-d vtable>list
     >r 1 meta-d get vector-tail* \ dispatch r>
-    pop-d drop [ unit ] map infer-branches ;
+    pop-d <dispatch-index>
+    over length [ <literal-tie> ] project-with
+    zip infer-branches ;
 
 \ dispatch [ infer-dispatch ] "infer" set-word-property
 \ dispatch [ [ fixnum vector ] [ ] ]

library/inference/conditions.factor

@@ -11,26 +11,24 @@ DEFER: recursive-state
         , , recursive-state get , meta-d get , meta-r get ,
     ] make-list ;
 
-: inference-error ( msg -- )
-    \ inference-error inference-condition throw ;
-
-: inference-warning ( msg -- )
-    \ inference-warning inference-condition error. ;
-
 : inference-condition. ( cond msg -- )
-    write
+    "! " write write
     cdr unswons error.
-    "Recursive state:" print
-    car [.] ;
-!    "Meta data stack:" print
-!    unswons {.}
-!    "Meta return stack:" print
-!    car {.} ;
+    "! Recursive state:" print
+    car [ "! " write . ] each ;
+
+: inference-error ( msg -- )
+    #! Signalled if your code is malformed in some
+    #! statically-provable way.
+    \ inference-error inference-condition throw ;
 
 PREDICATE: cons inference-error car \ inference-error = ;
 M: inference-error error. ( error -- )
     "Inference error: " inference-condition. ;
 
+: inference-warning ( msg -- )
+    \ inference-warning inference-condition error. ;
+
 PREDICATE: cons inference-warning car \ inference-warning = ;
 M: inference-warning error. ( error -- )
     "Inference warning: " inference-condition. ;

library/inference/inference.factor

@@ -28,7 +28,7 @@ SYMBOL: recursive-state
 GENERIC: value= ( literal value -- ? )
 GENERIC: value-class-and ( class value -- )
 
-TUPLE: value class type-prop recursion ;
+TUPLE: value class recursion class-ties literal-ties ;
 
 C: value ( recursion -- value )
     [ set-value-recursion ] keep ;
@@ -42,7 +42,7 @@ C: computed ( class -- value )
 M: computed value= ( literal value -- ? )
     2drop f ;
 
-: failing-class-and
+: failing-class-and ( class class -- class )
     2dup class-and dup null = [
         drop [
             word-name , " and " , word-name ,

library/inference/ties.factor

@@ -0,0 +1,48 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: inference
+USING: kernel lists prettyprint ;
+
+! A tie is when a literal value determines the type or value of
+! a computed result. For example, in the following code, the
+! type of the top of the stack depends on the outcome of the
+! branch:
+!
+! dup cons? [ ... ] [ ... ] ifte
+!
+! In each branch, there is a different tie of the value to a
+! type.
+!
+! Another type of tie happends with generic dispatch.
+!
+! The return value of the 'type' primitive determines the type
+! of a value. The branch chosen in a dispatch determines the
+! numeric value used as the dispatch parameter. Because of a
+! pair of ties, this allows inferences such as the following
+! having a stack effect of [ [ cons ] [ object ] ]:
+!
+! GENERIC: car
+! M: cons car 0 slot ;
+!
+! The only branch that does not end with undefined-method pulls
+! a tie that sets the value's type to cons after two steps.
+
+! Formally, a tie is a tuple.
+
+GENERIC: pull-tie ( tie -- )
+
+TUPLE: class-tie value class ;
+M: class-tie pull-tie ( tie -- )
+    dup class-tie-class swap class-tie-value
+    2dup set-value-class
+    value-class-ties assoc pull-tie ;
+
+TUPLE: literal-tie value literal ;
+M: literal-tie pull-tie ( tie -- )
+    dup literal-tie-literal swap literal-tie-value
+     2dup set-literal-value
+    value-literal-ties assoc pull-tie ;
+
+M: f pull-tie ( tie -- )
+    #! For convenience.
+    drop ;

library/inference/types.factor

@@ -4,17 +4,6 @@ IN: inference
 USING: errors generic interpreter kernel kernel-internals
 lists math namespaces strings vectors words stdio prettyprint ;
 
-! Enhanced inference of primitives relating to data types.
-! Optimizes type checks and slot access.
-
-! : infer-check ( assert class -- )
-!     peek-d dup value-class pick = [
-!         3drop
-!     ] [
-!         value-class-and
-!         dup "infer-effect" word-property consume/produce
-!     ] ifte ;
-
 : fast-slot? ( -- ? )
     #! If the slot number is literal and the object's type is
     #! known, we can compile a slot access into a single
@@ -36,8 +25,9 @@ lists math namespaces strings vectors words stdio prettyprint ;
 ] "infer" set-word-property
 
 : type-value-map ( value -- )
-    num-types [ dup builtin-type pick swons cons ] project
-    [ cdr cdr ] subset nip ;
+    num-types
+    [ tuck builtin-type <class-tie> cons ] project-with
+    [ cdr class-tie-class ] subset ;
 
 \ type [
     [ object ] ensure-d
@@ -46,7 +36,7 @@ lists math namespaces strings vectors words stdio prettyprint ;
         1 0 node-inputs
         [ object ] consume-d
         [ fixnum ] produce-d
-        r> peek-d set-value-type-prop
+        r> peek-d set-value-literal-ties
         1 0 node-outputs
     ] bind
 ] "infer" set-word-property

library/test/inference.factor

@@ -213,11 +213,12 @@ SYMBOL: sym-test
 
 ! Type inference
 
-! [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
-! [ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
-! [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
-! [ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
-! [ [ [ general-list ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
+[ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test
+[ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test
+[ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test
+[ [ [ object ] [ general-t ] ] ] [ [ dup [ drop t ] unless ] infer ] unit-test
+[ [ [ cons ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test
+[ [ [ general-list ] [ object ] ] ] [ [ dup [ car ] when ] infer ] unit-test
 ! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test
 ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test
 ! [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test