optimizer updates

diff --git a/library/bootstrap/boot-stage3.factor b/library/bootstrap/boot-stage3.factor
index 4b3f18f6db11189ad36ce4caef820b883240dc28..5a6cf1a61dad099b7ecf08dd961b5e82cd338bac 100644 (file)
--- a/library/bootstrap/boot-stage3.factor
+++ b/library/bootstrap/boot-stage3.factor
@@ -45,7 +45,7 @@ compile? [
 t [
     "/library/math/constants.factor"
     "/library/math/pow.factor"
-    "/library/math/matrices.factor"
+    "/library/math/more-matrices.factor"
     "/library/math/trig-hyp.factor"
     "/library/math/arc-trig-hyp.factor"
     "/library/math/random.factor"

diff --git a/library/collections/lists.factor b/library/collections/lists.factor
index 90dcbb5411ac30bef843cc68e1e860f267814bc8..b539b4056d3a97ebbcb5c9a706425febb8450493 100644 (file)
--- a/library/collections/lists.factor
+++ b/library/collections/lists.factor
@@ -84,9 +84,10 @@ M: cons map ( list quot -- list | quot: elt -- elt )
     #! Remove duplicate elements.
     dup [ uncons prune unique ] when ;
 
-: all=? ( list -- ? )
-    #! Check if all elements of a list are equal.
-    [ uncons [ = ] all-with? ] [ t ] ifte* ;
+: fiber? ( list quot -- ? | quot: elt elt -- ? )
+    #! Check if all elements in the list are equivalent under
+    #! the relation.
+    over [ >r uncons r> all-with? ] [ 2drop t ] ifte ; inline
 
 M: cons = ( obj cons -- ? )
     2dup eq? [
@@ -129,7 +130,7 @@ M: cons nth ( n list -- element )
 
 : intersection ( list list -- list )
     #! Make a list of elements that occur in both lists.
-    [ over contains? ] subset nip ;
+    [ swap contains? ] subset-with ;
 
 : difference ( list1 list2 -- list )
     #! Make a list of elements that occur in list2 but not

diff --git a/library/compiler/optimizer.factor b/library/compiler/optimizer.factor
index d72b247a52b6df243d50fc07fe8dee5b665b4559..177919412991c9f9af398cc80eb31c1911567b7f 100644 (file)
--- a/library/compiler/optimizer.factor
+++ b/library/compiler/optimizer.factor
@@ -53,8 +53,15 @@ DEFER: kill-node
 
 GENERIC: useless-node? ( node -- ? )
 
+DEFER: prune-nodes
+
+: prune-children ( node -- )
+    [ node-children [ prune-nodes ] map ] keep
+    set-node-children ;
+
 : (prune-nodes) ( node -- )
     [
+        dup prune-children
         dup node-successor dup useless-node? [
             node-successor over set-node-successor
         ] [
@@ -131,24 +138,38 @@ M: #call can-kill* ( literal node -- ? )
 : kill-mask ( killing inputs -- mask )
     [ swap memq? ] map-with ;
 
-: (kill-shuffle) ( mask -- op )
+: (kill-shuffle) ( word -- map )
     {{
-        [[ [ f f ] over ]]
-        [[ [ f t ] dup  ]]
-        [[ [ f f f ] pick ]]
-        [[ [ f f t ] over ]]
-        [[ [ f t f ] over ]]
-        [[ [ f t t ] dup  ]]
+        [[ over
+            {{
+                [[ [ f t ] dup  ]]
+            }}
+        ]]
+        [[ pick
+            {{
+                [[ [ f f t ] over ]]
+                [[ [ f t f ] over ]]
+                [[ [ f t t ] dup  ]]
+            }}
+        ]]
+        [[ swap {{ }} ]]
+        [[ dup {{ }} ]]
+        [[ >r {{ }} ]]
+        [[ r> {{ }} ]]
     }} hash ;
 
+: lookup-mask ( mask word -- word )
+    over [ not ] all? [ nip ] [ (kill-shuffle) hash ] ifte ;
+
 : kill-shuffle ( literals node -- )
     #! If certain values passing through a stack op are being
     #! killed, the stack op can be reduced, in extreme cases
     #! to a no-op.
-    [ node-in-d kill-mask (kill-shuffle) ] keep set-node-param ;
+    [ [ node-in-d kill-mask ] keep node-param lookup-mask ] keep
+    set-node-param ;
 
 M: #call kill-node* ( literals node -- )
-    dup node-param [ over pick ] memq?
+    dup node-param (kill-shuffle)
     [ kill-shuffle ] [ 2drop ] ifte ;
 
 M: #call useless-node? ( node -- ? )
@@ -167,11 +188,17 @@ SYMBOL: branch-returns
 
 M: #values can-kill* ( literal node -- ? )
     dupd consumes-literal? [
-        branch-returns get memq?
+        branch-returns get
+        [ memq? ] subset-with
+        [ [ eq? ] fiber? ] all?
     ] [
         drop t
     ] ifte ;
 
+: branch-values ( branches -- )
+    [ last-node node-in-d >list ] map
+    unify-lengths vector-transpose >list 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 #values
@@ -179,10 +206,8 @@ M: #values can-kill* ( literal node -- ? )
     2dup consumes-literal? [
         2drop f
     ] [
-       [
-            node-children dup
-            [ last-node node-in-d >list ] map unify-stacks
-            >list branch-returns set
+        [
+            node-children dup branch-values
             [ can-kill? ] all-with?
         ] with-scope
     ] ifte ;

diff --git a/library/inference/branches.factor b/library/inference/branches.factor
index b76ae4056f6ecdf9d3740543ac97506446b50942..781fc2f3bbb2be42081b5a9967d8fd84890023c2 100644 (file)
--- a/library/inference/branches.factor
+++ b/library/inference/branches.factor
@@ -22,7 +22,7 @@ sequences strings vectors words hashtables prettyprint ;
 : unify-results ( list -- value )
     #! If all values in list are equal, return the value.
     #! Otherwise, unify types.
-    dup all=? [
+    dup [ eq? ] fiber? [
         car
     ] [
         [ value-class ] map class-or-list <computed>
@@ -42,7 +42,7 @@ sequences strings vectors words hashtables prettyprint ;
 : balanced? ( list -- ? )
     #! Check if a list of [[ instack outstack ]] pairs is
     #! balanced.
-    [ uncons length swap length - ] map all=? ;
+    [ uncons length swap length - ] map [ = ] fiber? ;
 
 : unify-effect ( list -- in out )
     #! Unify a list of [[ instack outstack ]] pairs.
@@ -76,14 +76,15 @@ sequences strings vectors words hashtables prettyprint ;
 : unify-dataflow ( effects -- nodes )
     [ [ dataflow-graph get ] bind ] map ;
 
-: deep-clone ( seq -- seq ) [ clone ] map ;
+: clone-values ( seq -- seq ) [ clone-value ] map ;
 
 : copy-inference ( -- )
     #! We avoid cloning the same object more than once in order
     #! to preserve identity structure.
-    meta-r [ deep-clone ] change
-    meta-d [ deep-clone ] change
-    d-in [ deep-clone ] change
+    cloned off
+    meta-r [ clone-values ] change
+    meta-d [ clone-values ] change
+    d-in [ clone-values ] change
     dataflow-graph off
     current-node off ;
 

diff --git a/library/inference/values.factor b/library/inference/values.factor
index a045572a8c5b9567238c95c541d5432de6721c14..bf94babf50d81d3851d973c8a9787ffbae9f854a 100644 (file)
--- a/library/inference/values.factor
+++ b/library/inference/values.factor
@@ -1,12 +1,15 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: generic kernel namespaces sequences unparser words ;
+USING: generic kernel lists namespaces sequences unparser words ;
 
 GENERIC: value= ( literal value -- ? )
 GENERIC: value-class-and ( class value -- )
 GENERIC: safe-literal? ( value -- ? )
 
+SYMBOL: cloned
+GENERIC: clone-value ( value -- value )
+
 TUPLE: value class recursion safe? ;
 
 C: value ( recursion -- value )
@@ -46,6 +49,8 @@ C: literal ( obj rstate -- value )
     ] keep
     [ set-literal-value ] keep ;
 
+M: literal clone-value ( value -- value ) ;
+
 M: literal value= ( literal value -- ? )
     literal-value = ;
 
@@ -57,6 +62,11 @@ M: literal set-value-class ( class value -- )
 
 M: literal safe-literal? ( value -- ? ) value-safe? ;
 
+M: computed clone-value ( value -- value )
+    dup cloned get assq [ ] [
+        dup clone [ swap cloned [ acons ] change ] keep
+    ] ?ifte ;
+
 M: computed safe-literal? drop f ;
 
 M: computed literal-value ( value -- )

diff --git a/library/test/compiler/optimizer.factor b/library/test/compiler/optimizer.factor
index e54d04e1b4b58cc954ea2c8b0040c36f880b88a8..0e6f40353a51ae03c223d51fcde57a059d8cb095 100644 (file)
--- a/library/test/compiler/optimizer.factor
+++ b/library/test/compiler/optimizer.factor
@@ -10,17 +10,26 @@ USE: kernel
 USE: lists
 USE: sequences
 
+: kill-set*
+    dataflow kill-set [ literal-value ] map ;
+
 : foo 1 2 3 ;
 
 [ [ ] ] [ \ foo word-def dataflow kill-set ] unit-test
 
-[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test
+[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test
 
-[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test
+[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] kill-set* ] unit-test
 
-[ [ t t f ] ] [ [ 1 2 ] [ 1 2 3 ] [ f <literal> ] map kill-mask ] unit-test
+[ [ t t f ] ] [ [ 1 2 3 ] [
+    f <literal> ] map
+    [ [ literal-value 2 <= ] subset ] keep kill-mask
+] unit-test
 
-[ t ] [ 3 [ 3 over [ ] [ ] ifte drop ] dataflow kill-set contains? ] unit-test
+[ t ] [
+    3 [ 3 over [ ] [ ] ifte drop ] dataflow
+    kill-set [ value= ] some-with? >boolean
+] unit-test
 
 : literal-kill-test-1 4 compiled-offset cell 2 * - ; compiled
 
@@ -33,3 +42,30 @@ USE: sequences
 : literal-kill-test-3 10 3 /mod drop ; compiled
 
 [ 3 ] [ literal-kill-test-3 ] unit-test
+
+[ [ [ 3 ] [ dup ] ] ] [ [ [ 3 ] [ dup ] ifte drop ] kill-set* ] unit-test
+
+: literal-kill-test-4
+    5 swap [ 3 ] [ dup ] ifte 2drop ; compiled
+
+[ ] [ t literal-kill-test-4 ] unit-test
+[ ] [ f literal-kill-test-4 ] unit-test
+
+[ [ [ 3 ] [ dup ] ] ] [ \ literal-kill-test-4 word-def kill-set* ] unit-test
+
+: literal-kill-test-5
+    5 swap [ 5 ] [ dup ] ifte 2drop ; compiled
+
+[ ] [ t literal-kill-test-5 ] unit-test
+[ ] [ f literal-kill-test-5 ] unit-test
+
+[ [ [ 5 ] [ dup ] ] ] [ \ literal-kill-test-5 word-def kill-set* ] unit-test
+
+: literal-kill-test-6
+    5 swap [ dup ] [ dup ] ifte 2drop ; compiled
+
+[ ] [ t literal-kill-test-6 ] unit-test
+[ ] [ f literal-kill-test-6 ] unit-test
+
+[ [ 5 [ dup ] [ dup ] ] ] [ \ literal-kill-test-6 word-def kill-set* ] unit-test
+

diff --git a/library/test/lists/combinators.factor b/library/test/lists/combinators.factor
index d945f042ea737e886ef60d86d272725767fff5e8..ade9a86c3b0d5936e4227c296b07568b4aef5a14 100644 (file)
--- a/library/test/lists/combinators.factor
+++ b/library/test/lists/combinators.factor
@@ -23,11 +23,11 @@ USE: sequences
 [ [ "2 + 2" ] ] [ [ "2 + 2" ] [ string> ] sort ] unit-test
 [ [ 1 2 3 4 5 6 7 ] ] [ [ 6 4 5 7 2 1 3 ] [ > ] sort ] unit-test
 
-[ f ] [ [ { } { } "Hello" ] all=? ] unit-test
-[ f ] [ [ { 2 } { } { } ] all=? ] unit-test
-[ t ] [ [ ] all=? ] unit-test
-[ t ] [ [ 1/2 ] all=? ] unit-test
-[ t ] [ [ 1.0 10/10 1 ] all=? ] unit-test
+[ f ] [ [ { } { } "Hello" ] [ = ] fiber? ] unit-test
+[ f ] [ [ { 2 } { } { } ] [ = ] fiber? ] unit-test
+[ t ] [ [ ] [ = ] fiber? ] unit-test
+[ t ] [ [ 1/2 ] [ = ] fiber? ] unit-test
+[ t ] [ [ 1.0 10/10 1 ] [ = ] fiber? ] unit-test
 
 [ f ] [ [ ] [ ] some? ] unit-test
 [ t ] [ [ 1 ] [ ] some? >boolean ] unit-test