diff --git a/library/collections/cons.factor b/library/collections/cons.factor index af86ca1b6e..33a3671cad 100644 --- a/library/collections/cons.factor +++ b/library/collections/cons.factor @@ -76,10 +76,9 @@ PREDICATE: general-list list ( list -- ? ) : (each) ( list quot -- list quot ) [ >r car r> call ] 2keep >r cdr r> ; inline -M: general-list each ( list quot -- ) - #! Push each element of a proper list in turn, and apply a - #! quotation with effect ( elt -- ) to each element. - over [ (each) each ] [ 2drop ] ifte ; +M: f each ( list quot -- ) 2drop ; + +M: cons each ( list quot -- | quot: elt -- ) (each) each ; M: cons tree-each ( cons quot -- ) >r uncons r> tuck >r >r tree-each r> r> tree-each ; diff --git a/library/collections/lists.factor b/library/collections/lists.factor index 85465f56b5..271151cdde 100644 --- a/library/collections/lists.factor +++ b/library/collections/lists.factor @@ -66,11 +66,10 @@ M: general-list contains? ( obj list -- ? ) M: general-list reverse ( list -- list ) [ ] swap [ swons ] each ; -M: general-list map ( list quot -- list ) - #! Push each element of a proper list in turn, and collect - #! return values of applying a quotation with effect - #! ( X -- Y ) to each element into a new list. - over [ (each) rot >r map r> swons ] [ drop ] ifte ; +M: f map ( list quot -- list ) drop ; + +M: cons map ( list quot -- list | quot: elt -- elt ) + (each) rot >r map r> swons ; : remove ( obj list -- list ) #! Remove all occurrences of objects equal to this one from @@ -104,11 +103,8 @@ M: f = ( obj f -- ? ) eq? ; M: cons hashcode ( cons -- hash ) car hashcode ; -: (count) ( i n -- list ) - 2dup >= [ 2drop [ ] ] [ >r dup 1 + r> (count) cons ] ifte ; - : count ( n -- [ 0 ... n-1 ] ) - 0 swap (count) ; + 0 swap >list ; : project ( n quot -- list ) >r count r> map ; inline diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index 53c7ed77ee..9abdc0da02 100644 --- a/library/collections/sequences.factor +++ b/library/collections/sequences.factor @@ -43,6 +43,7 @@ G: map ( seq quot -- seq | quot: elt -- elt ) G: 2map ( seq seq quot -- seq | quot: elt elt -- elt ) [ over ] [ type ] ; inline +DEFER: DEFER: append ! remove this when sort is moved from lists to sequences ! Some low-level code used by vectors and string buffers. diff --git a/library/collections/vectors-epilogue.factor b/library/collections/vectors-epilogue.factor index 574e4b6672..da00d2f855 100644 --- a/library/collections/vectors-epilogue.factor +++ b/library/collections/vectors-epilogue.factor @@ -21,7 +21,7 @@ M: vector clone ( vector -- vector ) #! Execute the quotation n times, passing the loop counter #! the quotation as it ranges from 0..n-1. Collect results #! in a new vector. - project >vector ; inline + >r 0 swap >vector r> map ; inline : zero-vector ( n -- vector ) [ drop 0 ] vector-project ; diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor index 63c8c93a81..b93d5aabd7 100644 --- a/library/compiler/intrinsics.factor +++ b/library/compiler/intrinsics.factor @@ -78,13 +78,7 @@ sequences words ; : typed? ( value -- ? ) value-types length 1 = ; -: self ( word -- ) - f swap dup "infer-effect" word-prop (consume/produce) ; - -: intrinsic ( word -- ) - dup [ literal, \ self , ] make-list "infer" set-word-prop ; - -\ slot intrinsic +\ slot t "intrinsic" set-word-prop : slot@ ( node -- n ) #! Compute slot offset. @@ -111,7 +105,7 @@ sequences words ; ] ifte out-1 ] "linearizer" set-word-prop -\ set-slot intrinsic +\ set-slot t "intrinsic" set-word-prop \ set-slot [ dup typed-literal? [ @@ -128,7 +122,7 @@ sequences words ; ] ifte ] "linearizer" set-word-prop -\ type intrinsic +\ type t "intrinsic" set-word-prop \ type [ drop @@ -138,7 +132,7 @@ sequences words ; out-1 ] "linearizer" set-word-prop -\ arithmetic-type intrinsic +\ arithmetic-type t "intrinsic" set-word-prop \ arithmetic-type [ drop @@ -149,7 +143,7 @@ sequences words ; out-1 ] "linearizer" set-word-prop -\ getenv intrinsic +\ getenv t "intrinsic" set-word-prop \ getenv [ 1 %dec-d , @@ -158,7 +152,7 @@ sequences words ; out-1 ] "linearizer" set-word-prop -\ setenv intrinsic +\ setenv t "intrinsic" set-word-prop \ setenv [ 1 %dec-d , @@ -200,12 +194,12 @@ sequences words ; [[ fixnum> %fixnum> ]] [[ eq? %eq? ]] ] [ - uncons over intrinsic + uncons over t "intrinsic" set-word-prop [ literal, 0 , \ binary-op , ] make-list "linearizer" set-word-prop ] each -\ fixnum* intrinsic +\ fixnum* t "intrinsic" set-word-prop : slow-fixnum* \ %fixnum* 0 binary-op-reg ; @@ -225,7 +219,7 @@ sequences words ; ] ifte ] "linearizer" set-word-prop -\ fixnum-mod intrinsic +\ fixnum-mod t "intrinsic" set-word-prop \ fixnum-mod [ ! This is not clever. Because of x86, %fixnum-mod is @@ -234,13 +228,13 @@ sequences words ; drop \ %fixnum-mod 2 binary-op-reg ] "linearizer" set-word-prop -\ fixnum/i intrinsic +\ fixnum/i t "intrinsic" set-word-prop \ fixnum/i [ drop \ %fixnum/i 0 binary-op-reg ] "linearizer" set-word-prop -\ fixnum/mod intrinsic +\ fixnum/mod t "intrinsic" set-word-prop \ fixnum/mod [ ! See the remark on fixnum-mod for vreg usage @@ -251,7 +245,7 @@ sequences words ; 0 1 %replace-d , ] "linearizer" set-word-prop -\ fixnum-bitnot intrinsic +\ fixnum-bitnot t "intrinsic" set-word-prop \ fixnum-bitnot [ drop @@ -295,7 +289,7 @@ sequences words ; ] ifte ] ifte ; -\ fixnum-shift intrinsic +\ fixnum-shift t "intrinsic" set-word-prop \ fixnum-shift [ node-peek dup literal? [ diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index e073bab425..97d1ddd5d6 100644 --- a/library/generic/builtin.factor +++ b/library/generic/builtin.factor @@ -39,7 +39,7 @@ builtin [ 2drop t ] "class<" set-word-prop dup intern-symbol dup r> "builtin-type" set-word-prop dup builtin define-class - dup r> set-predicate + dup r> unit "predicate" set-word-prop dup builtin-predicate dup r> define-slots register-builtin ; diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 0e1fe78603..b3c995428c 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -7,7 +7,9 @@ math-internals ; ! A simple single-dispatch generic word system. -: predicate-word ( word -- word ) word-name "?" cat2 create-in ; +: predicate-word ( word -- word ) + word-name "?" cat2 create-in + dup t "inline" set-word-prop ; ! Terminology: ! - type: a datatype built in to the runtime, eg fixnum, word @@ -174,8 +176,4 @@ SYMBOL: object dup builtin-supertypes [ > ] sort typemap get set-hash ; -: set-predicate ( class word -- ) - dup t "inline" set-word-prop - unit "predicate" set-word-prop ; - typemap get [ typemap set ] unless diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index a6643d2d42..5c4765015e 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -20,15 +20,6 @@ hashtables errors sequences vectors ; : class-tuple 2 slot ; inline -! A sequence of all slots in a tuple, used for equality testing. -TUPLE: tuple-seq tuple ; - -M: tuple-seq nth ( n tuple-seq -- elt ) - tuple-seq-tuple array-nth ; - -M: tuple-seq length ( tuple-seq -- len ) - tuple-seq-tuple array-capacity ; - IN: generic DEFER: tuple? @@ -69,7 +60,7 @@ UNION: arrayed array tuple ; : tuple-predicate ( word -- ) #! Make a foo? word for testing the tuple class at the top #! of the stack. - dup predicate-word 2dup set-predicate + dup predicate-word 2dup unit "predicate" set-word-prop swap [ [ dup tuple? ] % [ \ class-tuple , literal, \ eq? , ] make-list , @@ -173,14 +164,29 @@ UNION: arrayed array tuple ; : add-tuple-dispatch ( word vtable -- ) >r tuple-dispatch-quot tuple r> set-vtable ; -: tuple>list ( tuple -- list ) - #! We have to type check here, since is unsafe. - dup tuple? [ - >list +! A sequence of all slots in a tuple, used for equality testing. +TUPLE: mirror tuple ; + +C: mirror ( tuple -- mirror ) + over tuple? [ + [ set-mirror-tuple ] keep ] [ "Not a tuple" throw ] ifte ; +M: mirror nth ( n mirror -- elt ) + bounds-check mirror-tuple array-nth ; + +M: mirror set-nth ( n mirror -- elt ) + bounds-check mirror-tuple set-array-nth ; + +M: mirror length ( mirror -- len ) + mirror-tuple array-capacity ; + +: tuple>list ( tuple -- list ) + #! We have to type check here, since is unsafe. + >list ; + : clone-tuple ( tuple -- tuple ) #! Make a shallow copy of a tuple, without cloning its #! delegate. @@ -204,7 +210,7 @@ M: tuple = ( obj tuple -- ? ) 2drop t ] [ over tuple? [ - swap swap sequence= + swap swap sequence= ] [ 2drop f ] ifte diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 16c3f0c231..be0112e3b2 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -75,24 +75,34 @@ sequences strings vectors words hashtables prettyprint ; SYMBOL: cloned +GENERIC: (deep-clone) + : deep-clone ( obj -- obj ) - #! Clone an object if it hasn't already been cloned in this - #! with-deep-clone scope. dup cloned get assq [ ] [ - dup clone [ swap cloned [ acons ] change ] keep + dup (deep-clone) [ swap cloned [ acons ] change ] keep ] ?ifte ; -: deep-clone-seq ( seq -- seq ) +M: tuple (deep-clone) ( obj -- obj ) + #! Clone an object if it hasn't already been cloned in this + #! with-deep-clone scope. + clone dup [ deep-clone ] nmap ; + +M: vector (deep-clone) ( seq -- seq ) #! Clone a sequence and each object it contains. [ deep-clone ] map ; +M: cons (deep-clone) ( cons -- cons ) + uncons deep-clone >r deep-clone r> cons ; + +M: object (deep-clone) ( obj -- obj ) ; + : copy-inference ( -- ) #! We avoid cloning the same object more than once in order #! to preserve identity structure. cloned off - meta-r [ deep-clone-seq ] change - meta-d [ deep-clone-seq ] change - d-in [ deep-clone-seq ] change + meta-r [ deep-clone ] change + meta-d [ deep-clone ] change + d-in [ deep-clone ] change dataflow-graph off ; : infer-branch ( value -- namespace ) @@ -100,9 +110,10 @@ SYMBOL: cloned #! meta-d, meta-r, d-in. They are set to f if #! terminate was called. [ - uncons pull-tie - dup value-recursion recursive-state set copy-inference + uncons deep-clone pull-tie + cloned off + dup value-recursion recursive-state set literal-value dup infer-quot active? [ #values values-node @@ -137,16 +148,39 @@ SYMBOL: cloned #! base case to this stack effect and try again. (infer-branches) dup unify-effects unify-dataflow ; +: boolean-value? ( value -- ? ) + #! Return if the value's boolean valuation is known. + value-class dup \ f = >r \ f class-and null = r> or ; + +: boolean-value ( value -- ? ) + #! Only valid if boolean? returns true. + value-class \ f = not ; + +: static-ifte? ( value -- ? ) + #! Is the outcome of this branch statically known? + dup value-safe? swap boolean-value? and ; + +: static-ifte ( true false -- ) + #! If the branch taken is statically known, just infer + #! along that branch. + 1 dataflow-drop, pop-d boolean-value [ drop ] [ nip ] ifte + >literal< infer-quot-value ; + : infer-ifte ( true false -- ) #! If branch taken is computed, infer along both paths and #! unify. 2list >r pop-d \ ifte r> - pick [ general-t POSTPONE: f ] [ ] map-with + pick [ POSTPONE: f general-t ] [ ] map-with zip ( condition ) infer-branches ; \ ifte [ - 2 dataflow-drop, pop-d pop-d swap infer-ifte + 2 dataflow-drop, pop-d pop-d swap + peek-d static-ifte? [ + static-ifte + ] [ + infer-ifte + ] ifte ] "infer" set-word-prop : vtable>list ( rstate vtable -- list ) @@ -166,5 +200,8 @@ USE: kernel-internals over length [ ] project-with zip infer-branches ; -\ dispatch [ pop-literal infer-dispatch ] "infer" set-word-prop +\ dispatch [ + pop-literal infer-dispatch +] "infer" set-word-prop + \ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 7fc164a6e6..12032f9e9f 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -18,8 +18,7 @@ SYMBOL: inferring-base-case SYMBOL: d-in : pop-literal ( -- rstate obj ) - 1 dataflow-drop, pop-d - dup value-recursion swap literal-value ; + 1 dataflow-drop, pop-d >literal< ; : (ensure-types) ( typelist n stack -- ) pick [ @@ -105,6 +104,12 @@ M: object apply-object apply-literal ; drop ] ifte ; +: infer-quot-value ( rstate quot -- ) + recursive-state get >r + swap recursive-state set + dup infer-quot handle-terminator + r> recursive-state set ; + : check-active ( -- ) active? [ "Provable runtime error" inference-error ] unless ; diff --git a/library/inference/partial-eval.factor b/library/inference/partial-eval.factor index 9a77787d3f..797d0ee46f 100644 --- a/library/inference/partial-eval.factor +++ b/library/inference/partial-eval.factor @@ -5,7 +5,7 @@ USING: generic interpreter kernel lists math namespaces sequences words ; : literal-inputs? ( in stack -- ) - tail-slice dup >list [ literal-safe? ] all? [ + tail-slice dup >list [ safe-literal? ] all? [ length dataflow-drop, t ] [ drop f @@ -69,6 +69,28 @@ sequences words ; stateless ] each +: eq-tie ( v1 v2 bool -- ) + >r swap literal-value general-t swons unit r> + set-value-class-ties ; + +: eq-ties ( v1 v2 bool -- ) + #! If the boolean is true, the values are equal. + pick literal? [ + eq-tie + ] [ + over literal? [ + swapd eq-tie + ] [ + 3drop + ] ifte + ] ifte ; + +\ eq? [ + peek-d peek-next-d + \ eq? infer-eval + peek-d eq-ties +] "infer" set-word-prop + ! Partially-evaluated words need their stack effects to be ! entered by hand. \ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop diff --git a/library/inference/ties.factor b/library/inference/ties.factor index 7579e15a3b..46b04add9e 100644 --- a/library/inference/ties.factor +++ b/library/inference/ties.factor @@ -40,7 +40,7 @@ M: class-tie pull-tie ( tie -- ) TUPLE: literal-tie value literal ; M: literal-tie pull-tie ( tie -- ) dup literal-tie-literal swap literal-tie-value - 2dup set-literal-value + dup literal? [ 2dup set-literal-value ] when value-literal-ties assoc pull-tie ; M: f pull-tie ( tie -- ) diff --git a/library/inference/types.factor b/library/inference/types.factor index c84c5766a4..f3e8387039 100644 --- a/library/inference/types.factor +++ b/library/inference/types.factor @@ -1,9 +1,7 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: inference -USING: errors generic interpreter kernel kernel-internals -lists math namespaces strings vectors words sequences -stdio prettyprint ; +USING: generic interpreter kernel lists math namespaces words ; : type-value-map ( value -- ) num-types @@ -11,7 +9,7 @@ stdio prettyprint ; [ cdr class-tie-class ] subset ; : infer-type ( -- ) - \ type #call dataflow, [ + f \ type dataflow, [ peek-d type-value-map >r 1 0 node-inputs [ object ] consume-d @@ -20,6 +18,13 @@ stdio prettyprint ; 1 0 node-outputs ] bind ; +: type-known? ( value -- ? ) + dup value-safe? swap value-types cdr not and ; + \ type [ - [ object ] ensure-d infer-type + peek-d type-known? [ + 1 dataflow-drop, pop-d value-types car apply-literal + ] [ + infer-type + ] ifte ] "infer" set-word-prop diff --git a/library/inference/values.factor b/library/inference/values.factor index 59a685cd4a..b7049b491b 100644 --- a/library/inference/values.factor +++ b/library/inference/values.factor @@ -5,10 +5,12 @@ USING: generic kernel namespaces sequences unparser words ; GENERIC: value= ( literal value -- ? ) GENERIC: value-class-and ( class value -- ) +GENERIC: safe-literal? ( value -- ? ) -TUPLE: value class recursion class-ties literal-ties ; +TUPLE: value class recursion class-ties literal-ties safe? ; C: value ( recursion -- value ) + [ t swap set-value-safe? ] keep [ set-value-recursion ] keep ; TUPLE: computed ; @@ -35,10 +37,9 @@ M: computed value-class-and ( class value -- ) value-class failing-class-and ] keep set-value-class ; -TUPLE: literal value safe? ; +TUPLE: literal value ; C: literal ( obj rstate -- value ) - [ t swap set-literal-safe? ] keep [ >r [ >r dup class r> set-value-class ] keep r> set-delegate @@ -54,9 +55,9 @@ M: literal value-class-and ( class value -- ) M: literal set-value-class ( class value -- ) 2drop ; -M: computed literal-safe? drop f ; +M: literal safe-literal? ( value -- ? ) value-safe? ; -M: computed set-literal-safe? 2drop ; +M: computed safe-literal? drop f ; M: computed literal-value ( value -- ) "A literal value was expected where a computed value was" @@ -64,3 +65,6 @@ M: computed literal-value ( value -- ) : value-types ( value -- list ) value-class builtin-supertypes ; + +: >literal< ( literal -- rstate obj ) + dup value-recursion swap literal-value ; diff --git a/library/inference/words.factor b/library/inference/words.factor index 121c1822a9..55b2dd5eed 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -28,13 +28,17 @@ hashtables parser prettyprint ; : consume/produce ( word [ in-types out-types ] -- ) #! Add a node to the dataflow graph that consumes and #! produces a number of values. - #call swap (consume/produce) ; + over "intrinsic" word-prop [ + f -rot + ] [ + #call swap + ] ifte (consume/produce) ; : no-effect ( word -- ) "Unknown stack effect: " swap word-name cat2 inference-error ; : inhibit-parital ( -- ) - meta-d get [ f swap set-literal-safe? ] each ; + meta-d get [ f swap set-value-safe? ] each ; : recursive? ( word -- ? ) f swap dup word-def [ = or ] tree-each-with ; @@ -182,12 +186,6 @@ M: word apply-object ( word -- ) apply-word ] ifte* ; -: infer-quot-value ( rstate quot -- ) - recursive-state get >r - swap recursive-state set - dup infer-quot handle-terminator - r> recursive-state set ; - \ call [ pop-literal infer-quot-value ] "infer" set-word-prop @@ -204,6 +202,7 @@ M: word apply-object ( word -- ) \ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop \ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop \ not-a-number t "terminator" set-word-prop +\ inference-error t "terminator" set-word-prop \ throw t "terminator" set-word-prop \ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop \ integer/ [ [ integer integer ] [ rational ] ] "infer-effect" set-word-prop diff --git a/library/test/inference.factor b/library/test/inference.factor index 77f9d953cd..cf2902eb34 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -30,7 +30,6 @@ namespaces parser sequences test vectors ; [ [ call ] infer old-effect ] unit-test-fails [ [[ 2 4 ]] ] [ [ 2dup ] infer old-effect ] unit-test -[ [[ 2 0 ]] ] [ [ push ] infer old-effect ] unit-test [ [[ 1 0 ]] ] [ [ [ ] [ ] ifte ] infer old-effect ] unit-test [ [ ifte ] infer old-effect ] unit-test-fails @@ -147,7 +146,7 @@ SYMBOL: sym-test [ [[ 0 1 ]] ] [ [ sym-test ] infer old-effect ] unit-test - +[ [[ 2 0 ]] ] [ [ push ] infer old-effect ] unit-test [ [[ 2 0 ]] ] [ [ set-length ] infer old-effect ] unit-test [ [[ 2 1 ]] ] [ [ 2list ] infer old-effect ] unit-test [ [[ 3 1 ]] ] [ [ 3list ] infer old-effect ] unit-test @@ -220,11 +219,12 @@ M: fixnum potential-hang dup [ potential-hang ] when ; ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test ! [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test -! [ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test -! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test -! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test -! -! [ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test +[ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test +[ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test +[ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test +[ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test + +[ [ [ object ] [ cons ] ] ] [ [ dup cons? [ drop [[ 1 2 ]] ] unless ] infer ] unit-test TUPLE: funny-cons car cdr ; GENERIC: iterate