dataflow optimizer work

diff --git a/library/collections/lists.factor b/library/collections/lists.factor
index 827d3b6e84e12b5599aa62eebf0623de4724b4d2..90dcbb5411ac30bef843cc68e1e860f267814bc8 100644 (file)
--- a/library/collections/lists.factor
+++ b/library/collections/lists.factor
@@ -134,7 +134,12 @@ M: cons nth ( n list -- element )
 : difference ( list1 list2 -- list )
     #! Make a list of elements that occur in list2 but not
     #! list1.
-    [ over contains? not ] subset nip ;
+    [ swap contains? not ] subset-with ;
+
+: diffq ( list1 list2 -- list )
+    #! Make a list of elements that occur in list2 but not
+    #! list1.
+    [ swap memq? not ] subset-with ;
 
 : contained? ( list1 list2 -- ? )
     #! Is every element of list1 in list2?

diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor
index ea280ea40b650355346119346b35949dfb317ad9..8df83a38ac1e97236bb4c46b317c239b156371db 100644 (file)
--- a/library/collections/sequences-epilogue.factor
+++ b/library/collections/sequences-epilogue.factor
@@ -82,7 +82,9 @@ M: object 2map ( seq1 seq2 quot -- seq | quot: elt1 elt2 -- elt3 )
     #! The index of the object in the sequence.
     0 index* ;
 
-M: object contains? ( obj seq -- ? ) index -1 > ;
+M: object contains? ( obj seq -- ? )
+    #! Tests for membership using =.
+    index -1 > ;
 
 : push ( element sequence -- )
     #! Push a value on the end of a sequence.

diff --git a/library/compiler/optimizer.factor b/library/compiler/optimizer.factor
index 3a5c98ce57cd6e62dd85df9fcf47def5e2e28479..d72b247a52b6df243d50fc07fe8dee5b665b4559 100644 (file)
--- a/library/compiler/optimizer.factor
+++ b/library/compiler/optimizer.factor
@@ -1,217 +1,196 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler-frontend
-USING: inference kernel kernel-internals lists namespaces
-sequences vectors words words ;
+USING: hashtables inference kernel lists namespaces sequences ;
 
 ! The optimizer transforms dataflow IR to dataflow IR. Currently
 ! it removes literals that are eventually dropped, and never
 ! arise as inputs to any other type of function. Such 'dead'
 ! literals arise when combinators are inlined and quotations are
-! lifted to their call sites. Also, #label nodes are inlined if
-! their children do not make a recursive call to the label.
+! lifted to their call sites.
 
-: scan-literal ( node -- )
-    #! If the node represents a literal push, add the literal to
-    #! the list being constructed.
-    "scan-literal" [ drop ] apply-dataflow ;
+GENERIC: literals* ( node -- )
 
-: (scan-literals) ( dataflow -- )
-    [ scan-literal ] each ;
+: literals, ( node -- )
+    [ dup literals* node-successor literals, ] when* ;
 
-: scan-literals ( dataflow -- list )
-    [ (scan-literals) ] make-list ;
+: literals ( node -- list )
+    [ literals, ] make-list ;
 
-: scan-branches ( branches -- )
-    #! Collect all literals from all branches.
-    [ node-param get ] bind [ [ scan-literal ] each ] each ;
+GENERIC: can-kill* ( literal node -- ? )
 
-: mentions-literal? ( literal list -- ? )
-    #! Does the given list of result objects refer to this
-    #! literal?
-    [ value= ] some-with? ;
-
-: consumes-literal? ( literal node -- ? )
-    #! Does the dataflow node consume the literal?
-    [
-        dup node-consume-d get mentions-literal? swap
-        dup node-consume-r get mentions-literal? nip or
-    ] bind ;
-
-: produces-literal? ( literal node -- ? )
-    #! Does the dataflow node produce the literal?
-    [
-        dup node-produce-d get mentions-literal? swap
-        dup node-produce-r get mentions-literal? nip or
-    ] bind ;
-
-: (can-kill?) ( literal node -- ? )
-    #! Return false if the literal appears as input to this
-    #! node, and this node is not a stack operation.
-    2dup consumes-literal? >r produces-literal? r> or not ;
-
-: can-kill? ( literal dataflow -- ? )
+: can-kill? ( literal node -- ? )
     #! Return false if the literal appears in any node in the
     #! list.
-    [ dupd "can-kill" [ (can-kill?) ] apply-dataflow ] all? nip ;
+    dup [
+        2dup can-kill* [
+            node-successor can-kill?
+        ] [
+            2drop f
+        ] ifte
+    ] [
+        2drop t
+    ] ifte ;
 
-: kill-set ( dataflow -- list )
+: kill-set ( node -- list )
     #! Push a list of literals that may be killed in the IR.
-    dup scan-literals [ over can-kill? ] subset nip ;
+    dup literals [ swap can-kill? ] subset-with ;
 
-SYMBOL: branch-returns
+GENERIC: kill-node* ( literals node -- )
 
-: 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
-    #! node.
-    2dup consumes-literal? [
-        2drop f
-    ] [
-        [ node-param get ] bind
-        [
-            dup [
-                peek [ node-consume-d get >vector ] bind
-            ] map
-            unify-stacks >list
-            branch-returns set
-            [ dupd can-kill? ] all? nip
-        ] with-scope
-    ] ifte ;
+DEFER: kill-node
+
+: kill-children ( literals node -- )
+    node-children [ kill-node ] each-with ;
 
 : kill-node ( literals node -- )
-    swap [ over (can-kill?) ] all? [ , ] [ drop ] ifte ;
+    dup [
+        2dup kill-children
+        2dup kill-node* node-successor kill-node
+    ] [
+        2drop
+    ] ifte ;
 
-: (kill-nodes) ( literals dataflow -- )
-    #! Append live nodes to currently constructing list.
-    [ "kill-node" [ nip , ] apply-dataflow ] each-with ;
+GENERIC: useless-node? ( node -- ? )
 
-: kill-nodes ( literals dataflow -- dataflow )
-    #! Remove literals and construct a list.
-    [ (kill-nodes) ] make-list ;
+: (prune-nodes) ( node -- )
+    [
+        dup node-successor dup useless-node? [
+            node-successor over set-node-successor
+        ] [
+            nip
+        ] ifte (prune-nodes)
+    ] when* ;
+
+: prune-nodes ( node -- node )
+    dup useless-node? [
+        node-successor prune-nodes
+    ] [
+        [ (prune-nodes) ] keep
+    ] ifte ;
 
 : optimize ( dataflow -- dataflow )
     #! Remove redundant literals from the IR. The original IR
     #! is destructively modified.
-    dup kill-set swap kill-nodes ;
+    dup kill-set over kill-node prune-nodes ;
 
-: kill-branches ( literals node -- )
-    [
-        node-param [ [ dupd kill-nodes ] map nip ] change
-    ] extend , ;
+! Generic nodes
+M: node literals* ( node -- )
+    node-children [ literals, ] each ;
 
-: kill-literal ( literals values -- values )
-    [
-        swap [ swap value= ] some-with? not
-    ] subset-with ;
+M: f can-kill* ( literal node -- ? )
+    2drop t ;
 
-#push [
-    [ node-produce-d get ] bind [ literal-value ] map %
-] "scan-literal" set-word-prop
+M: node can-kill* ( literal node -- ? )
+    2dup consumes-literal? >r produces-literal? r> or not ;
 
-#push [ 2drop t ] "can-kill" set-word-prop
+M: node kill-node* ( literals node -- )
+    2drop ;
 
-#push [
-    [ node-produce-d [ kill-literal ] change ] extend ,
-] "kill-node" set-word-prop
+M: f useless-node? ( node -- ? )
+    drop f ;
 
-#drop [ 2drop t ] "can-kill" set-word-prop
+M: node useless-node? ( node -- ? )
+    drop f ;
 
-#drop [
-    [ node-consume-d [ kill-literal ] change ] extend ,
-] "kill-node" set-word-prop
+! #push
+M: #push literals* ( node -- )
+    node-out-d % ;
 
-#label [
-    [ node-param get ] bind (scan-literals)
-] "scan-literal" set-word-prop
+M: #push can-kill* ( literal node -- ? )
+    2drop t ;
 
-#label [
-    [ node-param get ] bind can-kill?
-] "can-kill" set-word-prop
+M: #push kill-node* ( literals node -- )
+    [ node-out-d diffq ] keep set-node-out-d ;
 
-#call-label [
-    [ node-param get ] bind =
-] "calls-label" set-word-prop
+M: #push useless-node? ( node -- ? )
+    node-out-d empty? ;
 
-: calls-label? ( label list -- ? )
-    [ "calls-label" [ 2drop f ] apply-dataflow ] some-with? ;
+! #drop
+M: #drop can-kill* ( literal node -- ? )
+     2drop t ;
 
-#label [
-    [ node-param get ] bind calls-label?
-] "calls-label" set-word-prop
+M: #drop kill-node* ( literals node -- )
+    [ node-in-d diffq ] keep set-node-in-d ;
 
-: branches-call-label? ( label list -- ? )
-    [ calls-label? ] some-with? ;
+M: #drop useless-node? ( node -- ? )
+    node-in-d empty? ;
 
-\ ifte [
-    [ node-param get ] bind branches-call-label?
-] "calls-label" set-word-prop
+! #call
+M: #call can-kill* ( literal node -- ? )
+    nip node-param {{
+        [[ dup t ]]
+        [[ drop t ]]
+        [[ swap t ]]
+        [[ over t ]]
+        [[ pick t ]] 
+        [[ >r t ]]
+        [[ r> t ]]
+    }} hash ;
 
-\ dispatch [
-    [ node-param get ] bind branches-call-label?
-] "calls-label" set-word-prop
+: kill-mask ( killing inputs -- mask )
+    [ swap memq? ] map-with ;
 
-#label [ ( literals node -- )
-    [ node-param [ kill-nodes ] change ] extend ,
-] "kill-node" set-word-prop
+: (kill-shuffle) ( mask -- op )
+    {{
+        [[ [ f f ] over ]]
+        [[ [ f t ] dup  ]]
+        [[ [ f f f ] pick ]]
+        [[ [ f f t ] over ]]
+        [[ [ f t f ] over ]]
+        [[ [ f t t ] dup  ]]
+    }} hash ;
 
-#values [
-    dupd consumes-literal? [
-        branch-returns get mentions-literal?
-    ] [
-        drop t
-    ] ifte
-] "can-kill" set-word-prop
+: 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 ;
 
-\ ifte [ scan-branches ] "scan-literal" set-word-prop
-\ ifte [ can-kill-branches? ] "can-kill" set-word-prop
-\ ifte [ kill-branches ] "kill-node" set-word-prop
+M: #call kill-node* ( literals node -- )
+    dup node-param [ over pick ] memq?
+    [ kill-shuffle ] [ 2drop ] ifte ;
 
-\ dispatch [ scan-branches ] "scan-literal" set-word-prop
-\ dispatch [ can-kill-branches? ] "can-kill" set-word-prop
-\ dispatch [ kill-branches ] "kill-node" set-word-prop
+M: #call useless-node? ( node -- ? )
+    node-param not ;
 
-! Don't care about inputs to recursive combinator calls
-#call-label [ 2drop t ] "can-kill" set-word-prop
+! #call-label
+M: #call-label can-kill* ( literal node -- ? )
+     2drop t ;
 
-\ drop [ 2drop t ] "can-kill" set-word-prop
-\ drop [ kill-node ] "kill-node" set-word-prop
-\ dup [ 2drop t ] "can-kill" set-word-prop
-\ dup [ kill-node ] "kill-node" set-word-prop
-\ swap [ 2drop t ] "can-kill" set-word-prop
-\ swap [ kill-node ] "kill-node" set-word-prop
+! #label
+M: #label can-kill* ( literal node -- ? )
+    node-children car can-kill? ;
 
-: kill-mask ( killing inputs -- mask )
-    [ over [ over value= ] some? >boolean nip ] map nip ;
+! #values
+SYMBOL: branch-returns
 
-: reduce-stack-op ( literals node map -- )
-    #! If certain values passing through a stack op are being
-    #! killed, the stack op can be reduced, in extreme cases
-    #! to a no-op.
-    -rot [
-        [ node-consume-d get ] bind kill-mask swap assoc
-    ] keep
-    over [ [ node-op set ] extend , ] [ 2drop ] ifte ;
+M: #values can-kill* ( literal node -- ? )
+    dupd consumes-literal? [
+        branch-returns get memq?
+    ] [
+        drop t
+    ] ifte ;
 
-\ over [ 2drop t ] "can-kill" set-word-prop
-\ over [
-    [
-        [[ [ f f ] over ]]
-        [[ [ f t ] dup  ]]
-    ] reduce-stack-op
-] "kill-node" set-word-prop
+: 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
+    #! node.
+    2dup consumes-literal? [
+        2drop f
+    ] [
+       [
+            node-children dup
+            [ last-node node-in-d >list ] map unify-stacks
+            >list branch-returns set
+            [ can-kill? ] all-with?
+        ] with-scope
+    ] ifte ;
 
-\ pick [ 2drop t ] "can-kill" set-word-prop
-\ pick [
-    [
-        [[ [ f f f ] pick ]]
-        [[ [ f f t ] over ]]
-        [[ [ f t f ] over ]]
-        [[ [ f t t ] dup  ]]
-    ] reduce-stack-op
-] "kill-node" set-word-prop
+! #ifte
+M: #ifte can-kill* ( literal node -- ? )
+    can-kill-branches? ;
 
-\ >r [ 2drop t ] "can-kill" set-word-prop
-\ >r [ kill-node ] "kill-node" set-word-prop
-\ r> [ 2drop t ] "can-kill" set-word-prop
-\ r> [ kill-node ] "kill-node" set-word-prop
+! #dispatch
+M: #dispatch can-kill* ( literal node -- ? )
+    can-kill-branches? ;

diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor
index 5eacf2c3815325c34920a5b9a24cf66795f6babd..daa9281547ebff4834658e96908a6ad9ae3dbdb6 100644 (file)
--- a/library/inference/dataflow.factor
+++ b/library/inference/dataflow.factor
@@ -98,5 +98,16 @@ SYMBOL: current-node
 : node-effect ( node -- [[ d-in meta-d ]] )
     dup node-in-d swap node-out-d cons ;
 
+: consumes-literal? ( literal node -- ? )
+    #! Does the dataflow node consume the literal?
+    2dup node-in-d memq? >r node-in-r memq? r> or ;
+
+: produces-literal? ( literal node -- ? )
+    #! Does the dataflow node produce the literal?
+    2dup node-out-d memq? >r node-out-r memq? r> or ;
+
+: last-node ( node -- last )
+    dup node-successor [ last-node ] [ ] ?ifte ;
+
 ! Recursive state. An alist, mapping words to labels.
 SYMBOL: recursive-state