inline annotation for combinators; faster stack checker taking advantage of this fact; started dataflow IR

TODO.FACTOR.txt

@@ -25,6 +25,7 @@
 
 + listener/plugin:
 
+- console: wrong history
 - listener: if too many things popped off the stack, complain
 - gracefully handle non-working cfactor
 - NPE in ErrorHighlight

library/bootstrap/boot-stage2.factor

@@ -102,6 +102,7 @@ USE: stdio
     "/library/tools/heap-stats.factor"
     "/library/gensym.factor"
     "/library/tools/interpreter.factor"
+    "/library/inference/dataflow.factor"
     "/library/inference/inference.factor"
     "/library/inference/words.factor"
     "/library/inference/branches.factor"

library/combinators.factor

@@ -42,16 +42,16 @@ USE: stack
 : keep ( a quot -- a )
     #! Execute the quotation with a on the stack, and restore a
     #! after the quotation returns.
-    over >r call r> ;
+    over >r call r> ; inline
 
 : 2keep ( a b quot -- a b )
     #! Execute the quotation with a and b on the stack, and
     #! restore a and b after the quotation returns.
-    over >r pick >r call r> r> ;
+    over >r pick >r call r> r> ; inline
 
 : apply ( code input -- code output )
     #! Apply code to input.
-    swap dup >r call r> swap ;
+    swap dup >r call r> swap ; inline
 
 : cond ( x list -- )
     #! The list is of this form:
@@ -86,8 +86,7 @@ USE: stack
     #! If the condition is not f, execute the 'true' quotation,
     #! with the condition on the stack. Otherwise, pop the
     #! condition and execute the 'false' quotation.
-    pick [ drop call ] [ nip nip call ] ifte ;
-    inline
+    pick [ drop call ] [ nip nip call ] ifte ; inline
 
 : unless ( cond quot -- )
     #! Execute a quotation only when the condition is f. The

library/inference/branches.factor

@@ -42,13 +42,16 @@ USE: hashtables
 
 DEFER: (infer)
 
-: (effect) ( -- [ in | stack ] )
-    d-in get  meta-d get cons ;
-
-: infer-branch ( quot -- [ in-d | datastack ] )
+: infer-branch ( quot -- [ in-d | datastack ] dataflow )
     #! Infer the quotation's effect, restoring the meta
     #! interpreter state afterwards.
-    [ copy-interpreter (infer) (effect) ] with-scope ;
+    [
+        copy-interpreter
+        dataflow-graph off
+        (infer)
+        d-in get meta-d get cons
+        get-dataflow
+    ] with-scope ;
 
 : difference ( [ in | stack ] -- diff )
     #! Stack height difference of infer-branch return value.
@@ -87,23 +90,28 @@ DEFER: (infer)
         "Unbalanced branches" throw
     ] ifte ;
 
-: recursive-branch ( quot -- )
-    #! Set base case if inference didn't fail
+: recursive-branch ( quot -- ? )
+    #! Set base case if inference didn't fail.
     [
-        car infer-branch recursive-state get set-base
+        car infer-branch drop  recursive-state get set-base t
     ] [
-        [ drop ] when
+        [ drop f ] when
     ] catch ;
 
-: infer-branches ( brachlist -- )
+: infer-branches ( consume instruction brachlist -- )
     #! Recursive stack effect inference is done here. If one of
     #! the branches has an undecidable stack effect, we set the
     #! base case to this stack effect and try again.
-    dup [ recursive-branch ] each
-    [ car infer-branch ] map unify ;
+    f over [ recursive-branch or ] each [
+        [ [ car infer-branch , ] map ] make-list swap
+        >r dataflow, r> unify
+    ] [
+        "Foo!" throw
+    ] ifte ;
 
 : infer-ifte ( -- )
     #! Infer effects for both branches, unify.
+    3 IFTE
     pop-d pop-d 2list
     pop-d drop ( condition )
     infer-branches ;
@@ -118,12 +126,14 @@ DEFER: (infer)
 
 : infer-generic ( -- )
     #! Infer effects for all branches, unify.
+    2 GENERIC
     pop-d vtable>list
     peek-d drop ( dispatch )
     infer-branches ;
 
 : infer-2generic ( -- )
     #! Infer effects for all branches, unify.
+    3 2GENERIC
     pop-d vtable>list
     peek-d drop ( dispatch )
     peek-d drop ( dispatch )

library/inference/dataflow.factor

@@ -0,0 +1,59 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: inference
+USE: lists
+USE: namespaces
+USE: stack
+
+! We build a dataflow graph for the compiler.
+SYMBOL: dataflow-graph
+
+SYMBOL: CALL ( non-tail call )
+SYMBOL: JUMP ( tail-call )
+SYMBOL: PUSH ( literal )
+
+SYMBOL: IFTE
+SYMBOL: GENERIC
+SYMBOL: 2GENERIC
+
+: get-dataflow ( -- IR )
+    dataflow-graph get reverse ;
+
+: dataflow, ( consume instruction parameters -- )
+    #! Add a node to the dataflow IR. Each node is a list of
+    #! three elements:
+    #! - list of elements consumed from stack
+    #! - a symbol CALL, JUMP or PUSH
+    #! - parameter(s) to insn
+    unit cons cons  dataflow-graph cons@ ;
+
+: dataflow-literal, ( lit -- )
+    >r 0 PUSH r> dataflow, ;
+
+: dataflow-word, ( in word -- )
+    >r count CALL r> dataflow, ;

library/inference/inference.factor

@@ -55,13 +55,6 @@ SYMBOL: recursive-state
 SYMBOL: base-case
 SYMBOL: entry-effect
 
-! We build a dataflow graph for the compiler.
-SYMBOL: dataflow-graph
-
-: dataflow, ( obj -- )
-    #! Add a node to the dataflow IR.
-    dataflow-graph cons@ ;
-
 : gensym-vector ( n --  vector )
     dup <vector> swap [ gensym over vector-push ] times ;
 
@@ -115,21 +108,14 @@ SYMBOL: dataflow-graph
 
 DEFER: apply-word
 
+: apply-literal ( obj -- )
+    #! Literals are annotated with the current recursive
+    #! state.
+    dup dataflow-literal,  recursive-state get cons push-d ;
+
 : apply-object ( obj -- )
     #! Apply the object's stack effect to the inferencer state.
-    #! There are three options: recursive-infer words always
-    #! cause a recursive call of the inferencer, regardless.
-    #! Be careful, you might hang the inferencer. Other words
-    #! solve a fixed-point equation if a recursive call is made,
-    #! otherwise the inferencer is invoked recursively if its
-    #! not a recursive call.
-    dup word? [
-        apply-word
-    ] [
-        #! Literals are annotated with the current recursive
-        #! state.
-        dup dataflow,  recursive-state get cons push-d
-    ] ifte ;
+    dup word? [ apply-word ] [ apply-literal ] ifte ;
 
 : (infer) ( quot -- )
     #! Recursive calls to this word are made for nested
@@ -158,10 +144,11 @@ DEFER: apply-word
 
 : infer ( quot -- [ in | out ] )
     #! Stack effect of a quotation.
-    [
-        f init-inference (infer)  effect
-        ( dataflow-graph get USE: prettyprint . )
-    ] with-scope ;
+    [ f init-inference (infer)  effect ] with-scope ;
+
+: dataflow ( quot -- dataflow )
+    #! Data flow of a quotation.
+    [ f init-inference (infer)  get-dataflow ] with-scope ;
 
 : try-infer ( quot -- effect/f )
     #! Push f if inference fails.

library/inference/words.factor

@@ -45,6 +45,7 @@ USE: hashtables
     #! either execute the word in the meta interpreter (if it is
     #! side-effect-free and all parameters are literal), or
     #! simply apply its stack effect to the meta-interpreter.
+    dup car pick dataflow-word,
     swap "infer" word-property dup [
         swap car ensure-d call
     ] [
@@ -69,17 +70,11 @@ USE: hashtables
 
 : apply-compound ( word -- )
     #! Infer a compound word's stack effect.
-    dup "inline-infer" word-property [
+    dup "inline" word-property [
         inline-compound
     ] [
-        [
-            dup dataflow,  infer-compound consume/produce
-        ] [
-            [
-                dup t "inline-infer" set-word-property
-                inline-compound
-            ] when
-        ] catch
+        dup infer-compound dup car rot dataflow-word,
+        consume/produce
     ] ifte ;
 
 : current-word ( -- word )
@@ -112,18 +107,25 @@ USE: hashtables
         check-recursion recursive-word
     ] [
         drop dup "infer-effect" word-property dup [
-            over dataflow,
             apply-effect
         ] [
-            drop dup compound? [ apply-compound ] [ no-effect ] ifte
+            drop
+            [
+                [ compound? ] [ apply-compound ]
+                [ symbol?   ] [ apply-literal  ]
+                [ drop t    ] [ no-effect      ]
+            ] cond
         ] ifte
     ] ifte ;
 
 : infer-call ( [ rstate | quot ] -- )
+    1 \ drop dataflow-word,
     [
+        dataflow-graph off
         pop-d uncons recursive-state set (infer)
-        d-in get meta-d get
-    ] with-scope  meta-d set d-in set ;
+        d-in get meta-d get get-dataflow
+    ] with-scope
+    [ dataflow-graph cons@ ] each meta-d set d-in set ;
 
 \ call [ infer-call ] "infer" set-word-property
 

library/list-namespaces.factor

@@ -59,11 +59,12 @@ USE: stack
     #! objects to the list that is returned when the quotation
     #! is done.
     [ "list-buffer" off call "list-buffer" get ] with-scope ;
+    inline
 
 : make-list ( quot -- list )
     #! Return a list whose entries are in the same order that ,
     #! was called.
-    make-rlist reverse ;
+    make-rlist reverse ; inline
 
 : , ( obj -- )
     #! Append an object to the currently constructing list.

library/lists.factor

@@ -76,7 +76,7 @@ USE: vectors
     dup cons? [ tail ] when not ;
 
 : partition-add ( obj ? ret1 ret2 -- ret1 ret2 )
-    rot [ swapd cons ] [ >r cons r> ] ifte ; inline
+    rot [ swapd cons ] [ >r cons r> ] ifte ;
 
 : partition-step ( ref list combinator -- ref cdr combinator car ? )
     pick pick car pick call >r >r unswons r> swap r> ; inline
@@ -141,8 +141,7 @@ DEFER: tree-contains?
 : each ( list quot -- )
     #! Push each element of a proper list in turn, and apply a
     #! quotation with effect ( X -- ) to each element.
-    over [ (each) each ] [ 2drop ] ifte ;
-    inline
+    over [ (each) each ] [ 2drop ] ifte ; inline
 
 : reverse ( list -- list )
     [ ] swap [ swons ] each ;
@@ -151,8 +150,7 @@ DEFER: tree-contains?
     #! 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 ;
-    inline
+    over [ (each) rot >r map r> swons ] [ drop ] ifte ; inline
 
 : subset ( list quot -- list )
     #! Applies a quotation with effect ( X -- ? ) to each

library/sbuf.factor

@@ -38,12 +38,12 @@ USE: stack
     #! Call a quotation. The quotation can call , to prepend
     #! objects to the list that is returned when the quotation
     #! is done.
-    make-list cat ;
+    make-list cat ; inline
 
 : make-rstring ( quot -- string )
     #! Return a string whose entries are in the same order that ,
     #! was called.
-    make-rlist cat ;
+    make-rlist cat ; inline
 
 : fill ( count char -- string )
     #! Push a string that consists of the same character
@@ -56,7 +56,7 @@ USE: stack
     #! The quotation must have stack effect ( X -- X ).
     over str-length <sbuf> rot [
         swap >r apply r> tuck sbuf-append
-    ] str-each nip sbuf>str ;
+    ] str-each nip sbuf>str ; inline
 
 : split-next ( index string split -- next )
     3dup index-of* dup -1 = [

library/strings.factor

@@ -143,7 +143,7 @@ USE: stack
     #! pushed onto the stack.
     over str-length [
         -rot 2dup >r >r >r str-nth r> call r> r>
-    ] times* 2drop ;
+    ] times* 2drop ; inline
 
 : str-sort ( list -- sorted )
     #! Sorts the list into ascending lexicographical string

library/test/inference.factor

@@ -147,6 +147,10 @@ DEFER: foe
 
 [ [ 1 | 0 ] ] [ [ nested-when* ] infer ] unit-test
 
+SYMBOL: sym-test
+
+[ [ 0 | 1 ] ] [ [ sym-test ] infer ] unit-test
+
 [ [ 2 | 1 ] ] [ [ fie ] infer ] unit-test
 [ [ 2 | 1 ] ] [ [ foe ] infer ] unit-test
 

library/vector-combinators.factor

@@ -38,7 +38,7 @@ USE: stack
     #! pushed onto the stack.
     over vector-length [
         -rot 2dup >r >r >r vector-nth r> call r> r>
-    ] times* 2drop ;
+    ] times* 2drop ; inline
 
 : vector-map ( vector code -- vector )
     #! Applies code to each element of the vector, return a new
@@ -46,14 +46,14 @@ USE: stack
     #! ( obj -- obj ).
     over vector-length <vector> rot [
         swap >r apply r> tuck vector-push
-    ] vector-each nip ;
+    ] vector-each nip ; inline
 
 : vector-and ( vector -- ? )
     #! Logical and of all elements in the vector.
     t swap [ and ] vector-each ;
 
 : vector-all? ( vector pred -- ? )
-    vector-map vector-and ;
+    vector-map vector-and ; inline
 
 : vector-append ( v1 v2 -- )
     #! Destructively append v2 to v1.
@@ -65,7 +65,7 @@ USE: stack
     #! in a new vector.
     over <vector> rot [
         -rot 2dup >r >r slip vector-push r> r>
-    ] times* nip ;
+    ] times* nip ; inline
 
 : vector-zip ( v1 v2 -- v )
     #! Make a new vector with each pair of elements from the
@@ -81,4 +81,4 @@ USE: stack
     #! differ.
     -rot vector-zip [
         swap dup >r >r uncons r> call r> swap
-    ] vector-map nip ;
+    ] vector-map nip ; inline

library/vectors.factor

@@ -72,7 +72,7 @@ DEFER: vector-map
 
 : ?vector= ( n vec vec -- ? )
     #! Reached end?
-    drop vector-length = ;
+    drop vector-length number= ;
 
 : (vector=) ( n vec vec -- ? )
     3dup ?vector= [