Start work on escape analysis pass

unfinished/compiler/tree/combinators/combinators.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry kernel accessors sequences sequences.deep arrays
-compiler.tree ;
+stack-checker.inlining namespaces compiler.tree ;
 IN: compiler.tree.combinators
 
 : each-node ( nodes quot: ( node -- ) -- )
@@ -50,3 +50,8 @@ IN: compiler.tree.combinators
 : 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
 
 : 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
+
+: until-fixed-point ( #recursive quot -- )
+    over label>> t >>fixed-point drop
+    [ with-scope ] 2keep
+    over label>> fixed-point>> [ 2drop ] [ until-fixed-point ] if ; inline

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

@@ -0,0 +1,28 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs namespaces sequences kernel math
+stack-checker.state compiler.tree.copy-equiv ;
+IN: compiler.tree.escape-analysis.allocations
+
+SYMBOL: escaping
+
+! A map from values to sequences of values or 'escaping'
+SYMBOL: allocations
+
+: allocation ( value -- allocation )
+    resolve-copy allocations get at ;
+
+: record-allocation ( allocation value -- )
+    allocations get set-at ;
+
+: record-allocations ( allocations values -- )
+    [ record-allocation ] 2each ;
+
+: record-slot-access ( out slot# in -- )
+    over zero? [ 3drop ] [ allocation ?nth swap is-copy-of ] if ;
+
+! A map from values to sequences of values
+SYMBOL: slot-merging
+
+: merge-slots ( values -- value )
+    <value> [ introduce-value ] [ slot-merging get set-at ] [ ] tri ;

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

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

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

@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces search-dequeues
+compiler.tree
+compiler.tree.def-use
+compiler.tree.escape-analysis.allocations
+compiler.tree.escape-analysis.recursive
+compiler.tree.escape-analysis.branches
+compiler.tree.escape-analysis.nodes
+compiler.tree.escape-analysis.simple
+compiler.tree.escape-analysis.work-list ;
+IN: compiler.tree.escape-analysis
+
+: escape-analysis ( node -- node )
+    H{ } clone slot-merging set
+    H{ } clone allocations set
+    <hashed-dlist> work-list set
+    dup (escape-analysis) ;

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

@@ -0,0 +1,10 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences compiler.tree ;
+IN: compiler.tree.escape-analysis.nodes
+
+GENERIC: escape-analysis* ( node -- )
+
+M: node escape-analysis* drop ;
+
+: (escape-analysis) ( node -- ) [ escape-analysis* ] each ;

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

@@ -0,0 +1,16 @@
+IN: compiler.tree.escape-analysis.recursive.tests
+USING: kernel tools.test namespaces sequences
+compiler.tree.copy-equiv
+compiler.tree.escape-analysis.recursive
+compiler.tree.escape-analysis.allocations ;
+
+H{ } clone allocations set
+H{ } clone copies set
+
+[ ] [ 8 [ introduce-value ] each ] unit-test
+
+[ ] [ { 1 2 } 3 record-allocation ] unit-test
+
+[ t ] [ { 1 2 } { 6 7 } congruent? ] unit-test
+[ f ] [ { 3 4 } { 6 7 } congruent? ] unit-test
+[ f ] [ { 3 4 5 } { 6 7 } congruent? ] unit-test

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

@@ -0,0 +1,56 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences math combinators accessors namespaces
+compiler.tree
+compiler.tree.copy-equiv
+compiler.tree.combinators
+compiler.tree.escape-analysis.nodes
+compiler.tree.escape-analysis.branches
+compiler.tree.escape-analysis.allocations ;
+IN: compiler.tree.escape-analysis.recursive
+
+: congruent? ( alloc1 alloc2 -- ? )
+    2dup [ length ] bi@ = [
+        [ [ allocation ] bi@ congruent? ] 2all?
+    ] [ 2drop f ] if ;
+
+: check-fixed-point ( node alloc1 alloc2 -- node )
+    congruent? [ dup label>> f >>fixed-point drop ] unless ; inline
+
+: node-input-allocations ( node -- allocations )
+    in-d>> [ allocation ] map ;
+
+: node-output-allocations ( node -- allocations )
+    out-d>> [ allocation ] map ;
+
+: recursive-stacks ( #enter-recursive -- stacks )
+    [ 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 ;
+
+M: #recursive escape-analysis* ( #recursive -- )
+    [
+        copies [ clone ] change
+
+        child>>
+        [ first analyze-recursive-phi ]
+        [ (escape-analysis) ]
+        bi
+    ] until-fixed-point ;
+
+M: #call-recursive escape-analysis* ( #call-label -- )
+    dup
+    [ node-output-allocations ]
+    [ label>> return>> node-input-allocations ] bi
+    [ check-fixed-point ] keep
+    swap out-d>> record-allocations ;
+
+! M: #return-recursive escape-analysis* ( #return-recursive -- )
+!     dup dup label>> calls>> dup empty? [ 3drop ] [
+!         [ node-input-allocations ]
+!         [ first node-output-allocations ] bi*
+!         check-fixed-point drop
+!     ] if ;

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

@@ -0,0 +1,35 @@
+! Copyright (C) 2008 Slava Pestov.
+! 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
+compiler.tree
+compiler.tree.propagation.info
+compiler.tree.escape-analysis.nodes
+compiler.tree.escape-analysis.work-list
+compiler.tree.escape-analysis.allocations ;
+IN: compiler.tree.escape-analysis.simple
+
+: record-tuple-allocation ( #call -- )
+    #! Delegation.
+    dup dup in-d>> peek node-value-info literal>>
+    class>> all-slots rest-slice [ read-only>> ] all? [
+        [ in-d>> but-last ] [ out-d>> first ] bi
+        record-allocation
+    ] [ drop ] 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 ;
+
+M: #call escape-analysis*
+    dup word>> {
+        { \ <tuple-boa> [ record-tuple-allocation ] }
+        { \ slot [ record-slot-call ] }
+        [ drop in-d>> add-escaping-values ]
+    } case ;
+
+M: #return escape-analysis*
+    in-d>> add-escaping-values ;

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

@@ -0,0 +1,9 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: dequeues namespaces sequences fry ;
+IN: compiler.tree.escape-analysis.work-list
+
+SYMBOL: work-list
+
+: add-escaping-values ( values -- )
+    work-list get '[ , push-front ] each ;

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

@@ -43,18 +43,17 @@ SYMBOL: infer-children-data
     value-infos [ clone ] change
     constraints [ clone ] change ;
 
+: no-value-info ( -- )
+    value-infos off
+    constraints off ;
+
 : infer-children ( node -- )
     [ live-children ] [ child-constraints ] bi [
         [
-            over [
-                copy-value-info
-                assume
-                (propagate)
-            ] [
-                2drop
-                value-infos off
-                constraints off
-            ] if
+            over
+            [ copy-value-info assume (propagate) ]
+            [ 2drop no-value-info ]
+            if
         ] H{ } make-assoc
     ] 2map infer-children-data set ;
 

unfinished/compiler/tree/propagation/inlining/inlining.factor

@@ -142,3 +142,8 @@ SYMBOL: history
 
 : inline-method-body ( #call word -- ? )
     2dup should-inline? [ inline-word t ] [ 2drop f ] if ;
+
+: always-inline-word? ( word -- ? )
+    { curry compose } memq? ;
+
+: always-inline-word ( #call word -- ? ) inline-word t ;

unfinished/compiler/tree/propagation/propagation-tests.factor

@@ -325,7 +325,7 @@ cell-bits 32 = [
 [ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test
 
 [ V{ 10 } ] [
-    [ { fixnum } declare dup 10 = [ "A" throw ] unless ] final-literals
+    [ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals
 ] unit-test
 
 ! Slot propagation

unfinished/compiler/tree/propagation/recursive/recursive.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors arrays fry math.intervals
-combinators
+combinators namespaces
 stack-checker.inlining
 compiler.tree
 compiler.tree.copy-equiv
+compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
@@ -48,28 +49,20 @@ IN: compiler.tree.propagation.recursive
     [ node-output-infos check-fixed-point drop ] 2keep
     out-d>> set-value-infos ;
 
-USING: namespaces math ;
-SYMBOL: iter-counter
-0 iter-counter set-global
 M: #recursive propagate-around ( #recursive -- )
-    iter-counter inc
-    iter-counter get 10 > [ "Oops" throw ] when
-    dup label>> t >>fixed-point drop [
-        [
-            copies [ clone ] change
-            constraints [ clone ] change
+    [
+        copies [ clone ] change
+        constraints [ clone ] change
 
-            child>>
-            [ first propagate-recursive-phi ]
-            [ (propagate) ]
-            bi
-        ] with-scope
-    ] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ;
+        child>>
+        [ first propagate-recursive-phi ]
+        [ (propagate) ]
+        bi
+    ] until-fixed-point ;
 
 : generalize-return-interval ( info -- info' )
-    dup [ literal?>> ] [ class>> null-class? ] bi or [
-        clone [-inf,inf] >>interval
-    ] unless ;
+    dup [ literal?>> ] [ class>> null-class? ] bi or
+    [ clone [-inf,inf] >>interval ] unless ;
 
 : generalize-return ( infos -- infos' )
     [ generalize-return-interval ] map ;

unfinished/compiler/tree/propagation/simple/simple.factor

@@ -94,6 +94,7 @@ M: #declare propagate-before
 
 : do-inlining ( #call word -- ? )
     {
+        { [ dup always-inline-word? ] [ always-inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }
         { [ dup math-partial? ] [ inline-math-partial ] }

unfinished/compiler/tree/propagation/slots/slots.factor

@@ -29,7 +29,7 @@ UNION: fixed-length-sequence array byte-array string ;
     bi* value-info-intersect 1array ;
 
 : tuple-constructor? ( word -- ? )
-    { <tuple-boa> curry compose <complex> } memq? ;
+    { <tuple-boa> <complex> } memq? ;
 
 : read-only-slots ( values class -- slots )
     #! Delegation.
@@ -54,20 +54,12 @@ UNION: fixed-length-sequence array byte-array string ;
     in-d>> unclip-last
     value-info literal>> class>> (propagate-tuple-constructor) ;
 
-: propagate-curry ( #call -- info )
-    in-d>> \ curry (propagate-tuple-constructor) ;
-
-: propagate-compose ( #call -- info )
-    in-d>> \ compose (propagate-tuple-constructor) ;
-
 : propagate-<complex> ( #call -- info )
     in-d>> [ value-info ] map complex <tuple-info> ;
 
 : propagate-tuple-constructor ( #call word -- infos )
     {
         { \ <tuple-boa> [ propagate-<tuple-boa> ] }
-        { \ curry [ propagate-curry ] }
-        { \ compose [ propagate-compose ] } 
         { \ <complex> [ propagate-<complex> ] }
     } case 1array ;