Working on escape analysis

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

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel math
+USING: assocs namespaces sequences kernel math combinators sets
 stack-checker.state compiler.tree.copy-equiv ;
 IN: compiler.tree.escape-analysis.allocations
 
@@ -13,7 +13,11 @@ SYMBOL: allocations
     resolve-copy allocations get at ;
 
 : record-allocation ( allocation value -- )
-    allocations get set-at ;
+    {
+        { [ dup not ] [ 2drop ] }
+        { [ over not ] [ allocations get delete-at drop ] }
+        [ allocations get set-at ]
+    } cond ;
 
 : record-allocations ( allocations values -- )
     [ record-allocation ] 2each ;
@@ -25,4 +29,20 @@ SYMBOL: allocations
 SYMBOL: slot-merging
 
 : merge-slots ( values -- value )
-    <value> [ introduce-value ] [ slot-merging get set-at ] [ ] tri ;
+    dup [ ] contains? [
+        <value>
+        [ introduce-value ]
+        [ slot-merging get set-at ]
+        [ ] tri
+    ] [ drop f ] if ;
+
+! If an allocation's slot appears in this set, the allocation
+! is disqualified from unboxing.
+SYMBOL: disqualified
+
+: disqualify ( slot-value -- )
+    [ disqualified get conjoin ]
+    [ slot-merging get at [ disqualify ] each ] bi ;
+
+: escaping-allocation? ( value -- ? )
+    allocation [ [ disqualified get key? ] contains? ] [ t ] if* ;

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

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences
+USING: accessors kernel namespaces sequences sets
+stack-checker.branches
 compiler.tree
 compiler.tree.propagation.branches
 compiler.tree.escape-analysis.nodes
@@ -12,6 +13,9 @@ 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? [
@@ -19,8 +23,8 @@ M: #branch escape-analysis*
                 flip
                 [ (merge-allocations) ] [ [ merge-slots ] map ] bi
                 [ record-allocations ] keep
-            ] [ drop f ] if
+            ] [ disqualify-allocations f ] if
-        ] [ drop f ] if
+        ] [ disqualify-allocations f ] if
     ] map ;
 
 : merge-allocations ( in-values out-values -- )

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

@@ -0,0 +1,130 @@
+IN: compiler.tree.escape-analysis.tests
+USING: compiler.tree.escape-analysis
+compiler.tree.escape-analysis.allocations compiler.tree.builder
+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 ;
+
+\ escape-analysis must-infer
+
+: count-unboxed-allocations ( quot -- sizes )
+    build-tree
+    normalize
+    compute-copy-equiv
+    propagate
+    cleanup
+    escape-analysis
+    0 swap [
+        dup #call?
+        [
+            out-d>> dup empty? [ drop ] [
+                first escaping-allocation? [ 1+ ] unless
+            ] if
+        ] [ drop ] if
+    ] each-node ;
+
+[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry drop ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry 3 slot ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry 3 slot drop ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry uncurry ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ [ [ + ] curry ] [ drop [ ] ] if ] count-unboxed-allocations ] unit-test
+
+[ 2 ] [
+    [ [ [ + ] curry ] [ [ * ] curry ] if uncurry ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [ [ [ + ] curry ] [ [ * ] curry ] if ] count-unboxed-allocations
+] unit-test
+
+[ 3 ] [
+    [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if uncurry ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+    [ [ [ + ] curry 4 ] [ dup [ [ * ] curry ] [ [ / ] curry ] if uncurry ] if ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if ] count-unboxed-allocations
+] unit-test
+
+TUPLE: cons { car read-only } { cdr read-only } ;
+
+[ 0 ] [
+    [
+        dup 0 = [
+            2 cons boa
+        ] [
+            dup 1 = [
+                3 cons boa
+            ] when
+        ] if car>>
+    ] count-unboxed-allocations
+] unit-test
+
+[ 3 ] [
+    [
+        dup 0 = [
+            2 cons boa
+        ] [
+            dup 1 = [
+                3 cons boa
+            ] [
+                4 cons boa
+            ] if
+        ] if car>>
+    ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [
+        dup 0 = [
+            dup 1 = [
+                3 cons boa
+            ] [
+                4 cons boa
+            ] if
+        ] unless car>>
+    ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+    [
+        dup 0 = [
+            2 cons boa
+        ] [
+            dup 1 = [
+                3 cons boa
+            ] [
+                4 cons boa
+            ] if car>>
+        ] if
+    ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [
+        dup 0 = [
+            2 cons boa
+        ] [
+            dup 1 = [
+                3 cons boa dup .
+            ] [
+                4 cons boa
+            ] if
+        ] if drop
+    ] count-unboxed-allocations
+] unit-test

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

@@ -14,5 +14,6 @@ IN: compiler.tree.escape-analysis
 : escape-analysis ( node -- node )
     H{ } clone slot-merging set
     H{ } clone allocations set
+    H{ } clone disqualified set
     <hashed-dlist> work-list set
     dup (escape-analysis) ;

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

@@ -24,6 +24,9 @@ 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 ] }