Finishing up with propagation and escape analysis

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

@@ -9,12 +9,11 @@ compiler.tree
 compiler.tree.combinators
 compiler.tree.cleanup
 compiler.tree.builder
-compiler.tree.copy-equiv
 compiler.tree.normalization
 compiler.tree.propagation ;
 
 : cleaned-up-tree ( quot -- nodes )
-    build-tree normalize compute-copy-equiv propagate cleanup ;
+    build-tree normalize propagate cleanup ;
 
 [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
 

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

@@ -7,6 +7,9 @@ compiler.tree.def-use
 compiler.tree.combinators ;
 IN: compiler.tree.copy-equiv
 
+! This is not really a compiler pass; its invoked as part of
+! propagation.
+
 ! Two values are copy-equivalent if they are always identical
 ! at run-time ("DS" relation). This is just a weak form of
 ! value numbering.
@@ -26,8 +29,7 @@ SYMBOL: copies
         ] if
     ] ;
 
-: resolve-copy ( copy -- val )
-    copies get compress-path [ "Unknown value" throw ] unless* ;
+: resolve-copy ( copy -- val ) copies get compress-path ;
 
 : is-copy-of ( val copy -- ) copies get set-at ;
 
@@ -68,13 +70,7 @@ M: #phi compute-copy-equiv*
 
 M: node compute-copy-equiv* drop ;
 
-: amend-copy-equiv ( node -- )
-    [
-        [ node-defs-values [ introduce-value ] each ]
-        [ compute-copy-equiv* ]
-        bi
-    ] each-node ;
-
-: compute-copy-equiv ( node -- node )
-    H{ } clone copies set
-    dup amend-copy-equiv ;
+: compute-copy-equiv ( node -- )
+    [ node-defs-values [ introduce-value ] each ]
+    [ compute-copy-equiv* ]
+    bi ;

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

@@ -28,14 +28,9 @@ C: <slot-access> slot-access
 
 : 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
 
@@ -66,10 +61,21 @@ SYMBOL: +escaping+
 : merge-slots ( values -- value )
     <slot-value> [ merge-values ] keep ;
 
+: add-escaping-value ( value -- )
+    +escaping+ escaping-values get equate ;
+
 : add-escaping-values ( values -- )
     escaping-values get
     '[ +escaping+ , equate ] each ;
 
+: unknown-allocation ( value -- )
+    [ add-escaping-value ]
+    [ t swap record-allocation ]
+    bi ;
+
+: unknown-allocations ( values -- )
+    [ unknown-allocation ] each ;
+
 : escaping-value? ( value -- ? )
     +escaping+ escaping-values get equiv? ;
 

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

@@ -12,7 +12,7 @@ prettyprint classes.tuple.private classes classes.tuple ;
 GENERIC: count-unboxed-allocations* ( m node -- n )
 
 : (count-unboxed-allocations) ( m node -- n )
-    out-d>> first escaping-allocation? [ 1+ ] unless ;
+    dup out-d>> first escaping-allocation? [ drop ] [ short. 1+ ] if ;
 
 M: #call count-unboxed-allocations*
     dup word>> \ <tuple-boa> =
@@ -27,10 +27,8 @@ M: node count-unboxed-allocations* drop ;
 : count-unboxed-allocations ( quot -- sizes )
     build-tree
     normalize
-    compute-copy-equiv
     propagate
     cleanup
-    compute-copy-equiv
     escape-analysis
     0 swap [ count-unboxed-allocations* ] each-node ;
 
@@ -187,3 +185,99 @@ TUPLE: cons { car read-only } { cdr read-only } ;
         1 2 cons boa infinite-cons-loop
     ] count-unboxed-allocations
 ] unit-test
+
+TUPLE: rw-box i ;
+
+C: <rw-box> rw-box
+
+[ 0 ] [ [ <rw-box> i>> ] count-unboxed-allocations ] unit-test
+
+: fake-fib ( m -- n )
+    dup i>> 1 <= [ drop 1 <rw-box> ] when ; inline recursive
+
+[ 0 ] [ [ <rw-box> fake-fib i>> ] count-unboxed-allocations ] unit-test
+
+TUPLE: ro-box { i read-only } ;
+
+C: <ro-box> ro-box
+
+: tuple-fib ( m -- n )
+    dup i>> 1 <= [
+        drop 1 <ro-box>
+    ] [
+        i>> 1- <ro-box>
+        dup tuple-fib
+        swap
+        i>> 1- <ro-box>
+        tuple-fib
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 5 ] [ [ <ro-box> tuple-fib i>> ] count-unboxed-allocations ] unit-test
+
+[ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
+
+: bad-tuple-fib-1 ( m -- n )
+    dup i>> 1 <= [
+        drop 1 <ro-box>
+    ] [
+        i>> 1- <ro-box>
+        dup bad-tuple-fib-1
+        swap
+        i>> 1- <ro-box>
+        bad-tuple-fib-1 dup .
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 3 ] [ [ <ro-box> bad-tuple-fib-1 i>> ] count-unboxed-allocations ] unit-test
+
+: bad-tuple-fib-2 ( m -- n )
+    dup .
+    dup i>> 1 <= [
+        drop 1 <ro-box>
+    ] [
+        i>> 1- <ro-box>
+        dup bad-tuple-fib-2
+        swap
+        i>> 1- <ro-box>
+        bad-tuple-fib-2
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 2 ] [ [ <ro-box> bad-tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
+
+: tuple-fib-2 ( m -- n )
+    dup 1 <= [
+        drop 1 <ro-box>
+    ] [
+        1- dup tuple-fib-2
+        swap
+        1- tuple-fib-2
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 2 ] [ [ tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
+
+: tuple-fib-3 ( m -- n )
+    dup 1 <= [
+        drop 1 <ro-box>
+    ] [
+        1- dup tuple-fib-3
+        swap
+        1- tuple-fib-3 dup .
+        swap i>> swap i>> + <ro-box>
+    ] if ; inline recursive
+
+[ 0 ] [ [ tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
+
+: bad-tuple-fib-3 ( m -- n )
+    dup 1 <= [
+        drop 1 <ro-box>
+    ] [
+        1- dup bad-tuple-fib-3
+        swap
+        1- bad-tuple-fib-3
+        2drop f
+    ] if ; inline recursive
+
+[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test

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

@@ -4,7 +4,6 @@ USING: kernel namespaces search-dequeues assocs fry sequences
 disjoint-sets
 compiler.tree
 compiler.tree.def-use
-compiler.tree.copy-equiv
 compiler.tree.escape-analysis.allocations
 compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.branches

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

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences math combinators accessors namespaces
+fry disjoint-sets
 compiler.tree
-compiler.tree.copy-equiv
 compiler.tree.combinators
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.branches
@@ -17,9 +17,10 @@ IN: compiler.tree.escape-analysis.recursive
         [ [ [ allocation ] bi@ congruent? ] 2all? ]
     } cond ;
 
-: check-fixed-point ( node alloc1 alloc2 -- node )
-    [ congruent? ] 2all?
-    [ dup label>> f >>fixed-point drop ] unless ; inline
+: check-fixed-point ( node alloc1 alloc2 -- )
+    [ congruent? ] 2all? [ drop ] [
+        label>> f >>fixed-point drop
+    ] if ;
 
 : node-input-allocations ( node -- allocations )
     in-d>> [ allocation ] map ;
@@ -35,31 +36,26 @@ IN: compiler.tree.escape-analysis.recursive
     [ [ merge-values ] 2each ]
     [
         [ (merge-allocations) ] dip
-        [ [ allocation ] map check-fixed-point drop ]
+        [ [ allocation ] map check-fixed-point ]
         [ record-allocations ]
         2bi
     ] 2bi ;
 
 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 ;
+: return-allocations ( node -- allocations )
+    label>> return>> node-input-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 ;
+M: #call-recursive escape-analysis* ( #call-label -- )
+    [ ] [ return-allocations ] [ node-output-allocations ] tri
+    [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
+
+M: #return-recursive escape-analysis* ( #return-recursive -- )
+    [ in-d>> ] [ label>> calls>> ] bi
+    [ out-d>> escaping-values get '[ , equate ] 2each ] with each ;

unfinished/compiler/tree/normalization/normalization.factor

@@ -128,6 +128,10 @@ M: #recursive normalize*
     dup dup label>> introductions>>
     eliminate-recursive-introductions ;
 
+M: #enter-recursive normalize*
+    dup [ label>> ] keep >>enter-recursive drop
+    dup [ label>> ] [ out-d>> ] bi >>enter-out drop ;
+
 : unchanged-underneath ( #call-recursive -- n )
     [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
 

unfinished/compiler/tree/optimizer/optimizer.factor

@@ -9,7 +9,6 @@ IN: compiler.tree.optimizer
 
 : optimize-tree ( nodes -- nodes' )
     normalize
-    compute-copy-equiv
     propagate
     cleanup
     compute-def-use

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

@@ -90,7 +90,7 @@ M: #phi propagate-before ( #phi -- )
             [
                 drop condition-value get
                 [ [ =t ] [ =t ] bi* <--> ]
-                [ [ =f ] [ =f ] bi* <--> ] 2bi /\ assume
+                [ [ =f ] [ =f ] bi* <--> ] 2bi /\
             ]
         }
         {
@@ -98,19 +98,43 @@ M: #phi propagate-before ( #phi -- )
             [
                 drop condition-value get
                 [ [ =t ] [ =f ] bi* <--> ]
-                [ [ =f ] [ =t ] bi* <--> ] 2bi /\ assume
+                [ [ =f ] [ =t ] bi* <--> ] 2bi /\
             ]
         }
         {
             { { t f } { f } }
-            [ first =t condition-value get =t /\ swap t--> assume ]
+            [
+                first =t
+                condition-value get =t /\
+                swap t-->
+            ]
         }
         {
             { { f } { t f } }
-            [ second =t condition-value get =f /\ swap t--> assume ]
+            [
+                second =t
+                condition-value get =f /\
+                swap t-->
+            ]
         }
-        [ 3drop ]
-    } case ;
+        ! {
+        !     { { t f } { } }
+        !     [ B
+        !         first
+        !         [ [ =t ] bi@ <--> ]
+        !         [ [ =f ] bi@ <--> ] 2bi /\
+        !     ]
+        ! }
+        ! {
+        !     { { } { t f } }
+        !     [
+        !         second
+        !         [ [ =t ] bi@ <--> ]
+        !         [ [ =f ] bi@ <--> ] 2bi /\
+        !     ]
+        ! }
+        [ 3drop f ]
+    } case assume ;
 
 M: #phi propagate-after ( #phi -- )
     condition-value get [

unfinished/compiler/tree/propagation/info/info.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs classes classes.algebra kernel
 accessors math math.intervals namespaces sequences words
-combinators arrays compiler.tree.copy-equiv ;
+combinators combinators.short-circuit arrays
+compiler.tree.copy-equiv ;
 IN: compiler.tree.propagation.info
 
 : false-class? ( class -- ? ) \ f class<= ;
@@ -218,6 +219,28 @@ DEFER: (value-info-union)
     [ drop null-info ]
     [ dup first [ value-info-union ] reduce ] if ;
 
+: literals<= ( info1 info2 -- ? )
+    {
+        { [ dup literal?>> not ] [ 2drop t ] }
+        { [ over literal?>> not ] [ 2drop f ] }
+        [ [ literal>> ] bi@ eql? ]
+    } cond ;
+
+: value-info<= ( info1 info2 -- ? )
+    {
+        { [ dup not ] [ 2drop t ] }
+        { [ over not ] [ 2drop f ] }
+        [
+            {
+                [ [ class>> ] bi@ class<= ]
+                [ [ interval>> ] bi@ interval-subset? ]
+                [ literals<= ]
+                [ [ length>> ] bi@ value-info<= ]
+                [ [ slots>> ] bi@ [ value-info<= ] 2all? ]
+            } 2&&
+        ]
+    } cond ;
+
 ! Current value --> info mapping
 SYMBOL: value-infos
 

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

@@ -6,7 +6,6 @@ classes.union sets quotations assocs combinators words
 namespaces
 compiler.tree
 compiler.tree.builder
-compiler.tree.copy-equiv
 compiler.tree.normalization
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes ;
@@ -25,7 +24,7 @@ M: quotation splicing-nodes
     normalize ;
 
 : propagate-body ( #call -- )
-    body>> [ amend-copy-equiv ] [ (propagate) ] bi ;
+    body>> (propagate) ;
 
 ! Dispatch elimination
 : eliminate-dispatch ( #call word/quot/f -- ? )

unfinished/compiler/tree/propagation/nodes/nodes.factor

@@ -3,6 +3,7 @@
 USING: sequences accessors kernel assocs sequences
 compiler.tree
 compiler.tree.def-use
+compiler.tree.copy-equiv
 compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.nodes
 
@@ -15,7 +16,8 @@ GENERIC: propagate-after ( node -- )
 
 GENERIC: propagate-around ( node -- )
 
-: (propagate) ( node -- ) [ propagate-around ] each ;
+: (propagate) ( node -- )
+    [ [ compute-copy-equiv ] [ propagate-around ] bi ] each ;
 
 : extract-value-info ( values -- assoc )
     [ dup value-info ] H{ } map>assoc ;

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

@@ -1,5 +1,5 @@
 USING: kernel compiler.tree.builder compiler.tree
-compiler.tree.propagation compiler.tree.copy-equiv
+compiler.tree.propagation
 compiler.tree.normalization tools.test math math.order
 accessors sequences arrays kernel.private vectors
 alien.accessors alien.c-types sequences.private
@@ -14,7 +14,6 @@ IN: compiler.tree.propagation.tests
 : final-info ( quot -- seq )
     build-tree
     normalize
-    compute-copy-equiv
     propagate
     peek node-input-infos ;
 
@@ -145,6 +144,8 @@ IN: compiler.tree.propagation.tests
     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ] unit-test
 
+[ f ] [ [ t xor ] final-classes first null-class? ] unit-test
+
 [ t ] [ [ t or ] final-classes first true-class? ] unit-test
 
 [ t ] [ [ t swap or ] final-classes first true-class? ] unit-test
@@ -155,12 +156,20 @@ IN: compiler.tree.propagation.tests
 
 [ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
 
+[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
+
 [ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
 
+[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
+
 [ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
 
+[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
+
 [ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
 
+[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
+
 [ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
 
 [ V{ fixnum } ] [

unfinished/compiler/tree/propagation/propagation.factor

@@ -3,6 +3,7 @@
 USING: accessors kernel sequences namespaces hashtables
 compiler.tree
 compiler.tree.def-use
+compiler.tree.copy-equiv
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
@@ -13,8 +14,7 @@ compiler.tree.propagation.known-words ;
 IN: compiler.tree.propagation
 
 : propagate ( node -- node )
-    [
-        H{ } clone constraints set
-        H{ } clone value-infos set
-        dup (propagate)
-    ] with-scope ;
+    H{ } clone copies set
+    H{ } clone constraints set
+    H{ } clone value-infos set
+    dup (propagate) ;

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

@@ -13,8 +13,9 @@ compiler.tree.propagation.branches
 compiler.tree.propagation.constraints ;
 IN: compiler.tree.propagation.recursive
 
-: check-fixed-point ( node infos1 infos2 -- node )
-    sequence= [ dup label>> f >>fixed-point drop ] unless ; inline
+: check-fixed-point ( node infos1 infos2 -- )
+    [ value-info<= ] 2all?
+    [ drop ] [ label>> f >>fixed-point drop ] if ;
 
 : recursive-stacks ( #enter-recursive -- stacks initial )
     [ label>> calls>> [ node-input-infos ] map flip ]
@@ -46,19 +47,21 @@ IN: compiler.tree.propagation.recursive
 
 : propagate-recursive-phi ( #enter-recursive -- )
     [ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
-    [ node-output-infos check-fixed-point drop ] 2keep
-    out-d>> set-value-infos ;
+    [ node-output-infos check-fixed-point ]
+    [ out-d>> set-value-infos drop ]
+    3bi ;
 
 M: #recursive propagate-around ( #recursive -- )
-    [
-        copies [ clone ] change
+    { 0 } clone [ USE: math
+        dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
         constraints [ clone ] change
 
         child>>
+        [ first compute-copy-equiv ]
         [ first propagate-recursive-phi ]
         [ (propagate) ]
-        bi
-    ] until-fixed-point ;
+        tri
+    ] curry until-fixed-point ;
 
 : generalize-return-interval ( info -- info' )
     dup [ literal?>> ] [ class>> null-class? ] bi or
@@ -67,11 +70,9 @@ M: #recursive propagate-around ( #recursive -- )
 : generalize-return ( infos -- infos' )
     [ generalize-return-interval ] map ;
 
-M: #call-recursive propagate-before ( #call-label -- )
-    dup [ node-output-infos ] [ label>> return>> node-input-infos ] bi
-    [ check-fixed-point ] keep
-    generalize-return swap out-d>> set-value-infos ;
+: return-infos ( node -- infos )
+    label>> return>> node-input-infos generalize-return ;
 
-M: #return-recursive propagate-before ( #return-recursive -- )
-    dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi
-    check-fixed-point drop ;
+M: #call-recursive propagate-before ( #call-label -- )
+    [ ] [ return-infos ] [ node-output-infos ] tri
+    [ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;

unfinished/stack-checker/inlining/inlining.factor

@@ -17,7 +17,12 @@ IN: stack-checker.inlining
 : (inline-word) ( word label -- )
     [ [ def>> ] keep ] dip infer-quot-recursive ;
 
-TUPLE: inline-recursive word enter-out return calls fixed-point introductions ;
+TUPLE: inline-recursive
+word
+enter-out enter-recursive
+return calls
+fixed-point
+introductions ;
 
 : <inline-recursive> ( word -- label )
     inline-recursive new swap >>word ;