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

@@ -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 ;

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 ;

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>> '[
         _

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 ;

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

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

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 ;

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

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 ;

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 ;

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 ;
 

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 -- ? )

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 ;

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*
         ]