M: #enter-recursive emit-node drop ;
M: #phi emit-node drop ;
+
+M: #declare emit-node drop ;
\ No newline at end of file
: 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
[ ]
} cond ;
-M: #declare cleanup* drop f ;
-
: delete-unreachable-branches ( #branch -- )
dup live-branches>> '[
_
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 ;
-! 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
--- /dev/null
+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
-! 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 -- ? )
+: unbox-inputs? ( nodes -- ? )
+ {
+ [ length 2 >= ]
+ [ first #introduce? ]
+ [ second #declare? ]
+ } 1&& ;
+
+: run-escape-analysis? ( nodes -- ? )
+ { [ unbox-inputs? ] [ [ run-escape-analysis* ] any? ] } 1|| ;
+
M: #push run-escape-analysis*
- literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ;
+ literal>> class immutable-tuple-class? ;
M: #call run-escape-analysis*
- {
- { [ dup immutable-tuple-boa? ] [ t ] }
- [ f ]
- } cond nip ;
+ immutable-tuple-boa? ;
-M: node run-escape-analysis* drop f ;
+M: #recursive run-escape-analysis*
+ child>> run-escape-analysis? ;
-: run-escape-analysis? ( nodes -- ? )
- [ run-escape-analysis* ] contains-node? ;
+M: #branch run-escape-analysis*
+ children>> [ run-escape-analysis? ] any? ;
+
+M: node run-escape-analysis* drop f ;
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 )
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 )
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
init-escaping-values
H{ } clone allocations set
H{ } clone slot-accesses set
+ H{ } clone value-classes set
dup (escape-analysis)
compute-escaping-allocations ;
-! 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 ;
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 ;
-! 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
: object-slots ( object -- slots/f )
{
{ [ dup class immutable-tuple-class? ] [ tuple-slots ] }
- { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
[ drop f ]
} cond ;
: 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 -- ? )
-! 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 ;
} 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
[ 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?
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 ;
dup
'[
@ [
- dup array?
+ dup [ array? ] [ vector? ] bi or
[ _ push-all ] [ _ push ] if
] when*
]
projects / factor.git / commitdiff