Working on recursive escape analysis
parent
04a72f2472
commit
175b6deee5
unfinished/compiler/tree
copy-equiv
escape-analysis
allocations
branches
recursive
simple
propagation/branches
|
@ -8,7 +8,8 @@ compiler.tree.combinators ;
|
|||
IN: compiler.tree.copy-equiv
|
||||
|
||||
! Two values are copy-equivalent if they are always identical
|
||||
! at run-time ("DS" relation).
|
||||
! at run-time ("DS" relation). This is just a weak form of
|
||||
! value numbering.
|
||||
|
||||
! Mapping from values to their canonical leader
|
||||
SYMBOL: copies
|
||||
|
@ -25,7 +26,8 @@ SYMBOL: copies
|
|||
] if
|
||||
] ;
|
||||
|
||||
: resolve-copy ( copy -- val ) copies get compress-path ;
|
||||
: resolve-copy ( copy -- val )
|
||||
copies get compress-path [ "Unknown value" throw ] unless* ;
|
||||
|
||||
: is-copy-of ( val copy -- ) copies get set-at ;
|
||||
|
||||
|
@ -55,7 +57,7 @@ M: #return-recursive compute-copy-equiv*
|
|||
#! An output is a copy of every input if all inputs are
|
||||
#! copies of the same original value.
|
||||
[
|
||||
swap [ resolve-copy ] map sift
|
||||
swap sift [ resolve-copy ] map
|
||||
dup [ all-equal? ] [ empty? not ] bi and
|
||||
[ first swap is-copy-of ] [ 2drop ] if
|
||||
] 2each ;
|
||||
|
|
|
@ -1,26 +1,41 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces sequences kernel math combinators sets
|
||||
disjoint-sets fry stack-checker.state compiler.tree.copy-equiv ;
|
||||
USING: accessors assocs namespaces sequences kernel math
|
||||
combinators sets disjoint-sets fry stack-checker.state
|
||||
compiler.tree.copy-equiv ;
|
||||
IN: compiler.tree.escape-analysis.allocations
|
||||
|
||||
! 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
|
||||
! - a sequence of values -- potentially unboxed tuple allocations
|
||||
! - t -- not allocated locally, can never be unboxed
|
||||
! - t -- not allocated in this procedure, can never be unboxed
|
||||
|
||||
SYMBOL: allocations
|
||||
|
||||
: (allocation) resolve-copy allocations get ; inline
|
||||
TUPLE: slot-access slot# value ;
|
||||
|
||||
: allocation ( value -- allocation ) (allocation) at ;
|
||||
C: <slot-access> slot-access
|
||||
|
||||
: (allocation) ( value -- value' allocations )
|
||||
resolve-copy allocations get ; inline
|
||||
|
||||
: allocation ( value -- allocation )
|
||||
(allocation) at dup slot-access? [
|
||||
[ slot#>> ] [ value>> allocation ] bi nth
|
||||
allocation
|
||||
] when ;
|
||||
|
||||
: record-allocation ( allocation value -- ) (allocation) set-at ;
|
||||
|
||||
: unknown-allocation ( value -- ) t swap record-allocation ;
|
||||
|
||||
: record-allocations ( allocations values -- )
|
||||
[ record-allocation ] 2each ;
|
||||
|
||||
: unknown-allocations ( values -- )
|
||||
[ unknown-allocation ] each ;
|
||||
|
||||
! We track escaping values with a disjoint set.
|
||||
SYMBOL: escaping-values
|
||||
|
||||
|
@ -40,21 +55,16 @@ SYMBOL: +escaping+
|
|||
[ ]
|
||||
tri ;
|
||||
|
||||
: same-value ( in-value out-value -- )
|
||||
over [
|
||||
[ is-copy-of ] [ escaping-values get equate ] 2bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: record-slot-access ( out slot# in -- )
|
||||
over zero? [ 3drop ] [ allocation ?nth swap same-value ] if ;
|
||||
over zero? [ 3drop ] [
|
||||
<slot-access> swap record-allocation
|
||||
] if ;
|
||||
|
||||
: merge-values ( in-values out-value -- )
|
||||
escaping-values get '[ , , equate ] each ;
|
||||
|
||||
: merge-slots ( values -- value )
|
||||
dup [ ] contains? [
|
||||
<slot-value> [ merge-values ] keep
|
||||
] [ drop f ] if ;
|
||||
<slot-value> [ merge-values ] keep ;
|
||||
|
||||
: add-escaping-values ( values -- )
|
||||
escaping-values get
|
||||
|
|
|
@ -13,16 +13,19 @@ M: #branch escape-analysis*
|
|||
|
||||
: (merge-allocations) ( values -- allocation )
|
||||
[
|
||||
dup [ allocation ] map dup [ ] all? [
|
||||
dup [ length ] map all-equal? [
|
||||
nip flip
|
||||
[ (merge-allocations) ] [ [ merge-slots ] map ] bi
|
||||
[ record-allocations ] keep
|
||||
] [ drop add-escaping-values f ] if
|
||||
] [ drop add-escaping-values f ] if
|
||||
dup [ allocation ] map sift dup empty? [ 2drop f ] [
|
||||
dup [ t eq? not ] all? [
|
||||
dup [ length ] map all-equal? [
|
||||
nip flip
|
||||
[ (merge-allocations) ] [ [ merge-slots ] map ] bi
|
||||
[ record-allocations ] keep
|
||||
] [ drop add-escaping-values t ] if
|
||||
] [ drop add-escaping-values t ] if
|
||||
] if
|
||||
] map ;
|
||||
|
||||
: merge-allocations ( in-values out-values -- )
|
||||
[ [ sift ] map ] dip
|
||||
[ [ merge-values ] 2each ]
|
||||
[ [ (merge-allocations) ] dip record-allocations ]
|
||||
2bi ;
|
||||
|
|
|
@ -30,6 +30,7 @@ M: node count-unboxed-allocations* drop ;
|
|||
compute-copy-equiv
|
||||
propagate
|
||||
cleanup
|
||||
compute-copy-equiv
|
||||
escape-analysis
|
||||
0 swap [ count-unboxed-allocations* ] each-node ;
|
||||
|
||||
|
@ -157,3 +158,32 @@ TUPLE: cons { car read-only } { cdr read-only } ;
|
|||
[ car>> ] [ cdr>> ] bi
|
||||
] count-unboxed-allocations
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [
|
||||
[ [ 3 cons boa ] [ "A" throw ] if car>> ]
|
||||
count-unboxed-allocations
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
[ 10 [ drop ] each-integer ] count-unboxed-allocations
|
||||
] unit-test
|
||||
|
||||
[ 2 ] [
|
||||
[
|
||||
1 2 cons boa 10 [ 2drop 1 2 cons boa ] each-integer car>>
|
||||
] count-unboxed-allocations
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
[
|
||||
1 2 cons boa 10 [ drop 2 cons boa ] each-integer car>>
|
||||
] count-unboxed-allocations
|
||||
] unit-test
|
||||
|
||||
: infinite-cons-loop ( a -- b ) 2 cons boa infinite-cons-loop ; inline recursive
|
||||
|
||||
[ 0 ] [
|
||||
[
|
||||
1 2 cons boa infinite-cons-loop
|
||||
] count-unboxed-allocations
|
||||
] unit-test
|
||||
|
|
|
@ -10,12 +10,16 @@ compiler.tree.escape-analysis.allocations ;
|
|||
IN: compiler.tree.escape-analysis.recursive
|
||||
|
||||
: congruent? ( alloc1 alloc2 -- ? )
|
||||
2dup [ length ] bi@ = [
|
||||
[ [ allocation ] bi@ congruent? ] 2all?
|
||||
] [ 2drop f ] if ;
|
||||
{
|
||||
{ [ 2dup [ f eq? ] either? ] [ eq? ] }
|
||||
{ [ 2dup [ t eq? ] either? ] [ eq? ] }
|
||||
{ [ 2dup [ length ] bi@ = not ] [ 2drop f ] }
|
||||
[ [ [ allocation ] bi@ congruent? ] 2all? ]
|
||||
} cond ;
|
||||
|
||||
: check-fixed-point ( node alloc1 alloc2 -- node )
|
||||
congruent? [ dup label>> f >>fixed-point drop ] unless ; inline
|
||||
[ congruent? ] 2all?
|
||||
[ dup label>> f >>fixed-point drop ] unless ; inline
|
||||
|
||||
: node-input-allocations ( node -- allocations )
|
||||
in-d>> [ allocation ] map ;
|
||||
|
@ -27,13 +31,18 @@ IN: compiler.tree.escape-analysis.recursive
|
|||
[ 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 ;
|
||||
[ ] [ recursive-stacks flip ] [ out-d>> ] tri
|
||||
[ [ merge-values ] 2each ]
|
||||
[
|
||||
[ (merge-allocations) ] dip
|
||||
[ [ allocation ] map check-fixed-point drop ]
|
||||
[ record-allocations ]
|
||||
2bi
|
||||
] 2bi ;
|
||||
|
||||
M: #recursive escape-analysis* ( #recursive -- )
|
||||
[
|
||||
copies [ clone ] change
|
||||
! copies [ clone ] change
|
||||
|
||||
child>>
|
||||
[ first analyze-recursive-phi ]
|
||||
|
|
|
@ -10,12 +10,21 @@ compiler.tree.escape-analysis.nodes
|
|||
compiler.tree.escape-analysis.allocations ;
|
||||
IN: compiler.tree.escape-analysis.simple
|
||||
|
||||
M: #introduce escape-analysis*
|
||||
value>> unknown-allocation ;
|
||||
|
||||
: record-literal-allocation ( value object -- )
|
||||
dup class immutable-tuple-class? [
|
||||
tuple-slots rest-slice
|
||||
[ <slot-value> [ swap record-literal-allocation ] keep ] map
|
||||
swap record-allocation
|
||||
] [
|
||||
drop unknown-allocation
|
||||
] if ;
|
||||
|
||||
M: #push escape-analysis*
|
||||
#! Delegation.
|
||||
dup literal>> dup class immutable-tuple-class? [
|
||||
tuple-slots length 1- [ <slot-value> ] replicate
|
||||
swap out-d>> first record-allocation
|
||||
] [ 2drop ] if ;
|
||||
[ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
|
||||
|
||||
: record-tuple-allocation ( #call -- )
|
||||
#! Delegation.
|
||||
|
@ -23,19 +32,27 @@ M: #push escape-analysis*
|
|||
class>> immutable-tuple-class? [
|
||||
[ in-d>> but-last ] [ out-d>> first ] bi
|
||||
record-allocation
|
||||
] [ drop ] if ;
|
||||
] [ out-d>> unknown-allocations ] 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 ;
|
||||
over fixnum? [
|
||||
[ 3 - ] dip record-slot-access
|
||||
] [
|
||||
2drop unknown-allocation
|
||||
] if ;
|
||||
|
||||
M: #call escape-analysis*
|
||||
dup word>> {
|
||||
{ \ <tuple-boa> [ record-tuple-allocation ] }
|
||||
{ \ slot [ record-slot-call ] }
|
||||
[ drop in-d>> add-escaping-values ]
|
||||
[
|
||||
drop
|
||||
[ in-d>> add-escaping-values ]
|
||||
[ out-d>> unknown-allocations ] bi
|
||||
]
|
||||
} case ;
|
||||
|
||||
M: #return escape-analysis*
|
||||
|
|
|
@ -59,7 +59,7 @@ SYMBOL: infer-children-data
|
|||
|
||||
: compute-phi-input-infos ( phi-in -- phi-info )
|
||||
infer-children-data get
|
||||
'[ , [ [ value-info ] bind ] 2map ] map ;
|
||||
'[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ;
|
||||
|
||||
: annotate-phi-inputs ( #phi -- )
|
||||
dup phi-in-d>> compute-phi-input-infos >>phi-info-d
|
||||
|
|
Loading…
Reference in New Issue