From f86fbccfb05abca627614968585dd45dd25c033f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 1 Aug 2008 20:00:12 -0500
Subject: [PATCH 1/4] Fixing copy-equiv

---
 .../tree/copy-equiv/copy-equiv-tests.factor   | 25 +++++++++++++++
 .../tree/copy-equiv/copy-equiv.factor         | 32 +++++++++++++------
 2 files changed, 48 insertions(+), 9 deletions(-)
 create mode 100644 unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor

diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor
new file mode 100644
index 0000000000..251c4d40d2
--- /dev/null
+++ b/unfinished/compiler/tree/copy-equiv/copy-equiv-tests.factor
@@ -0,0 +1,25 @@
+IN: compiler.tree.copy-equiv.tests
+USING: compiler.tree.copy-equiv tools.test namespaces kernel
+assocs ;
+
+H{ } clone copies set
+
+[ ] [ 0 introduce-value ] unit-test
+[ ] [ 1 introduce-value ] unit-test
+[ ] [ 1 2 is-copy-of ] unit-test
+[ ] [ 2 3 is-copy-of ] unit-test
+[ ] [ 2 4 is-copy-of ] unit-test
+[ ] [ 4 5 is-copy-of ] unit-test
+[ ] [ 0 6 is-copy-of ] unit-test
+
+[ 0 ] [ 0 resolve-copy ] unit-test
+[ 1 ] [ 5 resolve-copy ] unit-test
+
+! Make sure that we did path compression
+[ 1 ] [ 5 copies get at ] unit-test
+
+[ 1 ] [ 1 resolve-copy ] unit-test
+[ 1 ] [ 2 resolve-copy ] unit-test
+[ 1 ] [ 3 resolve-copy ] unit-test
+[ 1 ] [ 4 resolve-copy ] unit-test
+[ 0 ] [ 6 resolve-copy ] unit-test
diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
index bd3375a78d..bf5b47c9b1 100644
--- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
+++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor
@@ -1,23 +1,37 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces disjoint-sets sequences assocs math
-kernel accessors fry
-compiler.tree compiler.tree.def-use compiler.tree.combinators ;
+USING: namespaces sequences assocs math kernel accessors fry
+combinators sets locals
+compiler.tree
+compiler.tree.def-use
+compiler.tree.combinators ;
 IN: compiler.tree.copy-equiv
 
 ! Two values are copy-equivalent if they are always identical
 ! at run-time ("DS" relation).
 
-! Disjoint set of copy equivalence
+! Mapping from values to their canonical leader
 SYMBOL: copies
 
-: is-copy-of ( val copy -- ) copies get equate ;
+:: compress-path ( source assoc -- destination )
+    [let | destination [ source assoc at ] |
+        source destination = [ source ] [
+            [let | destination' [ destination assoc compress-path ] |
+                destination' destination = [
+                    destination' source assoc set-at
+                ] unless
+                destination'
+            ]
+        ] if
+    ] ;
+
+: resolve-copy ( copy -- val ) copies get compress-path ;
+
+: is-copy-of ( val copy -- ) copies get set-at ;
 
 : are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
 
-: resolve-copy ( copy -- val ) copies get representative ;
-
-: introduce-value ( val -- ) copies get add-atom ;
+: introduce-value ( val -- ) copies get conjoin ;
 
 GENERIC: compute-copy-equiv* ( node -- )
 
@@ -60,5 +74,5 @@ M: node compute-copy-equiv* drop ;
     ] each-node ;
 
 : compute-copy-equiv ( node -- node )
-    <disjoint-set> copies set
+    H{ } clone copies set
     dup amend-copy-equiv ;

From 97871d40639e23941cd363b89d003331a7f1c607 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 1 Aug 2008 20:04:36 -0500
Subject: [PATCH 2/4] Fix problem with terminating branches; normalize always
 pushes #introduce to the front

---
 .../tree/combinators/combinators.factor       |  8 ++-
 .../tree/normalization/normalization.factor   | 51 ++++++++++++-------
 unfinished/compiler/tree/tree.factor          |  5 +-
 .../stack-checker/branches/branches.factor    | 10 +++-
 .../stack-checker/visitor/dummy/dummy.factor  |  2 +-
 .../stack-checker/visitor/visitor.factor      |  2 +-
 6 files changed, 55 insertions(+), 23 deletions(-)

diff --git a/unfinished/compiler/tree/combinators/combinators.factor b/unfinished/compiler/tree/combinators/combinators.factor
index d3009daf80..3adce27b43 100644
--- a/unfinished/compiler/tree/combinators/combinators.factor
+++ b/unfinished/compiler/tree/combinators/combinators.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: fry kernel accessors sequences sequences.deep
+USING: fry kernel accessors sequences sequences.deep arrays
 compiler.tree ;
 IN: compiler.tree.combinators
 
@@ -44,3 +44,9 @@ IN: compiler.tree.combinators
 
 : select-children ( seq flags -- seq' )
     [ [ drop f ] unless ] 2map ;
+
+: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline
+
+: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
+
+: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
diff --git a/unfinished/compiler/tree/normalization/normalization.factor b/unfinished/compiler/tree/normalization/normalization.factor
index 72ea885967..b6a9f126d6 100644
--- a/unfinished/compiler/tree/normalization/normalization.factor
+++ b/unfinished/compiler/tree/normalization/normalization.factor
@@ -9,8 +9,9 @@ IN: compiler.tree.normalization
 ! fix up some oddities in the tree output by the stack checker:
 !
 ! - We rewrite the code is that #introduce nodes only appear
-! at the top level, and not inside #recursive. This enables more
-! accurate type inference for 'row polymorphic' combinators.
+! at the beginning of a program, never having #introduce follow
+! any other type of node or appear inside a #branch or
+! #recursive. This simplifies some types of analysis.
 !
 ! - We collect #return-recursive and #call-recursive nodes and
 ! store them in the #recursive's label slot.
@@ -46,6 +47,10 @@ M: #branch count-introductions*
     [ count-introductions ] map supremum
     introductions [ + ] change ;
 
+M: #recursive count-introductions*
+    [ label>> ] [ child>> count-introductions ] bi
+    >>introductions drop ;
+
 M: node count-introductions* drop ;
 
 ! Collect label info
@@ -58,18 +63,16 @@ M: #call-recursive collect-label-info
     dup label>> calls>> push ;
 
 M: #recursive collect-label-info
-    [ label>> V{ } clone >>calls ]
-    [ child>> count-introductions ]
-    bi >>introductions drop ;
+    label>> V{ } clone >>calls drop ;
 
 M: node collect-label-info drop ;
 
 ! Eliminate introductions
 SYMBOL: introduction-stack
 
-: fixup-enter-recursive ( recursive -- )
+: fixup-enter-recursive ( introductions recursive -- )
     [ child>> first ] [ in-d>> ] bi >>in-d
-    [ introduction-stack get prepend ] change-out-d
+    [ append ] change-out-d
     drop ;
 
 GENERIC: eliminate-introductions* ( node -- node' )
@@ -93,23 +96,37 @@ M: #branch eliminate-introductions*
     [ [ length ] map infimum introduction-stack [ swap head ] change ]
     bi ;
 
+: eliminate-phi-introductions ( introductions seq terminated -- seq' )
+    [ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ;
+
 M: #phi eliminate-introductions*
-    remaining-introductions get swap
-    [ flip [ over length tail append ] 2map flip ] change-phi-in-d ;
+    remaining-introductions get swap dup terminated>>
+    '[ , eliminate-phi-introductions ] change-phi-in-d ;
 
 M: node eliminate-introductions* ;
 
-: eliminate-introductions ( recursive n -- )
-    make-values introduction-stack [
-        [ fixup-enter-recursive ]
-        [ child>> [ eliminate-introductions* ] change-each ] bi
+: eliminate-introductions ( nodes introductions -- nodes )
+    introduction-stack [
+        [ eliminate-introductions* ] map
     ] with-variable ;
 
+: eliminate-toplevel-introductions ( nodes -- nodes' )
+    dup count-introductions make-values
+    [ nip [ #introduce ] map ] [ eliminate-introductions ] 2bi
+    append ;
+
+: eliminate-recursive-introductions ( recursive n -- )
+    make-values
+    [ swap fixup-enter-recursive ]
+    [ '[ , eliminate-introductions ] change-child drop ]
+    2bi ;
+
 ! Normalize
 GENERIC: normalize* ( node -- node' )
 
 M: #recursive normalize*
-    dup dup label>> introductions>> eliminate-introductions ;
+    dup dup label>> introductions>>
+    eliminate-recursive-introductions ;
 
 : unchanged-underneath ( #call-recursive -- n )
     [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;
@@ -123,6 +140,6 @@ M: #call-recursive normalize*
 M: node normalize* ;
 
 : normalize ( nodes -- nodes' )
-    [ [ collect-label-info ] each-node ]
-    [ [ normalize* ] map-nodes ]
-    bi ;
+    dup [ collect-label-info ] each-node
+    eliminate-toplevel-introductions
+    [ normalize* ] map-nodes ;
diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor
index 2a6e6cfa2f..196c3e3658 100755
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -87,10 +87,11 @@ TUPLE: #dispatch < #branch ;
 : #dispatch ( n branches -- node )
     \ #dispatch new-branch ;
 
-TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r ;
+TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r terminated ;
 
-: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out -- node )
+: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- node )
     \ #phi new
+        swap >>terminated
         swap >>out-r
         swap >>phi-in-r
         swap >>out-d
diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor
index 4b63e540dc..c4a89deb05 100644
--- a/unfinished/stack-checker/branches/branches.factor
+++ b/unfinished/stack-checker/branches/branches.factor
@@ -58,9 +58,17 @@ SYMBOL: quotations
     unify-branches
     [ drop ] [ ] [ dup >vector meta-r set ] tri* ;
 
+: terminated-phi ( seq -- terminated )
+    terminated? branch-variable ;
+
 : compute-phi-function ( seq -- )
     [ quotation active-variable sift quotations set ]
-    [ [ datastack-phi ] [ retainstack-phi ] bi #phi, ]
+    [
+        [ datastack-phi ]
+        [ retainstack-phi ]
+        [ terminated-phi ]
+        tri #phi,
+    ]
     [ [ terminated? swap at ] all? terminated? set ]
     tri ;
 
diff --git a/unfinished/stack-checker/visitor/dummy/dummy.factor b/unfinished/stack-checker/visitor/dummy/dummy.factor
index 7ab13fdd47..a1ed5c83a1 100644
--- a/unfinished/stack-checker/visitor/dummy/dummy.factor
+++ b/unfinished/stack-checker/visitor/dummy/dummy.factor
@@ -17,7 +17,7 @@ M: f #return-recursive, 3drop ;
 M: f #terminate, drop ;
 M: f #if, 3drop ;
 M: f #dispatch, 2drop ;
-M: f #phi, 2drop 2drop ;
+M: f #phi, drop drop drop drop drop ;
 M: f #declare, drop ;
 M: f #recursive, 2drop 2drop ;
 M: f #copy, 2drop ;
diff --git a/unfinished/stack-checker/visitor/visitor.factor b/unfinished/stack-checker/visitor/visitor.factor
index ce30d12c7e..3afc8f752d 100644
--- a/unfinished/stack-checker/visitor/visitor.factor
+++ b/unfinished/stack-checker/visitor/visitor.factor
@@ -20,7 +20,7 @@ HOOK: #r>, stack-visitor ( inputs outputs -- )
 HOOK: #terminate, stack-visitor ( stack -- )
 HOOK: #if, stack-visitor ( ? true false -- )
 HOOK: #dispatch, stack-visitor ( n branches -- )
-HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
+HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- )
 HOOK: #declare, stack-visitor ( declaration -- )
 HOOK: #return, stack-visitor ( stack -- )
 HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )

From da255d9647447ca0abf1388e1e61832d2c6e21d5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 1 Aug 2008 20:10:49 -0500
Subject: [PATCH 3/4] Tweaking propagation

---
 .../tree/propagation/constraints/constraints.factor       | 2 +-
 .../tree/propagation/known-words/known-words.factor       | 6 ++++++
 .../compiler/tree/propagation/propagation-tests.factor    | 8 ++++++++
 3 files changed, 15 insertions(+), 1 deletion(-)

diff --git a/unfinished/compiler/tree/propagation/constraints/constraints.factor b/unfinished/compiler/tree/propagation/constraints/constraints.factor
index f6495d2998..46a9fc91ff 100644
--- a/unfinished/compiler/tree/propagation/constraints/constraints.factor
+++ b/unfinished/compiler/tree/propagation/constraints/constraints.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs math math.intervals kernel accessors
-sequences namespaces disjoint-sets classes classes.algebra
+sequences namespaces classes classes.algebra
 combinators words
 compiler.tree compiler.tree.propagation.info
 compiler.tree.copy-equiv ;
diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor
index 08fdb36cae..89d4cd690d 100644
--- a/unfinished/compiler/tree/propagation/known-words/known-words.factor
+++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor
@@ -200,6 +200,12 @@ generic-comparison-ops [
 : info-classes-intersect? ( info1 info2 -- ? )
     [ class>> ] bi@ classes-intersect? ;
 
+\ eq? [
+    over value-info literal>> fixnum? [
+        [ value-info literal>> is-equal-to ] dip t-->
+    ] [ 3drop f ] if
+] +constraints+ set-word-prop
+
 \ eq? [
     [ info-intervals-intersect? ]
     [ info-classes-intersect? ]
diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor
index c6e7865c48..0036f7bcc1 100644
--- a/unfinished/compiler/tree/propagation/propagation-tests.factor
+++ b/unfinished/compiler/tree/propagation/propagation-tests.factor
@@ -324,6 +324,10 @@ 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
+] unit-test
+
 ! Slot propagation
 TUPLE: prop-test-tuple { x integer } ;
 
@@ -528,3 +532,7 @@ M: array iterate first t ;
 [ V{ fixnum } ] [
     [ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes
 ] unit-test
+
+[ V{ f } ] [
+    [ 10 eq? [ drop 3 ] unless ] final-literals
+] unit-test

From 84323131d92b879142601b9e34f279c5e32d6680 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 1 Aug 2008 23:31:43 -0500
Subject: [PATCH 4/4] Start work on escape analysis pass

---
 .../tree/combinators/combinators.factor       |  7 ++-
 .../allocations/allocations.factor            | 28 ++++++++++
 .../escape-analysis/branches/branches.factor  | 32 +++++++++++
 .../escape-analysis/escape-analysis.factor    | 18 ++++++
 .../tree/escape-analysis/nodes/nodes.factor   | 10 ++++
 .../recursive/recursive-tests.factor          | 16 ++++++
 .../recursive/recursive.factor                | 56 +++++++++++++++++++
 .../tree/escape-analysis/simple/simple.factor | 35 ++++++++++++
 .../work-list/work-list.factor                |  9 +++
 .../tree/propagation/branches/branches.factor | 17 +++---
 .../tree/propagation/inlining/inlining.factor |  5 ++
 .../tree/propagation/propagation-tests.factor |  2 +-
 .../propagation/recursive/recursive.factor    | 31 ++++------
 .../tree/propagation/simple/simple.factor     |  1 +
 .../tree/propagation/slots/slots.factor       | 10 +---
 15 files changed, 238 insertions(+), 39 deletions(-)
 create mode 100644 unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
 create mode 100644 unfinished/compiler/tree/escape-analysis/branches/branches.factor
 create mode 100644 unfinished/compiler/tree/escape-analysis/escape-analysis.factor
 create mode 100644 unfinished/compiler/tree/escape-analysis/nodes/nodes.factor
 create mode 100644 unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
 create mode 100644 unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
 create mode 100644 unfinished/compiler/tree/escape-analysis/simple/simple.factor
 create mode 100644 unfinished/compiler/tree/escape-analysis/work-list/work-list.factor

diff --git a/unfinished/compiler/tree/combinators/combinators.factor b/unfinished/compiler/tree/combinators/combinators.factor
index 3adce27b43..05f5cf4daa 100644
--- a/unfinished/compiler/tree/combinators/combinators.factor
+++ b/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
diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
new file mode 100644
index 0000000000..7600a3b5a2
--- /dev/null
+++ b/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 ;
diff --git a/unfinished/compiler/tree/escape-analysis/branches/branches.factor b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
new file mode 100644
index 0000000000..23e53fd4fe
--- /dev/null
+++ b/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 ;
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
new file mode 100644
index 0000000000..490fff82ec
--- /dev/null
+++ b/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) ;
diff --git a/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor b/unfinished/compiler/tree/escape-analysis/nodes/nodes.factor
new file mode 100644
index 0000000000..eb56a9e338
--- /dev/null
+++ b/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 ;
diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor
new file mode 100644
index 0000000000..89ff2e59b4
--- /dev/null
+++ b/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
diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
new file mode 100644
index 0000000000..f0f49ee083
--- /dev/null
+++ b/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 ;
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
new file mode 100644
index 0000000000..cc6ac57a5e
--- /dev/null
+++ b/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 ;
diff --git a/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor b/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor
new file mode 100644
index 0000000000..8378ee43ae
--- /dev/null
+++ b/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 ;
diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor
index bba920949b..535fddb93b 100644
--- a/unfinished/compiler/tree/propagation/branches/branches.factor
+++ b/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 ;
 
diff --git a/unfinished/compiler/tree/propagation/inlining/inlining.factor b/unfinished/compiler/tree/propagation/inlining/inlining.factor
index 1182d8211f..e4da863d68 100644
--- a/unfinished/compiler/tree/propagation/inlining/inlining.factor
+++ b/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 ;
diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor
index 0036f7bcc1..b14e94ab8c 100644
--- a/unfinished/compiler/tree/propagation/propagation-tests.factor
+++ b/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
diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor
index c5fb04e322..3732d7c08c 100644
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/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 ;
diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor
index 589ad6db4c..4237738625 100644
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/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 ] }
diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor
index 2924eb4369..5e3480be2f 100644
--- a/unfinished/compiler/tree/propagation/slots/slots.factor
+++ b/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 ;