diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index f2f4284449..b7e88ccad5 100644 --- a/TODO.FACTOR.txt +++ b/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? diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index bdfcf30a45..7701ee1580 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/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" diff --git a/library/inference/branches.factor b/library/inference/branches.factor index f2bcc2485f..f0234de13b 100644 --- a/library/inference/branches.factor +++ b/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. [ - 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 , + \ f , ] make-list zip ( condition ) infer-branches ; @@ -209,13 +202,20 @@ SYMBOL: cloned dup value-recursion swap literal-value vector>list [ over ] map nip ; +: ( value -- value ) + value-literal-ties + 0 recursive-state get + [ 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 + over length [ ] project-with + zip infer-branches ; \ dispatch [ infer-dispatch ] "infer" set-word-property \ dispatch [ [ fixnum vector ] [ ] ] diff --git a/library/inference/conditions.factor b/library/inference/conditions.factor index 015fada32c..e92b88515b 100644 --- a/library/inference/conditions.factor +++ b/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. ; diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 9f9677b90f..15edb82727 100644 --- a/library/inference/inference.factor +++ b/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 , diff --git a/library/inference/ties.factor b/library/inference/ties.factor new file mode 100644 index 0000000000..0c6d113eda --- /dev/null +++ b/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 ; diff --git a/library/inference/types.factor b/library/inference/types.factor index a59fdf4cf0..810e2c804f 100644 --- a/library/inference/types.factor +++ b/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 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 diff --git a/library/test/inference.factor b/library/test/inference.factor index 24c4741313..ca27e02db8 100644 --- a/library/test/inference.factor +++ b/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