some stack inference work

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 -- )
+M: f each ( list quot -- ) 2drop ;
-    #! Push each element of a proper list in turn, and apply a
+
-    #! quotation with effect ( elt -- ) to each element.
+M: cons each ( list quot -- | quot: elt -- ) (each) each ;
-    over [ (each) each ] [ 2drop ] ifte ;
 
 M: cons tree-each ( cons quot -- )
     >r uncons r> tuck >r >r tree-each r> r> tree-each ;

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 )
+M: f map ( list quot -- list ) drop ;
-    #! Push each element of a proper list in turn, and collect
+
-    #! return values of applying a quotation with effect
+M: cons map ( list quot -- list | quot: elt -- elt )
-    #! ( X -- Y ) to each element into a new list.
+    (each) rot >r map r> swons ;
-    over [ (each) rot >r map r> swons ] [ drop ] ifte ;
 
 : 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 <range> >list ;
 
 : project ( n quot -- list )
     >r count r> map ; inline

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: <range>
 DEFER: append ! remove this when sort is moved from lists to sequences
 
 ! Some low-level code used by vectors and string buffers.

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 <range> >vector r> map ; inline
 
 : zero-vector ( n -- vector )
     [ drop 0 ] vector-project ;

library/compiler/intrinsics.factor

@@ -78,13 +78,7 @@ sequences words ;
 
 : typed? ( value -- ? ) value-types length 1 = ;
 
-: self ( word -- )
+\ slot t "intrinsic" set-word-prop
-    f swap dup "infer-effect" word-prop (consume/produce) ;
-
-: intrinsic ( word -- )
-    dup [ literal, \ self , ] make-list "infer" set-word-prop ;
-
-\ slot intrinsic
 
 : 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? [

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 ;

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 [ <namespace> typemap set ] unless

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 )
+! A sequence of all slots in a tuple, used for equality testing.
-    #! We have to type check here, since <tuple-seq> is unsafe.
+TUPLE: mirror tuple ;
-    dup tuple? [
+
-        <tuple-seq> >list
+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 <mirror> is unsafe.
+    <mirror> >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 <tuple-seq> swap <tuple-seq> sequence=
+            swap <mirror> swap <mirror> sequence=
         ] [
             2drop f
         ] ifte

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 <mirror> [ 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-r [ deep-clone ] change
-    meta-d [ deep-clone-seq ] change
+    meta-d [ deep-clone ] change
-    d-in [ deep-clone-seq ] 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.
     <namespace> [
-        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 ] [ <class-tie> ] map-with
+    pick [ POSTPONE: f general-t ] [ <class-tie> ] 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 [ <literal-tie> ] 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

library/inference/inference.factor

@@ -18,8 +18,7 @@ SYMBOL: inferring-base-case
 SYMBOL: d-in
 
 : pop-literal ( -- rstate obj )
-    1 dataflow-drop, pop-d
+    1 dataflow-drop, pop-d >literal< ;
-    dup value-recursion swap literal-value ;
 
 : (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 ;
 

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 <literal-tie> 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

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 -- )

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
+USING: generic interpreter kernel lists math namespaces words ;
-lists math namespaces strings vectors words sequences
-stdio prettyprint ;
 
 : 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

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 <value> [ >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 ;

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

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: t ] ] ] [ [ f not ] infer ] unit-test
-! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test
+[ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test
-! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test
+[ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test
-! 
+[ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] 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