From 8a9c15ab0b185a3eab2bf4f0f52c65572a3d0c4d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 9 Aug 2009 16:29:21 -0500
Subject: [PATCH] compiler.tree.escape-analysis: if the output of an #introduce
 node has an immutable tuple class type declaration, and it is not passed to
 any subroutine calls, or returned from the word, then unbox it. This speeds
 up vector arithmetic words on specialized arrays, because the specialized
 array is unboxed up-front, eliminating an indirection on every loop iteration

---
 basis/compiler/cfg/builder/builder.factor     |  2 +
 basis/compiler/tree/builder/builder.factor    | 11 ++--
 basis/compiler/tree/cleanup/cleanup.factor    |  2 -
 basis/compiler/tree/def-use/def-use.factor    |  2 +-
 .../allocations/allocations.factor            |  9 +++-
 .../escape-analysis/check/check-tests.factor  | 27 ++++++++++
 .../tree/escape-analysis/check/check.factor   | 38 ++++++++-----
 .../escape-analysis-tests.factor              | 19 ++++++-
 .../escape-analysis/escape-analysis.factor    |  1 +
 .../tree/escape-analysis/nodes/nodes.factor   | 11 ++--
 .../tree/escape-analysis/simple/simple.factor | 23 ++++++--
 .../tree/propagation/inlining/inlining.factor |  5 +-
 .../tree/tuple-unboxing/tuple-unboxing.factor | 53 ++++++++++++++++---
 basis/compiler/utilities/utilities.factor     |  2 +-
 14 files changed, 164 insertions(+), 41 deletions(-)
 create mode 100644 basis/compiler/tree/escape-analysis/check/check-tests.factor

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 206dfac786..7b74d1c258 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -246,3 +246,5 @@ M: #copy emit-node drop ;
 M: #enter-recursive emit-node drop ;
 
 M: #phi emit-node drop ;
+
+M: #declare emit-node drop ;
\ No newline at end of file
diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor
index 00325f5a72..e4523deb9f 100644
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@@ -49,19 +49,18 @@ PRIVATE>
 : build-tree ( word/quot -- nodes )
     [ f ] dip build-tree-with ;
 
-:: build-sub-tree ( #call word/quot -- nodes/f )
+:: build-sub-tree ( in-d out-d word/quot -- nodes/f )
     #! We don't want methods on mixins to have a declaration for that mixin.
     #! This slows down compiler.tree.propagation.inlining since then every
     #! inlined usage of a method has an inline-dependency on the mixin, and
     #! not the more specific type at the call site.
     f specialize-method? [
         [
-            #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
+            in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
             {
                 { [ dup not ] [ ] }
-                { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
-                [ in-d #call out-d>> #copy suffix ]
+                { [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
+                [ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
             } cond
         ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
-    ] with-variable ;
-
+    ] with-variable ;
\ No newline at end of file
diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index 3232e965db..1cd9589065 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -89,8 +89,6 @@ M: #call cleanup*
         [ ]
     } cond ;
 
-M: #declare cleanup* drop f ;
-
 : delete-unreachable-branches ( #branch -- )
     dup live-branches>> '[
         _
diff --git a/basis/compiler/tree/def-use/def-use.factor b/basis/compiler/tree/def-use/def-use.factor
index fa504919a3..21e79eb6c4 100644
--- a/basis/compiler/tree/def-use/def-use.factor
+++ b/basis/compiler/tree/def-use/def-use.factor
@@ -43,7 +43,7 @@ GENERIC: node-uses-values ( node -- values )
 M: #introduce node-uses-values drop f ;
 M: #push node-uses-values drop f ;
 M: #phi node-uses-values phi-in-d>> concat remove-bottom prune ;
-M: #declare node-uses-values declaration>> keys ;
+M: #declare node-uses-values drop f ;
 M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
 M: #shuffle node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
 M: #alien-callback node-uses-values drop f ;
diff --git a/basis/compiler/tree/escape-analysis/allocations/allocations.factor b/basis/compiler/tree/escape-analysis/allocations/allocations.factor
index 5d34eaad15..5291c5e81f 100644
--- a/basis/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/basis/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -1,9 +1,16 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs namespaces sequences kernel math
 combinators sets disjoint-sets fry stack-checker.values ;
 IN: compiler.tree.escape-analysis.allocations
 
+! A map from values to classes. Only for #introduce outputs
+SYMBOL: value-classes
+
+: value-class ( value -- class ) value-classes get at ;
+
+: set-value-class ( class value -- ) value-classes get set-at ;
+
 ! 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
diff --git a/basis/compiler/tree/escape-analysis/check/check-tests.factor b/basis/compiler/tree/escape-analysis/check/check-tests.factor
new file mode 100644
index 0000000000..075e20eb23
--- /dev/null
+++ b/basis/compiler/tree/escape-analysis/check/check-tests.factor
@@ -0,0 +1,27 @@
+IN: compiler.tree.escape-analysis.check.tests
+USING: compiler.tree.escape-analysis.check tools.test accessors kernel
+kernel.private math compiler.tree.builder compiler.tree.normalization
+compiler.tree.propagation compiler.tree.cleanup ;
+
+: test-checker ( quot -- ? )
+    build-tree normalize propagate cleanup run-escape-analysis? ;
+
+[ t ] [
+    [ { complex } declare [ real>> ] [ imaginary>> ] bi ]
+    test-checker
+] unit-test
+
+[ t ] [
+    [ complex boa [ real>> ] [ imaginary>> ] bi ]
+    test-checker
+] unit-test
+
+[ t ] [
+    [ [ complex boa [ real>> ] [ imaginary>> ] bi ] when ]
+    test-checker
+] unit-test
+
+[ f ] [
+    [ swap 1 2 ? ]
+    test-checker
+] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tree/escape-analysis/check/check.factor b/basis/compiler/tree/escape-analysis/check/check.factor
index ed253ad89b..4679dfe342 100644
--- a/basis/compiler/tree/escape-analysis/check/check.factor
+++ b/basis/compiler/tree/escape-analysis/check/check.factor
@@ -1,22 +1,32 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.tuple math math.private accessors
-combinators kernel compiler.tree compiler.tree.combinators
-compiler.tree.propagation.info ;
+USING: classes classes.tuple math math.private accessors sequences
+combinators.short-circuit kernel compiler.tree
+compiler.tree.combinators compiler.tree.propagation.info ;
 IN: compiler.tree.escape-analysis.check
 
 GENERIC: run-escape-analysis* ( node -- ? )
 
-M: #push run-escape-analysis*
-    literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ;
-
-M: #call run-escape-analysis*
+: unbox-inputs? ( nodes -- ? )
     {
-        { [ dup immutable-tuple-boa? ] [ t ] }
-        [ f ] 
-    } cond nip ;
-
-M: node run-escape-analysis* drop f ;
+        [ length 2 >= ]
+        [ first #introduce? ]
+        [ second #declare? ]
+    } 1&& ;
 
 : run-escape-analysis? ( nodes -- ? )
-    [ run-escape-analysis* ] contains-node? ;
+    { [ unbox-inputs? ] [ [ run-escape-analysis* ] any? ] } 1|| ;
+
+M: #push run-escape-analysis*
+    literal>> class immutable-tuple-class? ;
+
+M: #call run-escape-analysis*
+    immutable-tuple-boa? ;
+
+M: #recursive run-escape-analysis*
+    child>> run-escape-analysis? ;
+
+M: #branch run-escape-analysis*
+    children>> [ run-escape-analysis? ] any? ;
+
+M: node run-escape-analysis* drop f ;
diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 4fb01608f0..be6b2863f0 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -9,7 +9,7 @@ quotations.private prettyprint classes.tuple.private classes
 classes.tuple namespaces
 compiler.tree.propagation.info stack-checker.errors
 compiler.tree.checker
-kernel.private ;
+kernel.private vectors ;
 
 GENERIC: count-unboxed-allocations* ( m node -- n )
 
@@ -24,6 +24,9 @@ M: #push count-unboxed-allocations*
     dup literal>> class immutable-tuple-class?
     [ (count-unboxed-allocations) ] [ drop ] if ;
 
+M: #introduce count-unboxed-allocations*
+    out-d>> [ escaping-allocation? [ 1+ ] unless ] each ;
+
 M: node count-unboxed-allocations* drop ;
 
 : count-unboxed-allocations ( quot -- sizes )
@@ -328,3 +331,17 @@ C: <ro-box> ro-box
 TUPLE: empty-tuple ;
 
 [ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
+
+! New feature!
+
+[ 1 ] [ [ { complex } declare real>> ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [
+    [ { complex } declare [ real>> ] [ imaginary>> ] bi ]
+    count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+    [ { vector } declare length>> ]
+    count-unboxed-allocations
+] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tree/escape-analysis/escape-analysis.factor b/basis/compiler/tree/escape-analysis/escape-analysis.factor
index 82e41d7b49..dcad55742b 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis.factor
@@ -15,5 +15,6 @@ IN: compiler.tree.escape-analysis
     init-escaping-values
     H{ } clone allocations set
     H{ } clone slot-accesses set
+    H{ } clone value-classes set
     dup (escape-analysis)
     compute-escaping-allocations ;
diff --git a/basis/compiler/tree/escape-analysis/nodes/nodes.factor b/basis/compiler/tree/escape-analysis/nodes/nodes.factor
index 3fdde22bd8..3451750a34 100644
--- a/basis/compiler/tree/escape-analysis/nodes/nodes.factor
+++ b/basis/compiler/tree/escape-analysis/nodes/nodes.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences
+USING: kernel sequences fry math namespaces
 compiler.tree
 compiler.tree.def-use
 compiler.tree.escape-analysis.allocations ;
@@ -8,9 +8,14 @@ IN: compiler.tree.escape-analysis.nodes
 
 GENERIC: escape-analysis* ( node -- )
 
+SYMBOL: next-node
+
+: each-with-next ( seq quot: ( elt -- ) -- )
+    dupd '[ 1 + _ ?nth next-node set @ ] each-index ; inline
+
 : (escape-analysis) ( node -- )
     [
         [ node-defs-values introduce-values ]
         [ escape-analysis* ]
         bi
-    ] each ;
+    ] each-with-next ;
diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor
index c0b3982c0e..c053b15f29 100644
--- a/basis/compiler/tree/escape-analysis/simple/simple.factor
+++ b/basis/compiler/tree/escape-analysis/simple/simple.factor
@@ -1,20 +1,36 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences classes.tuple
 classes.tuple.private arrays math math.private slots.private
 combinators deques search-deques namespaces fry classes
-classes.algebra stack-checker.state
+classes.algebra assocs stack-checker.state
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.simple
 
+M: #declare escape-analysis* drop ;
+
 M: #terminate escape-analysis* drop ;
 
 M: #renaming escape-analysis* inputs/outputs copy-values ;
 
-M: #introduce escape-analysis* out-d>> unknown-allocations ;
+: declared-class ( value -- class/f )
+    next-node get dup #declare? [ declaration>> at ] [ 2drop f ] if ;
+
+: record-param-allocation ( value class -- )
+    dup immutable-tuple-class? [
+        [ swap set-value-class ] [
+            all-slots [
+                [ <slot-value> dup ] [ class>> ] bi*
+                record-param-allocation
+            ] map swap record-allocation
+        ] 2bi
+    ] [ drop unknown-allocation ] if ;
+
+M: #introduce escape-analysis*
+    out-d>> [ dup declared-class record-param-allocation ] each ;
 
 DEFER: record-literal-allocation
 
@@ -24,7 +40,6 @@ DEFER: record-literal-allocation
 : object-slots ( object -- slots/f )
     {
         { [ dup class immutable-tuple-class? ] [ tuple-slots ] }
-        { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
         [ drop f ]
     } cond ;
 
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 4d54dc5e39..ef1326c81f 100755
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -31,8 +31,11 @@ SYMBOL: inlining-count
 : splicing-call ( #call word -- nodes )
     [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
 
+: open-code-#call ( #call word/quot -- nodes/f )
+    [ [ in-d>> ] [ out-d>> ] bi ] dip build-sub-tree ;
+
 : splicing-body ( #call quot/word -- nodes/f )
-    build-sub-tree dup [ analyze-recursive normalize ] when ;
+    open-code-#call dup [ analyze-recursive normalize ] when ;
 
 ! Dispatch elimination
 : undo-inlining ( #call -- ? )
diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 6bed4407b8..de2848ea78 100755
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -1,12 +1,15 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs accessors kernel combinators
+USING: namespaces assocs accessors kernel kernel.private combinators
 classes.algebra sequences slots.private fry vectors
 classes.tuple.private math math.private arrays
-stack-checker.branches
+stack-checker.branches stack-checker.values
 compiler.utilities
 compiler.tree
+compiler.tree.builder
+compiler.tree.cleanup
 compiler.tree.combinators
+compiler.tree.propagation
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.simple
 compiler.tree.escape-analysis.allocations ;
@@ -72,8 +75,8 @@ M: #call unbox-tuples*
     } case ;
 
 M: #declare unbox-tuples*
-    #! We don't look at declarations after propagation anyway.
-    f >>declaration ;
+    #! We don't look at declarations after escape analysis anyway.
+    drop f ;
 
 M: #copy unbox-tuples*
     [ flatten-values ] change-in-d
@@ -113,6 +116,44 @@ M: #return-recursive unbox-tuples*
     [ flatten-values ] change-in-d
     [ flatten-values ] change-out-d ;
 
+: value-declaration ( value -- quot )
+    value-class [ 1array '[ _ declare ] ] [ [ ] ] if* ;
+
+: unbox-parameter-quot ( allocation -- quot )
+    dup unboxed-allocation {
+        { [ dup not ] [ 2drop [ ] ] }
+        { [ dup array? ] [
+            [ value-declaration ] [
+                [
+                    [ unbox-parameter-quot ] [ 2 + '[ _ slot ] ] bi*
+                    prepose
+                ] map-index
+            ] bi* '[ @ _ cleave ]
+        ] }
+    } cond ;
+
+: unbox-parameters-quot ( values -- quot )
+    [ unbox-parameter-quot ] map
+    dup [ [ ] = ] all? [ drop [ ] ] [ '[ _ spread ] ] if ;
+
+: unbox-parameters-nodes ( new-values old-values -- nodes )
+    [ flatten-values ] [ unbox-parameters-quot ] bi build-sub-tree ;
+
+: new-and-old-values ( values -- new-values old-values )
+    [ length [ <value> ] replicate ] keep ;
+
+: unbox-hairy-introduce ( #introduce -- nodes )
+    dup out-d>> new-and-old-values
+    [ drop >>out-d ] [ unbox-parameters-nodes ] 2bi
+    swap prefix propagate ;
+
+M: #introduce unbox-tuples*
+    ! For every output that is unboxed, insert slot accessors
+    ! to convert the stack value into its unboxed form
+    dup out-d>> [ unboxed-allocation ] any? [
+        unbox-hairy-introduce
+    ] when ;
+
 ! These nodes never participate in unboxing
 : assert-not-unboxed ( values -- )
     dup array?
@@ -123,8 +164,6 @@ M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
 
 M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
 
-M: #introduce unbox-tuples* dup out-d>> assert-not-unboxed ;
-
 M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
 
 M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor
index a17d099be4..d8df81fc0d 100644
--- a/basis/compiler/utilities/utilities.factor
+++ b/basis/compiler/utilities/utilities.factor
@@ -9,7 +9,7 @@ IN: compiler.utilities
         dup
         '[
             @ [
-                dup array?
+                dup [ array? ] [ vector? ] bi or
                 [ _ push-all ] [ _ push ] if
             ] when*
         ]