fixing various compiler and inferencer bugs

TODO.FACTOR.txt

@@ -1,3 +1,11 @@
+- flip-branches optimizer not working
+
+- prettyprint:
+
+{ V{ T{ literal T{ value f f G:110886 } f } T{ value 
+    f f G:110887
+} } }
+
 - make-pane: if no input, just return pane-output
 - intrinsic char-slot set-char-slot for x86
 - closing ui does not stop timers
@@ -69,8 +77,6 @@
 - flushing optimization
 - [ [ dup call ] dup call ] infer hangs
 - the invalid recursion form case needs to be fixed, for inlines too
-- recursion is iffy; if the stack at the recursive call doesn't match
-  up, throw an error
 - compile continuations
 
 + sequences:
@@ -85,6 +91,10 @@
 
 + kernel:
 
+- first-class methods:
+  - methods outliner
+  - annotations for methods
+  - docstrings, and originating source file for methods
 - better handling of random arrangements of html words when
   prettyprinting
 - reader syntax for byte arrays, displaced aliens

library/bootstrap/boot-stage1.factor

@@ -123,7 +123,6 @@ vectors words ;
         "/library/inference/inference.factor"
         "/library/inference/branches.factor"
         "/library/inference/words.factor"
-        "/library/inference/recursive-values.factor"
         "/library/inference/class-infer.factor"
         "/library/inference/kill-literals.factor"
         "/library/inference/split-nodes.factor"

library/bootstrap/boot-stage2.factor

@@ -44,7 +44,7 @@ compile? [
     {
         uncons 1+ 1- + <= > >= mod length
         nth-unsafe set-nth-unsafe
-        = string>number number>string scan solve-recursion
+        = string>number number>string scan
         kill-set kill-node (generate)
     } [ compile ] each
 ] when

library/collections/lists.factor

@@ -15,15 +15,25 @@ M: cons peek ( list -- last )
     #! Last element of a list.
     last car ;
 
-M: f each ( list quot -- ) 2drop ;
+: (list-each) ( list quot -- )
+    over [
+        [ >r car r> call ] 2keep >r cdr r> (list-each)
+    ] [
+        2drop
+    ] if ; inline
 
-M: cons each ( list quot -- | quot: elt -- )
+M: general-list each ( list quot -- | quot: elt -- )
-    [ >r car r> call ] 2keep >r cdr r> each ;
+    (list-each) ;
 
-M: f map ( f quot -- f ) drop ;
+: (list-map) ( list quot -- list )
+    over [
+        over cdr over >r >r >r car r> call
+        r> r> rot >r (list-map) r> swons
+    ] [
+        drop
+    ] if ; inline
 
-M: cons map ( cons quot -- cons )
+M: general-list map ( list quot -- list ) (list-map) ;
-    over cdr over >r >r >r car r> call r> r> rot >r map r> swons ;
 
 : (list-find) ( list quot i -- i elt )
     pick [

library/collections/sequence-sort.factor

@@ -44,8 +44,6 @@ C: sorter ( seq start end -- sorter )
         ] when
     ] when ; inline
 
-DEFER: (nsort)
-
 : (nsort) ( quot seq start end -- )
     2dup < [
         <sorter> sort-step

library/collections/sequences-epilogue.factor

@@ -79,12 +79,13 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
     #! consecutive indices numbered from 'start'.
     3dup copy-into-check
     dup length [ >r pick r> + pick set-nth-unsafe ] 2each 2drop ;
+    inline
 
 : nappend ( to from -- )
     #! Add all elements of 'from' at the end of 'to'.
     >r dup length swap r>
     over length over length + pick set-length
-    copy-into ;
+    copy-into ; inline
 
 : append ( s1 s2 -- s1+s2 )
     #! Outputs a new sequence of the same type as s1.
@@ -122,11 +123,11 @@ M: object peek ( sequence -- element )
     #! Shorten the sequence by one element.
     [ length 1- ] keep
     [ 0 -rot set-nth ] 2keep
-    set-length ;
+    set-length ; inline
 
 : pop ( sequence -- element )
     #! Get value at end of sequence and remove it.
-    dup peek swap pop* ;
+    dup peek swap pop* ; inline
 
 : join ( seq glue -- seq )
     #! The new sequence is of the same type as glue.

library/collections/virtual-sequences.factor

@@ -47,9 +47,9 @@ C: slice ( from to seq -- seq )
     >r 3dup check-slice r>
     [ set-slice-seq ] keep
     [ set-slice-to ] keep
-    [ set-slice-from ] keep ;
+    [ set-slice-from ] keep ; inline
 
-: <range> ( from to -- seq ) dup <slice> ;
+: <range> ( from to -- seq ) dup <slice> ; inline
 
 M: slice length ( range -- n )
     dup slice-to swap slice-from - ;

library/compiler/linearizer.factor

@@ -19,18 +19,21 @@ M: f linearize* ( f -- ) drop ;
 M: node linearize* ( node -- ) linearize-next ;
 
 M: #label linearize* ( node -- )
+    #! We remap the IR node's label to a new label object here,
+    #! to avoid problems with two IR #label nodes having the
+    #! same label in different lexical scopes.
     <label> [
         %return-to ,
-        dup node-param %label ,
+        <label> dup pick node-param set %label ,
         dup node-child linearize*
     ] keep %label ,
     linearize-next ;
 
-: ?tail-call ( node caller jumper -- next )
+: ?tail-call ( node label caller jumper -- next )
-    >r >r dup node-successor #return? [
+    >r >r over node-successor #return? [
-        node-param r> drop r> execute ,
+        r> drop r> execute , drop
     ] [
-        dup node-param r> execute , r> drop linearize-next
+        r> execute , r> drop linearize-next
     ] if ; inline
 
 : intrinsic ( #call -- quot ) node-param "intrinsic" word-prop ;
@@ -53,12 +56,12 @@ M: #call linearize* ( node -- )
         dup intrinsic [
             dupd call linearize-next
         ] [
-            \ %call \ %jump ?tail-call
+            dup node-param \ %call \ %jump ?tail-call
         ] if*
     ] if* ;
 
 M: #call-label linearize* ( node -- )
-    \ %call-label \ %jump-label ?tail-call ;
+    dup node-param get \ %call-label \ %jump-label ?tail-call ;
 
 M: #if linearize* ( node -- )
     <label> dup in-1  -1 %inc-d , 0 %jump-t , linearize-if ;
@@ -81,6 +84,4 @@ M: #dispatch linearize* ( vtable -- )
     node-children dispatch-head dispatch-body ;
 
 M: #return linearize* ( node -- )
-    #! Simple label returns do not count, since simple labels do
-    #! not push a stack frame on the C stack.
     drop %return , ;

library/inference/dataflow.factor

@@ -64,7 +64,7 @@ C: #label make-node ;
 
 TUPLE: #entry ;
 C: #entry make-node ;
-: #entry ( -- node ) meta-d get clone in-node <#entry> ;
+: #entry ( -- node ) f param-node <#entry> ;
 
 TUPLE: #call ;
 C: #call make-node ;

library/inference/inline-methods.factor

@@ -50,8 +50,7 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
     dup inlining-class swap node-param "methods" word-prop hash ;
 
 : method-dataflow ( node -- dataflow )
-    dup will-inline swap node-in-d dataflow-with
+    dup will-inline swap node-in-d dataflow-with ;
-    dup solve-recursion ;
 
 : inline-method ( node -- node )
     #! We set the #call node's param to f so that it gets killed

library/inference/kill-literals.factor

@@ -63,16 +63,19 @@ M: #return live-values* ( node -- seq )
     dup node-param [ drop { } ] [ delegate live-values* ] if ;
 
 ! nodes that don't use their input values directly
-UNION: #killable #shuffle #call-label #merge #values ;
+UNION: #killable #shuffle #call-label #merge #values #entry ;
 
 M: #killable live-values* ( node -- seq ) drop { } ;
 
-! #entry
+: purge-invariants ( stacks -- seq )
-M: #entry live-values* ( node -- seq )
+    #! Output a sequence of values which are not present in the
-    #! The live values are those which appear in the in-d but
+    #! same position in each sequence of the stacks sequence.
-    #! not in the out-d. These are literals which are replaced
+    unify-lengths flip [ all-eq? not ] subset concat ;
-    #! by computed values in the solve-recursion step.
+
-    node-out-d ;
+! #label
+M: #label live-values* ( node -- seq )
+    dup node-child node-in-d
+    >r collect-recursion r> add purge-invariants ;
 
 ! branching
 UNION: #branch #if #dispatch ;
@@ -82,5 +85,5 @@ M: #branch returns* ( node -- ) node-children [ returns* ] each ;
 M: #branch live-values* ( node -- )
     #! This assumes that the last element of each branch is a
     #! #return node.
-    dup delegate live-values* >r returns [ node-in-d ] map
+    dup delegate live-values*
-    unify-lengths purge-invariants r> append ;
+    >r returns [ node-in-d ] map purge-invariants r> append ;

library/inference/optimizer.factor

@@ -39,9 +39,7 @@ DEFER: optimize-node
     optimize-1 [ optimize-loop ] when ;
 
 : optimize ( dataflow -- dataflow )
-    [
+    [ dup split-node optimize-loop ] with-scope ;
-        dup solve-recursion dup split-node optimize-loop
-    ] with-scope ;
 
 : prune-if ( node quot -- successor/t )
     over >r call [ r> node-successor ] [ r> drop t ] if ;

library/inference/recursive-values.factor

@@ -1,47 +0,0 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: optimizer
-USING: inference kernel namespaces prettyprint sequences vectors ;
-
-GENERIC: collect-recursion* ( label node -- )
-
-M: node collect-recursion* ( label node -- ) 2drop ;
-
-M: #call-label collect-recursion* ( label node -- )
-    tuck node-param = [ node-in-d , ] [ drop ] if ;
-
-: collect-recursion ( #label -- seq )
-    #! Collect the input stacks of all #call-label nodes that
-    #! call given label.
-    dup node-param swap
-    [ [ collect-recursion* ] each-node-with ] { } make ;
-
-GENERIC: solve-recursion*
-
-M: node solve-recursion* ( node -- ) drop ;
-
-: purge-invariants ( stacks -- seq )
-    #! Output a sequence of values which are not present in the
-    #! same position in each sequence of the stacks sequence.
-    flip [ all-eq? not ] subset concat ;
-
-: join-values ( calls entry -- new old live )
-    add unify-lengths
-    [ flip [ unify-values ] map ] keep
-    [ peek ] keep
-    purge-invariants ;
-
-: entry-values ( node -- new old live )
-    dup collect-recursion swap node-child node-in-d join-values ;
-
-M: #label solve-recursion* ( node -- )
-    #! #entry node-out-d is abused; its not a stack slice, but
-    #! a set of values.
-    [ entry-values ] keep node-child
-    [ set-node-out-d ] keep
-    node-successor subst-values ;
-
-: solve-recursion ( node -- )
-    #! Figure out which values survive inner recursions in
-    #! #labels, and those that don't should be fudged.
-    [ solve-recursion* ] each-node ;

library/inference/words.factor

@@ -30,18 +30,71 @@ TUPLE: rstate label quot base-case? ;
 : with-recursive-state ( word label base-case quot -- )
     >r >r over word-def r> <rstate> cons
     recursive-state [ cons ] change r>
-    call
+    call ; inline
-    recursive-state [ cdr ] change ; inline
 
-: inline-block ( word base-case -- node-block )
+: inline-block ( word base-case -- node-block variables )
-    >r gensym 2dup r> [
+    [
-        [
+        copy-inference
-            dup #label >r
+        >r gensym 2dup r> [
-            #entry node,
+            [
-            swap word-def infer-quot
+                dup #label >r
-            #return node, r>
+                #entry node,
-        ] with-nesting
+                swap word-def infer-quot
-    ] with-recursive-state ;
+                #return node, r>
+            ] with-nesting
+        ] with-recursive-state
+    ] make-hash ;
+
+: apply-infer ( hash -- )
+    { meta-d meta-r d-in }
+    [ [ swap hash ] keep set ] each-with ;
+
+GENERIC: collect-recursion* ( label node -- )
+
+M: node collect-recursion* ( label node -- ) 2drop ;
+
+M: #call-label collect-recursion* ( label node -- )
+    tuck node-param = [ node-in-d , ] [ drop ] if ;
+
+: collect-recursion ( #label -- seq )
+    #! Collect the input stacks of all #call-label nodes that
+    #! call given label.
+    dup node-param swap
+    [ [ collect-recursion* ] each-node-with ] { } make ;
+
+: amend-d-in ( new old -- )
+    [ length ] 2apply - d-in [ + ] change ;
+
+: join-values ( node -- )
+    #! We have to infer recursive labels twice to determine
+    #! which literals survive the recursion (eg, quotations)
+    #! and which don't (loop indices, etc). The latter cannot
+    #! be folded.
+    meta-d get [
+        >r collect-recursion r> add unify-lengths
+        flip [ unify-values ] map dup meta-d set
+    ] keep amend-d-in ;
+
+: splice-node ( node -- )
+    #! Labels which do not call themselves are just spliced into
+    #! the IR, and no #label node is added.
+    dup node-successor [
+        dup node, penultimate-node f over set-node-successor
+        dup current-node set
+    ] when drop ;
+
+: inline-closure ( word -- )
+    #! This is not a closure in the lexical scope sense, but a
+    #! closure under recursive value substitution.
+    #! If the block does not call itself, there is no point in
+    #! having the block node in the IR. Just add its contents.
+    dup f inline-block over recursive-label? [
+        meta-d get >r
+        drop join-values f inline-block apply-infer
+        r> over node-child set-node-in-d node,
+    ] [
+        apply-infer node-child node-successor splice-node drop
+    ] if ;
 
 : infer-compound ( word base-case -- terminates? effect )
     #! Infer a word's stack effect in a separate inferencer
@@ -49,8 +102,8 @@ TUPLE: rstate label quot base-case? ;
     #! control flow by throwing an exception or restoring a
     #! continuation.
     [
-        recursive-state get init-inference
+        recursive-state get init-inference over >r inline-block
-        over >r inline-block drop terminated? get effect r>
+        nip [ terminated? get effect ] bind r>
     ] with-scope over consume/produce over [ terminate ] when ;
 
 GENERIC: apply-word
@@ -92,10 +145,8 @@ M: symbol apply-object ( word -- )
     apply-literal ;
 
 : inline-base-case ( word label -- )
-    meta-d get clone >r
+    meta-d get clone >r over t inline-block apply-infer drop
-    over t inline-block drop
+    [ #call-label ] [ #call ] ?if r> over set-node-in-d node, ;
-    [ #call-label ] [ #call ] ?if
-    r> over set-node-in-d node, ;
 
 : base-case ( word label -- )
     over "inline" word-prop [
@@ -134,26 +185,11 @@ M: symbol apply-object ( word -- )
         ] if*
     ] if* ;
 
-: splice-node ( node -- )
-    dup node-successor [
-        dup node, penultimate-node f over set-node-successor
-        dup current-node set
-    ] when drop ;
-
-: block, ( block -- )
-    #! If the block does not call itself, there is no point in
-    #! having the block node in the IR. Just add its contents.
-    dup recursive-label? [
-        node,
-    ] [
-        node-child node-successor splice-node
-    ] if ;
-
 M: compound apply-object ( word -- )
     #! Apply the word's stack effect to the inferencer state.
     dup recursive-state get assoc [
         recursive-word
     ] [
         dup "inline" word-prop
-        [ f inline-block block, ] [ apply-default ] if
+        [ inline-closure ] [ apply-default ] if
     ] if* ;

library/test/benchmark/iteration.factor

@@ -0,0 +1,18 @@
+IN: temporary
+USING: arrays compiler kernel kernel-internals lists math
+sequences strings test vectors sequences-internals ;
+
+: list-iter 100 [ 0 100000 <range> >list [ ] map drop ] times ; compiled
+: vector-iter 100 [ 0 100000 <range> >vector [ ] map drop ] times ; compiled
+: array-iter 100 [ 0 100000 <range> >array [ ] map drop ] times ; compiled
+: string-iter 100 [ 0 100000 <range> >string [ ] map drop ] times ; compiled
+: sbuf-iter 100 [ 0 100000 <range> >sbuf [ ] map drop ] times ; compiled
+: reverse-iter 100 [ 0 100000 <range> >vector <reversed> [ ] map drop ] times ; compiled
+: dot-iter 100 [ 0 100000 <range> dup v. drop ] times ; compiled
+
+[ ] [ list-iter ] unit-test
+[ ] [ vector-iter ] unit-test
+[ ] [ array-iter ] unit-test
+[ ] [ string-iter ] unit-test
+[ ] [ sbuf-iter ] unit-test
+[ ] [ reverse-iter ] unit-test

library/test/compiler/optimizer.factor

@@ -1,6 +1,7 @@
 USING: arrays assembler compiler compiler-backend generic
 hashtables inference kernel kernel-internals lists math
-optimizer prettyprint sequences strings test vectors words ;
+optimizer prettyprint sequences strings test vectors words
+sequences-internals ;
 IN: temporary
 
 : kill-1
@@ -38,7 +39,7 @@ IN: temporary
 : set= 2dup subset? >r swap subset? r> and ;
 
 : kill-set=
-    dataflow dup solve-recursion dup split-node
+    dataflow dup split-node
     kill-set hash-keys [ literal-value ] map set= ;
 
 : foo 1 2 3 ;
@@ -100,6 +101,14 @@ IN: temporary
 
 [ 4 ] [ 2 2 literal-kill-test-7 ] unit-test
 
+: literal-kill-test-8
+    dup [ >r dup slip r> literal-kill-test-8 ] [ 2drop ] if ; inline
+
+[ t ] [
+    [ [ ] swap literal-kill-test-8 ] dataflow
+    dup split-node live-values hash-values [ literal? ] subset empty?
+] unit-test
+
 ! Test method inlining
 [ string ] [
     \ string
@@ -211,3 +220,21 @@ TUPLE: pred-test ;
 : the-test 2 dup (the-test) ; compiled
 
 [ 2 0 ] [ the-test ] unit-test
+
+! regression
+: (double-recursion) ( start end -- )
+    < [
+        6 1 (double-recursion)
+        3 2 (double-recursion)
+    ] when ; inline
+
+: double-recursion 0 2 (double-recursion) ; compiled
+
+[ ] [ double-recursion ] unit-test
+
+: double-label-1
+    [ f double-label-1 ] [ swap nth-unsafe ] if ; inline
+: double-label-2
+    dup general-list? [ ] [ ] if 0 t double-label-1 ; compiled
+
+[ 0 ] [ 10 double-label-2 ] unit-test

library/test/inference.factor

@@ -204,6 +204,16 @@ DEFER: blah4
 : blah4 dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ;
 [ { 3 0 } ] [ [ blah4 ] infer ] unit-test
 
+! Regression
+: bad-combinator ( obj quot -- )
+    over [
+        2drop
+    ] [
+        [ swap slip ] keep swap bad-combinator
+    ] if ; inline
+
+[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails
+
 [ { 2 1 } ] [ [ swons ] infer ] unit-test
 [ { 1 2 } ] [ [ uncons ] infer ] unit-test
 [ { 1 1 } ] [ [ unit ] infer ] unit-test

library/test/test.factor

@@ -103,7 +103,7 @@ SYMBOL: failures
         "benchmark/continuations" "benchmark/ack"
         "benchmark/hashtables" "benchmark/strings"
         "benchmark/vectors" "benchmark/prettyprint"
-        "benchmark/image"
+        "benchmark/image" "benchmark/iteration"
     } run-tests ;
 
 : compiler-tests