Working on recursive escape analysis

unfinished/compiler/tree/copy-equiv/copy-equiv.factor

@@ -8,7 +8,8 @@ compiler.tree.combinators ;
 IN: compiler.tree.copy-equiv
 
 ! Two values are copy-equivalent if they are always identical
-! at run-time ("DS" relation).
+! at run-time ("DS" relation). This is just a weak form of
+! value numbering.
 
 ! Mapping from values to their canonical leader
 SYMBOL: copies
@@ -25,7 +26,8 @@ SYMBOL: copies
         ] if
     ] ;
 
-: resolve-copy ( copy -- val ) copies get compress-path ;
+: resolve-copy ( copy -- val )
+    copies get compress-path [ "Unknown value" throw ] unless* ;
 
 : is-copy-of ( val copy -- ) copies get set-at ;
 
@@ -55,7 +57,7 @@ M: #return-recursive compute-copy-equiv*
     #! An output is a copy of every input if all inputs are
     #! copies of the same original value.
     [
-        swap [ resolve-copy ] map sift
+        swap sift [ resolve-copy ] map
         dup [ all-equal? ] [ empty? not ] bi and
         [ first swap is-copy-of ] [ 2drop ] if
     ] 2each ;

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

@@ -1,26 +1,41 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel math combinators sets
-disjoint-sets fry stack-checker.state compiler.tree.copy-equiv ;
+USING: accessors assocs namespaces sequences kernel math
+combinators sets disjoint-sets fry stack-checker.state
+compiler.tree.copy-equiv ;
 IN: compiler.tree.escape-analysis.allocations
 
 ! A map from values to one of the following:
 ! - f -- initial status, assigned to values we have not seen yet;
 !        may potentially become an allocation later
 ! - a sequence of values -- potentially unboxed tuple allocations
-! - t -- not allocated locally, can never be unboxed
+! - t -- not allocated in this procedure, can never be unboxed
 
 SYMBOL: allocations
 
-: (allocation) resolve-copy allocations get ; inline
+TUPLE: slot-access slot# value ;
 
-: allocation ( value -- allocation ) (allocation) at ;
+C: <slot-access> slot-access
+
+: (allocation) ( value -- value' allocations )
+    resolve-copy allocations get ; inline
+
+: allocation ( value -- allocation )
+    (allocation) at dup slot-access? [
+        [ slot#>> ] [ value>> allocation ] bi nth
+        allocation
+    ] when ;
 
 : record-allocation ( allocation value -- ) (allocation) set-at ;
 
+: unknown-allocation ( value -- ) t swap record-allocation ;
+
 : record-allocations ( allocations values -- )
     [ record-allocation ] 2each ;
 
+: unknown-allocations ( values -- )
+    [ unknown-allocation ] each ;
+
 ! We track escaping values with a disjoint set.
 SYMBOL: escaping-values
 
@@ -40,21 +55,16 @@ SYMBOL: +escaping+
     [ ]
     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 ;
+    over zero? [ 3drop ] [
+        <slot-access> swap record-allocation
+    ] if ;
 
 : merge-values ( in-values out-value -- )
     escaping-values get '[ , , equate ] each ;
 
 : merge-slots ( values -- value )
-    dup [ ] contains? [
-        <slot-value> [ merge-values ] keep
-    ] [ drop f ] if ;
+    <slot-value> [ merge-values ] keep ;
 
 : add-escaping-values ( values -- )
     escaping-values get

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

@@ -13,16 +13,19 @@ M: #branch escape-analysis*
 
 : (merge-allocations) ( values -- allocation )
     [
-        dup [ allocation ] map dup [ ] all? [
-            dup [ length ] map all-equal? [
-                nip flip
-                [ (merge-allocations) ] [ [ merge-slots ] map ] bi
-                [ record-allocations ] keep
-            ] [ drop add-escaping-values f ] if
-        ] [ drop add-escaping-values f ] if
+        dup [ allocation ] map sift dup empty? [ 2drop f ] [
+            dup [ t eq? not ] all? [
+                dup [ length ] map all-equal? [
+                    nip flip
+                    [ (merge-allocations) ] [ [ merge-slots ] map ] bi
+                    [ record-allocations ] keep
+                ] [ drop add-escaping-values t ] if
+            ] [ drop add-escaping-values t ] if
+        ] if
     ] map ;
 
 : merge-allocations ( in-values out-values -- )
+    [ [ sift ] map ] dip
     [ [ merge-values ] 2each ]
     [ [ (merge-allocations) ] dip record-allocations ]
     2bi ;

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

@@ -30,6 +30,7 @@ M: node count-unboxed-allocations* drop ;
     compute-copy-equiv
     propagate
     cleanup
+    compute-copy-equiv
     escape-analysis
     0 swap [ count-unboxed-allocations* ] each-node ;
 
@@ -157,3 +158,32 @@ TUPLE: cons { car read-only } { cdr read-only } ;
         [ car>> ] [ cdr>> ] bi
     ] count-unboxed-allocations
 ] unit-test
+
+[ 1 ] [
+    [ [ 3 cons boa ] [ "A" throw ] if car>> ]
+    count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [ 10 [ drop ] each-integer ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+    [
+        1 2 cons boa 10 [ 2drop 1 2 cons boa ] each-integer car>>
+    ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [
+        1 2 cons boa 10 [ drop 2 cons boa ] each-integer car>>
+    ] count-unboxed-allocations
+] unit-test
+
+: infinite-cons-loop ( a -- b ) 2 cons boa infinite-cons-loop ; inline recursive
+
+[ 0 ] [
+    [
+        1 2 cons boa infinite-cons-loop
+    ] count-unboxed-allocations
+] unit-test

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

@@ -10,12 +10,16 @@ compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.recursive
 
 : congruent? ( alloc1 alloc2 -- ? )
-    2dup [ length ] bi@ = [
-        [ [ allocation ] bi@ congruent? ] 2all?
-    ] [ 2drop f ] if ;
+    {
+        { [ 2dup [ f eq? ] either? ] [ eq? ] }
+        { [ 2dup [ t eq? ] either? ] [ eq? ] }
+        { [ 2dup [ length ] bi@ = not ] [ 2drop f ] }
+        [ [ [ allocation ] bi@ congruent? ] 2all? ]
+    } cond ;
 
 : check-fixed-point ( node alloc1 alloc2 -- node )
-    congruent? [ dup label>> f >>fixed-point drop ] unless ; inline
+    [ congruent? ] 2all?
+    [ dup label>> f >>fixed-point drop ] unless ; inline
 
 : node-input-allocations ( node -- allocations )
     in-d>> [ allocation ] map ;
@@ -27,13 +31,18 @@ IN: compiler.tree.escape-analysis.recursive
     [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
 
 : analyze-recursive-phi ( #enter-recursive -- )
-    [ ] [ recursive-stacks flip (merge-allocations) ] [ out-d>> ] tri
-    [ [ allocation ] map check-fixed-point drop ] 2keep
-    record-allocations ;
+    [ ] [ recursive-stacks flip ] [ out-d>> ] tri
+    [ [ merge-values ] 2each ]
+    [
+        [ (merge-allocations) ] dip
+        [ [ allocation ] map check-fixed-point drop ]
+        [ record-allocations ]
+        2bi
+    ] 2bi ;
 
 M: #recursive escape-analysis* ( #recursive -- )
     [
-        copies [ clone ] change
+        ! copies [ clone ] change
 
         child>>
         [ first analyze-recursive-phi ]

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

@@ -10,12 +10,21 @@ compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.simple
 
+M: #introduce escape-analysis*
+    value>> unknown-allocation ;
+
+: record-literal-allocation ( value object -- )
+    dup class immutable-tuple-class? [
+        tuple-slots rest-slice
+        [ <slot-value> [ swap record-literal-allocation ] keep ] map
+        swap record-allocation
+    ] [
+        drop unknown-allocation
+    ] if ;
+
 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 ;
+    [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
 
 : record-tuple-allocation ( #call -- )
     #! Delegation.
@@ -23,19 +32,27 @@ M: #push escape-analysis*
     class>> immutable-tuple-class? [
         [ in-d>> but-last ] [ out-d>> first ] bi
         record-allocation
-    ] [ drop ] if ;
+    ] [ out-d>> unknown-allocations ] if ;
 
 : record-slot-call ( #call -- )
     [ out-d>> first ]
     [ dup in-d>> second node-value-info literal>> ]
     [ in-d>> first ] tri
-    over fixnum? [ [ 3 - ] dip record-slot-access ] [ 3drop ] if ;
+    over fixnum? [
+        [ 3 - ] dip record-slot-access
+    ] [
+        2drop unknown-allocation
+    ] if ;
 
 M: #call escape-analysis*
     dup word>> {
         { \ <tuple-boa> [ record-tuple-allocation ] }
         { \ slot [ record-slot-call ] }
-        [ drop in-d>> add-escaping-values ]
+        [
+            drop
+            [ in-d>> add-escaping-values ]
+            [ out-d>> unknown-allocations ] bi
+        ]
     } case ;
 
 M: #return escape-analysis*

unfinished/compiler/tree/propagation/branches/branches.factor

@@ -59,7 +59,7 @@ SYMBOL: infer-children-data
 
 : compute-phi-input-infos ( phi-in -- phi-info )
     infer-children-data get
-    '[ , [ [ value-info ] bind ] 2map ] map ;
+    '[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ;
 
 : annotate-phi-inputs ( #phi -- )
     dup phi-in-d>> compute-phi-input-infos >>phi-info-d