diff --git a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
index b6772650b6..c7d558f4bf 100644
--- a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
+++ b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
@@ -8,11 +8,9 @@ IN: compiler.tree.dataflow-analysis
! Dataflow analysis
SYMBOL: work-list
-: look-at-value ( values -- )
- work-list get push-front ;
+: look-at-value ( values -- ) work-list get push-front ;
-: look-at-values ( values -- )
- work-list get '[ , push-front ] each ;
+: look-at-values ( values -- ) work-list get push-all-front ;
: look-at-inputs ( node -- ) in-d>> look-at-values ;
diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
index 7600a3b5a2..09c20a93dc 100644
--- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -1,7 +1,8 @@
! 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 ;
+USING: assocs namespaces sequences kernel math combinators sets
+fry stack-checker.state compiler.tree.copy-equiv
+compiler.tree.escape-analysis.graph ;
IN: compiler.tree.escape-analysis.allocations
SYMBOL: escaping
@@ -13,7 +14,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 ;
@@ -21,8 +26,33 @@ SYMBOL: allocations
: 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
+! We track available values
+SYMBOL: slot-graph
: merge-slots ( values -- value )
- <value> [ introduce-value ] [ slot-merging get set-at ] [ ] tri ;
+ dup [ ] contains? [
+ <value>
+ [ introduce-value ]
+ [ slot-graph get add-edges ]
+ [ ] tri
+ ] [ drop f ] if ;
+
+! A disqualified slot value is not available for unboxing. A
+! tuple may be unboxed if none of its slots have been
+! disqualified.
+
+: disqualify ( slot-value -- )
+ slot-graph get mark-vertex ;
+
+SYMBOL: escaping-allocations
+
+: compute-escaping-allocations ( -- )
+ #! Any allocations involving unavailable slots are
+ #! potentially escaping, and cannot be unboxed.
+ allocations get
+ slot-graph get marked-components
+ '[ [ , key? ] contains? nip ] assoc-filter
+ escaping-allocations set ;
+
+: escaping-allocation? ( value -- ? )
+ escaping-allocations get key? ;
diff --git a/unfinished/compiler/tree/escape-analysis/branches/branches.factor b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
index 23e53fd4fe..1bd6973369 100644
--- a/unfinished/compiler/tree/escape-analysis/branches/branches.factor
+++ b/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
- ] [ drop f ] if
+ ] [ disqualify-allocations f ] if
+ ] [ disqualify-allocations f ] if
] map ;
: merge-allocations ( in-values out-values -- )
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
new file mode 100644
index 0000000000..83cdfd980b
--- /dev/null
+++ b/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 classes.tuple.private ;
+
+\ escape-analysis must-infer
+
+: count-unboxed-allocations ( quot -- sizes )
+ build-tree
+ normalize
+ compute-copy-equiv
+ propagate
+ cleanup
+ escape-analysis
+ 0 swap [
+ dup #call?
+ [
+ dup word>> \ <tuple-boa> = [
+ out-d>> first escaping-allocation? [ 1+ ] unless
+ ] [ drop ] 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
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
index 490fff82ec..c41627005b 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
@@ -3,16 +3,16 @@
USING: kernel namespaces search-dequeues
compiler.tree
compiler.tree.def-use
+compiler.tree.escape-analysis.graph
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 ;
+compiler.tree.escape-analysis.simple ;
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) ;
+ <graph> slot-graph set
+ dup (escape-analysis)
+ compute-escaping-allocations ;
diff --git a/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor b/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor
new file mode 100644
index 0000000000..3a7dee58a9
--- /dev/null
+++ b/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor
@@ -0,0 +1,19 @@
+IN: compiler.tree.escape-analysis.graph.tests
+USING: compiler.tree.escape-analysis.graph tools.test namespaces
+accessors ;
+
+<graph> "graph" set
+
+[ ] [ { 2 3 4 } 1 "graph" get add-edges ] unit-test
+[ ] [ { 5 6 } 2 "graph" get add-edges ] unit-test
+[ ] [ { 7 8 } 9 "graph" get add-edges ] unit-test
+[ ] [ { 6 10 } 4 "graph" get add-edges ] unit-test
+
+[ ] [ 3 "graph" get mark-vertex ] unit-test
+
+[ H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 5 } { 6 6 } { 10 10 } } ]
+[ "graph" get marked>> ] unit-test
+
+[ ] [ { 1 11 } 12 "graph" get add-edges ] unit-test
+
+[ t ] [ 11 "graph" get marked-vertex? ] unit-test
diff --git a/unfinished/compiler/tree/escape-analysis/graph/graph.factor b/unfinished/compiler/tree/escape-analysis/graph/graph.factor
new file mode 100644
index 0000000000..59ba51d99e
--- /dev/null
+++ b/unfinished/compiler/tree/escape-analysis/graph/graph.factor
@@ -0,0 +1,38 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors assocs fry sequences sets
+dequeues search-dequeues namespaces ;
+IN: compiler.tree.escape-analysis.graph
+
+TUPLE: graph edges work-list ;
+
+: <graph> ( -- graph )
+ H{ } clone <hashed-dlist> graph boa ;
+
+: mark-vertex ( vertex graph -- ) work-list>> push-front ;
+
+: add-edge ( out in graph -- )
+ [ edges>> push-at ] [ swapd edges>> push-at ] 3bi ;
+
+: add-edges ( out-seq in graph -- )
+ '[ , , add-edge ] each ;
+
+<PRIVATE
+
+SYMBOL: marked
+
+: (mark-vertex) ( vertex graph -- )
+ over marked get key? [ 2drop ] [
+ [ drop marked get conjoin ]
+ [ [ edges>> at ] [ work-list>> ] bi push-all-front ]
+ 2bi
+ ] if ;
+
+PRIVATE>
+
+: marked-components ( graph -- vertices )
+ #! All vertices in connected components of marked vertices.
+ H{ } clone marked [
+ [ work-list>> ] keep
+ '[ , (mark-vertex) ] slurp-dequeue
+ ] with-variable ;
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index cc6ac57a5e..8329a04a61 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -6,7 +6,6 @@ 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
@@ -24,6 +23,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 ] }
diff --git a/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor b/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor
deleted file mode 100644
index 8378ee43ae..0000000000
--- a/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor
+++ /dev/null
@@ -1,9 +0,0 @@
-! 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 ;