More accurate escape analysis

unfinished/compiler/tree/escape-analysis/allocations/allocations.factor

@@ -1,13 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs namespaces sequences kernel math combinators sets
-fry stack-checker.state compiler.tree.copy-equiv
+disjoint-sets fry stack-checker.state compiler.tree.copy-equiv ;
-compiler.tree.escape-analysis.graph ;
 IN: compiler.tree.escape-analysis.allocations
 
-SYMBOL: escaping
+! A map from values to sequences of values
-
-! A map from values to sequences of values or 'escaping'
 SYMBOL: allocations
 
 : allocation ( value -- allocation )
@@ -23,35 +20,56 @@ SYMBOL: allocations
 : record-allocations ( allocations values -- )
     [ record-allocation ] 2each ;
 
-: record-slot-access ( out slot# in -- )
+! We track escaping values with a disjoint set.
-    over zero? [ 3drop ] [ allocation ?nth swap is-copy-of ] if ;
+SYMBOL: escaping-values
 
-! We track available values
+SYMBOL: +escaping+
-SYMBOL: slot-graph
+
+: <escaping-values> ( -- disjoint-set )
+    <disjoint-set> +escaping+ over add-atom ;
+
+: init-escaping-values ( -- )
+    copies get <escaping-values>
+    [ '[ drop , add-atom ] assoc-each ]
+    [ '[ , equate ] assoc-each ]
+    [ nip escaping-values set ]
+    2tri ;
+
+: <slot-value> ( -- value )
+    <value>
+    [ introduce-value ]
+    [ escaping-values get add-atom ]
+    [ ]
+    tri ;
+
+: same-value ( in-value out-value -- )
+    over [
+        [ is-copy-of ] [ escaping-values get equate ] 2bi
+    ] [ 2drop ] if ;
+
+: record-slot-access ( out slot# in -- )
+    over zero? [ 3drop ] [ allocation ?nth swap same-value ] if ;
+
+: merge-values ( in-values out-value -- )
+    escaping-values get '[ , , equate ] each ;
 
 : merge-slots ( values -- value )
     dup [ ] contains? [
-        <value>
+        <slot-value> [ merge-values ] keep
-        [ introduce-value ]
-        [ slot-graph get add-edges ]
-        [ ] tri
     ] [ drop f ] if ;
 
-! A disqualified slot value is not available for unboxing. A
+: add-escaping-values ( values -- )
-! tuple may be unboxed if none of its slots have been
+    escaping-values get
-! disqualified.
+    '[ +escaping+ , equate ] each ;
 
-: disqualify ( slot-value -- )
+: escaping-value? ( value -- ? )
-    slot-graph get mark-vertex ;
+    +escaping+ escaping-values get equiv? ;
 
 SYMBOL: escaping-allocations
 
 : compute-escaping-allocations ( -- )
-    #! Any allocations involving unavailable slots are
-    #! potentially escaping, and cannot be unboxed.
     allocations get
-    slot-graph get marked-components
+    [ drop escaping-value? ] assoc-filter
-    '[ [ , key? ] contains? nip ] assoc-filter
     escaping-allocations set ;
 
 : escaping-allocation? ( value -- ? )

unfinished/compiler/tree/escape-analysis/branches/branches.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences sets
+USING: accessors kernel namespaces sequences sets fry
 stack-checker.branches
 compiler.tree
 compiler.tree.propagation.branches
@@ -13,22 +13,21 @@ SYMBOL: children-escape-data
 M: #branch escape-analysis*
     live-children sift [ (escape-analysis) ] each ;
 
-: disqualify-allocations ( allocations -- )
-    [ [ disqualify ] each ] each ;
-
 : (merge-allocations) ( values -- allocation )
     [
-        [ allocation ] map dup [ ] all? [
+        dup [ allocation ] map dup [ ] all? [
             dup [ length ] map all-equal? [
-                flip
+                nip flip
                 [ (merge-allocations) ] [ [ merge-slots ] map ] bi
                 [ record-allocations ] keep
-            ] [ disqualify-allocations f ] if
+            ] [ drop add-escaping-values f ] if
-        ] [ disqualify-allocations f ] if
+        ] [ drop add-escaping-values f ] if
     ] map ;
 
 : merge-allocations ( in-values out-values -- )
-    [ (merge-allocations) ] dip record-allocations ;
+    [ [ merge-values ] 2each ]
+    [ [ (merge-allocations) ] dip record-allocations ]
+    2bi ;
 
 M: #phi escape-analysis*
     [ [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ]

unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -5,10 +5,25 @@ compiler.tree.normalization compiler.tree.copy-equiv
 compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.combinators compiler.tree sequences math
 kernel tools.test accessors slots.private quotations.private
-prettyprint classes.tuple.private ;
+prettyprint classes.tuple.private classes classes.tuple ;
 
 \ escape-analysis must-infer
 
+GENERIC: count-unboxed-allocations* ( m node -- n )
+
+: (count-unboxed-allocations) ( m node -- n )
+    out-d>> first escaping-allocation? [ 1+ ] unless ;
+
+M: #call count-unboxed-allocations*
+    dup word>> \ <tuple-boa> =
+    [ (count-unboxed-allocations) ] [ drop ] if ;
+
+M: #push count-unboxed-allocations*
+    dup literal>> class immutable-tuple-class?
+    [ (count-unboxed-allocations) ] [ drop ] if ;
+
+M: node count-unboxed-allocations* drop ;
+
 : count-unboxed-allocations ( quot -- sizes )
     build-tree
     normalize
@@ -16,14 +31,7 @@ prettyprint classes.tuple.private ;
     propagate
     cleanup
     escape-analysis
-    0 swap [
+    0 swap [ count-unboxed-allocations* ] each-node ;
-        dup #call?
-        [
-            dup word>> \ <tuple-boa> = [
-                out-d>> first escaping-allocation? [ 1+ ] unless
-            ] [ drop ] if
-        ] [ drop ] if
-    ] each-node ;
 
 [ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
 
@@ -128,3 +136,24 @@ TUPLE: cons { car read-only } { cdr read-only } ;
         ] if drop
     ] count-unboxed-allocations
 ] unit-test
+
+[ 2 ] [
+    [
+        [ dup cons boa ] [ drop 1 2 cons boa ] if car>>
+    ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+    [
+        3dup
+        [ cons boa ] [ cons boa 3 cons boa ] if
+        [ car>> ] [ cdr>> ] bi
+    ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+    [
+        3dup [ cons boa ] [ cons boa . 1 2 cons boa ] if
+        [ car>> ] [ cdr>> ] bi
+    ] count-unboxed-allocations
+] unit-test

unfinished/compiler/tree/escape-analysis/escape-analysis.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces search-dequeues
+USING: kernel namespaces search-dequeues assocs fry sequences
+disjoint-sets
 compiler.tree
 compiler.tree.def-use
-compiler.tree.escape-analysis.graph
+compiler.tree.copy-equiv
 compiler.tree.escape-analysis.allocations
 compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.branches
@@ -12,7 +13,7 @@ compiler.tree.escape-analysis.simple ;
 IN: compiler.tree.escape-analysis
 
 : escape-analysis ( node -- node )
+    init-escaping-values
     H{ } clone allocations set
-    <graph> slot-graph set
     dup (escape-analysis)
     compute-escaping-allocations ;

unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor

@@ -1,19 +0,0 @@
-IN: compiler.tree.escape-analysis.graph.tests
-USING: compiler.tree.escape-analysis.graph tools.test namespaces
-accessors ;
-
-<graph> "graph" set
-
-[ ] [ { 2 3 4 } 1 "graph" get add-edges ] unit-test
-[ ] [ { 5 6 } 2 "graph" get add-edges ] unit-test
-[ ] [ { 7 8 } 9 "graph" get add-edges ] unit-test
-[ ] [ { 6 10 } 4 "graph" get add-edges ] unit-test
-
-[ ] [ 3 "graph" get mark-vertex ] unit-test
-
-[ H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 5 } { 6 6 } { 10 10 } } ]
-[ "graph" get marked>> ] unit-test
-
-[ ] [ { 1 11 } 12 "graph" get add-edges ] unit-test
-
-[ t ] [ 11 "graph" get marked-vertex? ] unit-test

unfinished/compiler/tree/escape-analysis/graph/graph.factor

@@ -1,38 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs fry sequences sets
-dequeues search-dequeues namespaces ;
-IN: compiler.tree.escape-analysis.graph
-
-TUPLE: graph edges work-list ;
-
-: <graph> ( -- graph )
-    H{ } clone <hashed-dlist> graph boa ;
-
-: mark-vertex ( vertex graph -- ) work-list>> push-front ;
-
-: add-edge ( out in graph -- )
-    [ edges>> push-at ] [ swapd edges>> push-at ] 3bi ;
-
-: add-edges ( out-seq in graph -- )
-    '[ , , add-edge ] each ;
-
-<PRIVATE
-
-SYMBOL: marked
-
-: (mark-vertex) ( vertex graph -- )
-    over marked get key? [ 2drop ] [
-        [ drop marked get conjoin ]
-        [ [ edges>> at ] [ work-list>> ] bi push-all-front ]
-        2bi
-    ] if ;
-
-PRIVATE>
-
-: marked-components ( graph -- vertices )
-    #! All vertices in connected components of marked vertices.
-    H{ } clone marked [
-        [ work-list>> ] keep
-        '[ , (mark-vertex) ] slurp-dequeue
-    ] with-variable ;

unfinished/compiler/tree/escape-analysis/simple/simple.factor

@@ -2,17 +2,25 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences classes.tuple
 classes.tuple.private math math.private slots.private
-combinators dequeues search-dequeues namespaces fry
+combinators dequeues search-dequeues namespaces fry classes
+stack-checker.state
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.simple
 
+M: #push escape-analysis*
+    #! Delegation.
+    dup literal>> dup class immutable-tuple-class? [
+        tuple-slots length 1- [ <slot-value> ] replicate
+        swap out-d>> first record-allocation
+    ] [ 2drop ] if ;
+
 : record-tuple-allocation ( #call -- )
     #! Delegation.
     dup dup in-d>> peek node-value-info literal>>
-    class>> all-slots rest-slice [ read-only>> ] all? [
+    class>> immutable-tuple-class? [
         [ in-d>> but-last ] [ out-d>> first ] bi
         record-allocation
     ] [ drop ] if ;
@@ -23,9 +31,6 @@ IN: compiler.tree.escape-analysis.simple
     [ in-d>> first ] tri
     over fixnum? [ [ 3 - ] dip record-slot-access ] [ 3drop ] if ;
 
-: add-escaping-values ( values -- )
-    [ allocation [ disqualify ] each ] each ;
-
 M: #call escape-analysis*
     dup word>> {
         { \ <tuple-boa> [ record-tuple-allocation ] }