improved literal killing optimization

CHANGES.html

@@ -6,6 +6,18 @@
 
 <h1>Factor 0.78:</h1>
 
+<ul>
+
+<li>Sequences:
+
+<ul>
+<li>Faster <code>map</code>, <code>2each</code> and <code>2map</code></li>
+</li>
+
+</ul>
+
+<h1>Factor 0.78:</h1>
+
 <ul>
 <li>Consecutive stack operations are now composed into single shuffle expressions.</li>
 <li>The return stack pointer is now stored in a register on x86.</li>

TODO.FACTOR.txt

@@ -48,19 +48,22 @@
 
 + compiler:
 
+- remove dead code after a 'throw'
+- when doing comparison with one arg being a float, inline method
+- investigate overzealous math inlining
+- literals on either side of a shuffle can be more efficient
+- shuffles: eliminate dead loads
+- floating point intrinsics
 - flushing optimization
 - fix fixnum/mod overflow on PowerPC
 - eliminate simplifier
 - intrinsic char-slot set-char-slot
 - [ [ dup call ] dup call ] infer hangs
-- declarations
 - 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
 - remove %fixnum-</<=/>/>=, always use %jump-* form
 - remove %jump-t, use %jump-eq? f instead
-- kill dead code after 'throw'
-- better type inference
 
 + kernel:
 

library/bootstrap/boot-stage1.factor

@@ -38,6 +38,7 @@ sequences io vectors words ;
         "/library/collections/growable.factor"
         "/library/collections/cons.factor"
         "/library/collections/virtual-sequences.factor"
+        "/library/collections/sequence-combinators.factor"
         "/library/collections/sequences-epilogue.factor"
         "/library/collections/strings.factor"
         "/library/collections/sbuf.factor"

library/collections/growable.factor

@@ -29,3 +29,9 @@ GENERIC: set-capacity
 : grow-length ( len seq -- )
     growable-check 2dup length > [ 2dup expand ] when
     set-capacity ;
+
+! We need this pretty early on.
+IN: vectors
+
+: empty-vector ( len -- vec )
+    dup <vector> [ set-capacity ] keep ; inline

library/collections/lists.factor

@@ -18,6 +18,11 @@ M: f each ( list quot -- ) 2drop ;
 M: cons each ( list quot -- | quot: elt -- )
     [ >r car r> call ] 2keep >r cdr r> each ;
 
+M: f map ( f quot -- f ) drop ;
+
+M: cons map ( cons quot -- cons )
+    over cdr over >r >r >r car r> call r> r> rot >r map r> swons ;
+
 : (list-find) ( list quot i -- i elt )
     pick [
         >r 2dup >r >r >r car r> call [

library/collections/sequence-combinators.factor

@@ -0,0 +1,136 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: sequences
+USING: generic kernel kernel-internals math vectors ;
+
+G: each ( seq quot -- | quot: elt -- )
+    [ over ] standard-combination ; inline
+
+M: object each ( seq quot -- )
+    swap dup length [
+        [ swap nth swap call ] 3keep
+    ] repeat 2drop ;
+
+: each-with ( obj seq quot -- | quot: obj elt -- )
+    swap [ with ] each 2drop ; inline
+
+: reduce ( seq identity quot -- value | quot: x y -- z )
+    swapd each ; inline
+
+G: find ( seq quot -- i elt | quot: elt -- ? )
+    [ over ] standard-combination ; inline
+
+: find-with ( obj seq quot -- i elt | quot: elt -- ? )
+    swap [ with rot ] find 2swap 2drop ; inline
+
+: collect ( n generator -- vector | quot: n -- value )
+    #! Primitive mapping out of an integer sequence into a
+    #! vector. Used by map and 2map. Don't call, use map
+    #! instead.
+    >r [ empty-vector ] keep r> swap [
+        [
+            rot >r [ swap call ] keep r>
+            underlying set-array-nth
+        ] 3keep
+    ] repeat drop ; inline
+
+G: map [ over ] standard-combination ; inline
+
+: (map) ( quot seq i -- quot seq value )
+    pick pick >r >r swap nth swap call r> r> rot ; inline
+
+M: object map ( seq quot -- seq )
+    swap [ dup length [ (map) ] collect ] keep like 2nip ;
+
+: map-with ( obj list quot -- list | quot: obj elt -- elt )
+    swap [ with rot ] map 2nip ; inline
+
+: accumulate ( list identity quot -- values | quot: x y -- z )
+    rot [ pick >r swap call r> ] map-with nip ; inline
+
+: change-nth ( seq i quot -- )
+    pick pick >r >r >r swap nth r> call r> r> swap set-nth ;
+    inline
+
+: nmap ( seq quot -- seq | quot: elt -- elt )
+    over length [ [ swap change-nth ] 3keep ] repeat 2drop ;
+    inline
+
+: (2each) ( quot seq seq i -- quot seq seq i )
+    [ 2nth rot dup slip ] 3keep ; inline
+
+: 2each ( seq seq quot -- )
+    #! Don't use with lists.
+    -rot dup length ( over length over length min )
+    [ (2each) ] repeat 3drop ; inline
+
+: 2reduce ( seq seq identity quot -- value | quot: e x y -- z )
+    #! Don't use with lists.
+    >r -rot r> 2each ; inline
+
+: (2map) ( quot seq seq i -- quot seq seq value )
+    pick pick >r >r 2nth rot dup slip
+    swap r> swap r> swap ; inline
+
+: 2map ( seq seq quot -- seq )
+    #! Don't use with lists.
+    -rot [
+        dup length ( over length over length min ) [ (2map) ] collect
+    ] keep like >r 3drop r> ; inline
+
+: find* ( i seq quot -- i elt )
+    pick pick length >= [
+        3drop -1 f
+    ] [
+        3dup >r >r >r >r nth r> call [
+            r> dup r> nth r> drop
+        ] [
+            r> 1 + r> r> find*
+        ] ifte
+    ] ifte ; inline
+
+: find-with* ( obj i seq quot -- i elt | quot: elt -- ? )
+    -rot [ with rot ] find* 2swap 2drop ; inline
+
+M: object find ( seq quot -- i elt )
+    0 -rot find* ;
+
+: contains? ( seq quot -- ? )
+    find drop -1 > ; inline
+
+: contains-with? ( obj seq quot -- ? )
+    find-with drop -1 > ; inline
+
+: all? ( seq quot -- ? )
+    #! ForAll(P in X) <==> !Exists(!P in X)
+    swap [ swap call not ] contains-with? not ; inline
+
+: all-with? ( obj seq quot -- ? | quot: elt -- ? )
+    swap [ with rot ] all? 2nip ; inline
+
+: subset ( seq quot -- seq | quot: elt -- ? )
+    #! all elements for which the quotation returned a value
+    #! other than f are collected in a new list.
+    swap [
+        dup length <vector> -rot [
+            rot >r 2dup >r >r swap call [
+                r> r> r> [ push ] keep swap
+            ] [
+                r> r> drop r> swap
+            ] ifte
+        ] each drop
+    ] keep like ; inline
+
+: subset-with ( obj seq quot -- seq | quot: obj elt -- ? )
+    swap [ with rot ] subset 2nip ; inline
+
+: (monotonic) ( quot seq i -- ? )
+    2dup 1 + swap nth >r swap nth r> rot call ; inline
+
+: monotonic? ( seq quot -- ? | quot: elt elt -- ? )
+    #! Eg, { 1 2 3 4 } [ < ] monotonic? ==> t
+    #!     { 1 3 2 4 } [ < ] monotonic? ==> f
+    #! Don't use with lists.
+    swap dup length 1 - [
+        pick pick >r >r (monotonic) r> r> rot
+    ] all? 2nip ; inline

library/collections/sequences-epilogue.factor

@@ -4,102 +4,6 @@ IN: sequences
 USING: errors generic kernel kernel-internals lists math strings
 vectors words ;
 
-! Combinators
-M: object each ( seq quot -- )
-    swap dup length [
-        [ swap nth swap call ] 3keep
-    ] repeat 2drop ;
-
-: map ( seq quot -- seq | quot: elt -- elt )
-    over [
-        length <vector> rot
-        [ -rot [ slip push ] 2keep ] each nip
-    ] keep like ; inline
-
-: map-with ( obj list quot -- list | quot: obj elt -- elt )
-    swap [ with rot ] map 2nip ; inline
-
-: accumulate ( list identity quot -- values | quot: x y -- z )
-    rot [ pick >r swap call r> ] map-with nip ; inline
-
-: change-nth ( seq i quot -- )
-    pick pick >r >r >r swap nth r> call r> r> swap set-nth ;
-    inline
-
-: nmap ( seq quot -- seq | quot: elt -- elt )
-    over length [ [ swap change-nth ] 3keep ] repeat 2drop ; inline
-
-: 2each ( seq seq quot -- | quot: elt -- )
-    over length >r >r cons r> r>
-    [ [ swap >r >r uncons r> 2nth r> call ] 3keep ] repeat
-    2drop ; inline
-
-: 2reduce ( seq seq identity quot -- value | quot: e x y -- z )
-    >r -rot r> 2each ; inline
-
-: 2map ( seq seq quot -- seq | quot: elt elt -- elt )
-    over [
-        length <vector> 2swap
-        [ 2swap [ slip push ] 2keep ] 2each nip
-    ] keep like ; inline
-
-: find* ( i seq quot -- i elt )
-    pick pick length >= [
-        3drop -1 f
-    ] [
-        3dup >r >r >r >r nth r> call [
-            r> dup r> nth r> drop
-        ] [
-            r> 1 + r> r> find*
-        ] ifte
-    ] ifte ; inline
-
-: find-with* ( obj i seq quot -- i elt | quot: elt -- ? )
-    -rot [ with rot ] find* 2swap 2drop ; inline
-
-M: object find ( seq quot -- i elt )
-    0 -rot find* ;
-
-: contains? ( seq quot -- ? )
-    find drop -1 > ; inline
-
-: contains-with? ( obj seq quot -- ? )
-    find-with drop -1 > ; inline
-
-: all? ( seq quot -- ? )
-    #! ForAll(P in X) <==> !Exists(!P in X)
-    swap [ swap call not ] contains-with? not ; inline
-
-: all-with? ( obj seq quot -- ? | quot: elt -- ? )
-    swap [ with rot ] all? 2nip ; inline
-
-: subset ( seq quot -- seq | quot: elt -- ? )
-    #! all elements for which the quotation returned a value
-    #! other than f are collected in a new list.
-    swap [
-        dup length <vector> -rot [
-            rot >r 2dup >r >r swap call [
-                r> r> r> [ push ] keep swap
-            ] [
-                r> r> drop r> swap
-            ] ifte
-        ] each drop
-    ] keep like ; inline
-
-: subset-with ( obj seq quot -- seq | quot: obj elt -- ? )
-    swap [ with rot ] subset 2nip ; inline
-
-: (monotonic) ( quot seq i -- ? )
-    2dup 1 + swap nth >r swap nth r> rot call ; inline
-
-: monotonic? ( seq quot -- ? | quot: elt elt -- ? )
-    #! Eg, { 1 2 3 4 } [ < ] monotonic? ==> t
-    #!     { 1 3 2 4 } [ < ] monotonic? ==> f
-    swap dup length 1 - [
-        pick pick >r >r (monotonic) r> r> rot
-    ] all? 2nip ; inline
-
-! Operations
 M: object like drop ;
 
 M: object empty? ( seq -- ? ) length 0 = ;

library/collections/sequences.factor

@@ -28,21 +28,6 @@ GENERIC: resize ( n seq -- seq )
 : immutable ( seq quot -- seq | quot: seq -- )
     swap [ thaw ] keep >r dup >r swap call r> r> like ; inline
 
-G: each ( seq quot -- | quot: elt -- )
-    [ over ] standard-combination ; inline
-
-: each-with ( obj seq quot -- | quot: obj elt -- )
-    swap [ with ] each 2drop ; inline
-
-: reduce ( seq identity quot -- value | quot: x y -- z )
-    swapd each ; inline
-
-G: find ( seq quot -- i elt | quot: elt -- ? )
-    [ over ] standard-combination ; inline
-
-: find-with ( obj seq quot -- i elt | quot: elt -- ? )
-    swap [ with rot ] find 2swap 2drop ; inline
-
 : first 0 swap nth ; inline
 : second 1 swap nth ; inline
 : third 2 swap nth ; inline

library/collections/strings-epilogue.factor

@@ -34,4 +34,5 @@ M: string like ( seq sbuf -- string ) drop >string ;
 
 M: sbuf clone ( sbuf -- sbuf ) >sbuf ;
 
-M: sbuf like ( seq sbuf -- sbuf ) drop >sbuf ;
+M: sbuf like ( seq sbuf -- sbuf )
+    drop dup sbuf? [ >sbuf ] unless ;

library/collections/vectors.factor

@@ -14,9 +14,6 @@ M: vector set-nth ( obj n vec -- )
 M: vector hashcode ( vec -- n )
     dup length 0 number= [ drop 0 ] [ first hashcode ] ifte ;
 
-: empty-vector ( len -- vec )
-    dup <vector> [ set-length ] keep ; inline
-
 : >vector ( list -- vector )
     dup length <vector> [ swap nappend ] keep ; inline
 
@@ -26,12 +23,18 @@ M: vector clone ( vector -- vector ) >vector ;
 
 M: general-list like drop >list ;
 
-M: vector like drop >vector ;
+M: vector like drop dup vector? [ >vector ] unless ;
 
-: (1vector) [ push ] keep ; inline
-: (2vector) [ swapd push ] keep (1vector) ; inline
-: (3vector) [ >r rot r> push ] keep (2vector) ; inline
+: 1vector ( x -- { x } )
+    1 empty-vector [ 0 swap set-nth ] keep ; flushable
 
-: 1vector ( x -- { x } ) 1 <vector> (1vector) ; flushable
-: 2vector ( x y -- { x y } ) 2 <vector> (2vector) ; flushable
-: 3vector ( x y z -- { x y z } ) 3 <vector> (3vector) ; flushable
+: 2vector ( x y -- { x y } )
+    2 empty-vector
+    [ 1 swap set-nth ] keep
+    [ 0 swap set-nth ] keep ; flushable
+
+: 3vector ( x y z -- { x y z } )
+    3 empty-vector
+    [ 2 swap set-nth ] keep
+    [ 1 swap set-nth ] keep
+    [ 0 swap set-nth ] keep ; flushable

library/compiler/x86/architecture.factor

@@ -2,7 +2,7 @@ IN: compiler-backend
 USING: assembler compiler-backend sequences ;
 
 ! x86 register assignments
-! EAX, ECX, EDX vregs
+! EAX, ECX, EDX, EBP vregs
 ! ESI datastack
 ! EBX callstack
 

library/inference/dataflow.factor

@@ -109,7 +109,11 @@ C: #values make-node ;
 
 TUPLE: #return ;
 C: #return make-node ;
-: #return ( -- node ) meta-d get clone in-d-node <#return> ;
+: #return ( label -- node )
+    #! The parameter is the label we are returning from, or if
+    #! f, this is a top-level return.
+    meta-d get clone in-d-node <#return>
+    [ set-node-param ] keep ;
 
 TUPLE: #ifte ;
 C: #ifte make-node ;

library/inference/inference.factor

@@ -130,7 +130,7 @@ M: wrapper apply-object wrapped apply-literal ;
     [ infer-quot effect ] with-infer ;
 
 : (dataflow) ( quot -- dataflow )
-    infer-quot #return node, dataflow-graph get ;
+    infer-quot f #return node, dataflow-graph get ;
 
 : dataflow ( quot -- dataflow )
     #! Data flow of a quotation.

library/inference/kill-literals.factor

@@ -4,18 +4,27 @@ IN: inference
 USING: generic hashtables inference kernel lists
 matrices namespaces sequences vectors ;
 
-GENERIC: literals* ( node -- )
+GENERIC: literals* ( node -- seq )
 
 : literals ( node -- seq )
-    [ [ literals* ] each-node ] { } make ;
+    [ [ literals* % ] each-node ] { } make ;
 
-GENERIC: can-kill? ( literal node -- ? )
+GENERIC: can-kill* ( literal node -- ? )
+
+: can-kill? ( literals node -- ? )
+    dup [
+        2dup can-kill* [
+            node-successor can-kill?
+        ] [
+            2drop f
+        ] ifte
+    ] [
+        2drop t
+    ] ifte ;
 
 : kill-set ( node -- list )
     #! Push a list of literals that may be killed in the IR.
-    dup literals [
-        swap [ can-kill? ] all-nodes-with?
-    ] subset-with ;
+    dup literals [ swap can-kill? ] subset-with ;
 
 : remove-values ( values node -- )
     2dup [ node-in-d seq-diff ] keep set-node-in-d
@@ -23,38 +32,73 @@ GENERIC: can-kill? ( literal node -- ? )
     2dup [ node-in-r seq-diff ] keep set-node-in-r
     [ node-out-r seq-diff ] keep set-node-out-r ;
 
-GENERIC: kill-node* ( literals node -- )
-
-M: node kill-node* ( literals node -- ) 2drop ;
-
 : kill-node ( literals node -- )
-    [ 2dup kill-node* remove-values ] each-node-with ;
+    [ remove-values ] each-node-with ;
 
 ! Generic nodes
-M: node literals* ( node -- ) drop ;
+M: node literals* ( node -- ) drop { } ;
 
-M: node can-kill? ( literal node -- ? ) uses-value? not ;
+M: node can-kill* ( literal node -- ? ) uses-value? not ;
 
 ! #push
-M: #push literals* ( node -- )
-    node-out-d % ;
+M: #push literals* ( node -- ) node-out-d ;
 
-M: #push can-kill? ( literal node -- ? ) 2drop t ;
-
-M: #push kill-node* ( literals node -- )
-    [ node-out-d seq-diff ] keep set-node-out-d ;
+M: #push can-kill* ( literal node -- ? ) 2drop t ;
 
 ! #shuffle
-M: #shuffle can-kill? ( literal node -- ? ) 2drop t ;
+M: #shuffle can-kill* ( literal node -- ? ) 2drop t ;
 
 ! #call-label
-M: #call-label can-kill? ( literal node -- ? ) 2drop t ;
-
-! #values
-M: #values can-kill? ( literal node -- ? ) 2drop t ;
+M: #call-label can-kill* ( literal node -- ? ) 2drop t ;
 
 ! #merge
-M: #merge can-kill? ( literal node -- ? ) 2drop t ;
+M: #merge can-kill* ( literal node -- ? ) 2drop t ;
 
 ! #entry
-M: #entry can-kill? ( literal node -- ? ) 2drop t ;
+M: #entry can-kill* ( literal node -- ? ) 2drop t ;
+
+! #return
+SYMBOL: branch-returns
+
+M: #return can-kill* ( literal node -- ? )
+    #! Values returned by local labels can be killed.
+    dup node-param [
+        dupd uses-value? [
+            branch-returns get
+            [ memq? ] subset-with
+            [ [ eq? ] monotonic? ] all?
+        ] [
+            drop t
+        ] ifte
+    ] [
+        delegate can-kill*
+    ] ifte ;
+
+: branch-values ( branches -- )
+    [ last-node node-in-d ] map
+    unify-lengths flip branch-returns set ;
+
+: can-kill-branches? ( literal node -- ? )
+    #! Check if the literal appears in either branch. This
+    #! assumes that the last element of each branch is a #return
+    #! node.
+    2dup uses-value? [
+        2drop f
+    ] [
+        [
+            node-children dup branch-values
+            [ can-kill? ] all-with?
+        ] with-scope
+    ] ifte ;
+
+! #ifte
+M: #ifte can-kill* ( literal node -- ? )
+    can-kill-branches? ;
+
+! #dispatch
+M: #dispatch can-kill* ( literal node -- ? )
+    can-kill-branches? ;
+
+! #label
+M: #label can-kill* ( literal node -- ? )
+    node-child can-kill? ;

library/inference/words.factor

@@ -34,7 +34,7 @@ hashtables parser prettyprint ;
 
 : inline-block ( word -- node-block )
     gensym over word-def cons [
-        #entry node,  word-def infer-quot  #return node,
+        #entry node,  word-def infer-quot  t #return node,
     ] with-block ;
 
 : infer-compound ( word base-case -- effect )

library/math/pow.factor

@@ -9,11 +9,12 @@ USING: errors kernel math math-internals ;
 : exp >rect swap fexp swap polar> ; inline
 : log >polar swap flog swap rect> ; inline
 
-: sqrt ( z -- sqrt )
-    >polar dup pi = [
-        drop fsqrt 0 swap rect>
+: sqrt ( n -- n )
+    dup complex? [
+        >polar swap fsqrt swap 2 / polar>
     ] [
-        swap fsqrt swap 2 / polar>
+        >float dup 0.0 >=
+        [ fsqrt ] [ neg fsqrt 0 swap rect> ] ifte
     ] ifte ; foldable
 
 : norm ( vec -- n ) norm-sq sqrt ;

library/syntax/prettyprint.factor

@@ -161,7 +161,6 @@ C: pprinter ( -- stream )
     [
         end-printing set
         dup pprinter-block pprint-section
-        end-blocks
     ] callcc0 drop ;
 
 GENERIC: pprint* ( obj -- )

library/test/compiler/optimizer.factor

@@ -163,3 +163,10 @@ TUPLE: pred-test ;
 : literal-not-branch 0 not [ ] [ ] ifte ; compiled
 
 [ ] [ literal-not-branch ] unit-test
+
+! regression
+
+: bad-kill-1 [ 3 f ] [ dup bad-kill-1 ] ifte ; inline
+: bad-kill-2 bad-kill-1 drop ; compiled
+
+[ 3 ] [ t bad-kill-2 ] unit-test

native/memory.h

@@ -68,8 +68,8 @@ CELL T;
 #define VECTOR_TYPE 11
 #define STRING_TYPE 12
 #define SBUF_TYPE 13
-#define DLL_TYPE 15
 #define WRAPPER_TYPE 14
+#define DLL_TYPE 15
 #define ALIEN_TYPE 16
 #define WORD_TYPE 17
 #define TUPLE_TYPE 18

version.factor

@@ -1,2 +1,2 @@
 IN: kernel
-: version "0.78" ;
+: version "0.79" ;