Finishing up with propagation and escape analysis

db4
Slava Pestov 2008-08-07 01:08:11 -05:00
parent bd35994d3c
commit c6b310228e
16 changed files with 232 additions and 76 deletions

View File

@ -9,12 +9,11 @@ compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
compiler.tree.builder
compiler.tree.copy-equiv
compiler.tree.normalization
compiler.tree.propagation ;
: cleaned-up-tree ( quot -- nodes )
build-tree normalize compute-copy-equiv propagate cleanup ;
build-tree normalize propagate cleanup ;
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test

View File

@ -7,6 +7,9 @@ compiler.tree.def-use
compiler.tree.combinators ;
IN: compiler.tree.copy-equiv
! This is not really a compiler pass; its invoked as part of
! propagation.
! Two values are copy-equivalent if they are always identical
! at run-time ("DS" relation). This is just a weak form of
! value numbering.
@ -26,8 +29,7 @@ SYMBOL: copies
] if
] ;
: resolve-copy ( copy -- val )
copies get compress-path [ "Unknown value" throw ] unless* ;
: resolve-copy ( copy -- val ) copies get compress-path ;
: is-copy-of ( val copy -- ) copies get set-at ;
@ -68,13 +70,7 @@ M: #phi compute-copy-equiv*
M: node compute-copy-equiv* drop ;
: amend-copy-equiv ( node -- )
[
[ node-defs-values [ introduce-value ] each ]
[ compute-copy-equiv* ]
bi
] each-node ;
: compute-copy-equiv ( node -- node )
H{ } clone copies set
dup amend-copy-equiv ;
: compute-copy-equiv ( node -- )
[ node-defs-values [ introduce-value ] each ]
[ compute-copy-equiv* ]
bi ;

View File

@ -28,14 +28,9 @@ C: <slot-access> slot-access
: 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
@ -66,10 +61,21 @@ SYMBOL: +escaping+
: merge-slots ( values -- value )
<slot-value> [ merge-values ] keep ;
: add-escaping-value ( value -- )
+escaping+ escaping-values get equate ;
: add-escaping-values ( values -- )
escaping-values get
'[ +escaping+ , equate ] each ;
: unknown-allocation ( value -- )
[ add-escaping-value ]
[ t swap record-allocation ]
bi ;
: unknown-allocations ( values -- )
[ unknown-allocation ] each ;
: escaping-value? ( value -- ? )
+escaping+ escaping-values get equiv? ;

View File

@ -12,7 +12,7 @@ prettyprint classes.tuple.private classes classes.tuple ;
GENERIC: count-unboxed-allocations* ( m node -- n )
: (count-unboxed-allocations) ( m node -- n )
out-d>> first escaping-allocation? [ 1+ ] unless ;
dup out-d>> first escaping-allocation? [ drop ] [ short. 1+ ] if ;
M: #call count-unboxed-allocations*
dup word>> \ <tuple-boa> =
@ -27,10 +27,8 @@ M: node count-unboxed-allocations* drop ;
: count-unboxed-allocations ( quot -- sizes )
build-tree
normalize
compute-copy-equiv
propagate
cleanup
compute-copy-equiv
escape-analysis
0 swap [ count-unboxed-allocations* ] each-node ;
@ -187,3 +185,99 @@ TUPLE: cons { car read-only } { cdr read-only } ;
1 2 cons boa infinite-cons-loop
] count-unboxed-allocations
] unit-test
TUPLE: rw-box i ;
C: <rw-box> rw-box
[ 0 ] [ [ <rw-box> i>> ] count-unboxed-allocations ] unit-test
: fake-fib ( m -- n )
dup i>> 1 <= [ drop 1 <rw-box> ] when ; inline recursive
[ 0 ] [ [ <rw-box> fake-fib i>> ] count-unboxed-allocations ] unit-test
TUPLE: ro-box { i read-only } ;
C: <ro-box> ro-box
: tuple-fib ( m -- n )
dup i>> 1 <= [
drop 1 <ro-box>
] [
i>> 1- <ro-box>
dup tuple-fib
swap
i>> 1- <ro-box>
tuple-fib
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 5 ] [ [ <ro-box> tuple-fib i>> ] count-unboxed-allocations ] unit-test
[ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
: bad-tuple-fib-1 ( m -- n )
dup i>> 1 <= [
drop 1 <ro-box>
] [
i>> 1- <ro-box>
dup bad-tuple-fib-1
swap
i>> 1- <ro-box>
bad-tuple-fib-1 dup .
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 3 ] [ [ <ro-box> bad-tuple-fib-1 i>> ] count-unboxed-allocations ] unit-test
: bad-tuple-fib-2 ( m -- n )
dup .
dup i>> 1 <= [
drop 1 <ro-box>
] [
i>> 1- <ro-box>
dup bad-tuple-fib-2
swap
i>> 1- <ro-box>
bad-tuple-fib-2
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 2 ] [ [ <ro-box> bad-tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
: tuple-fib-2 ( m -- n )
dup 1 <= [
drop 1 <ro-box>
] [
1- dup tuple-fib-2
swap
1- tuple-fib-2
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 2 ] [ [ tuple-fib-2 i>> ] count-unboxed-allocations ] unit-test
: tuple-fib-3 ( m -- n )
dup 1 <= [
drop 1 <ro-box>
] [
1- dup tuple-fib-3
swap
1- tuple-fib-3 dup .
swap i>> swap i>> + <ro-box>
] if ; inline recursive
[ 0 ] [ [ tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
: bad-tuple-fib-3 ( m -- n )
dup 1 <= [
drop 1 <ro-box>
] [
1- dup bad-tuple-fib-3
swap
1- bad-tuple-fib-3
2drop f
] if ; inline recursive
[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test

View File

@ -4,7 +4,6 @@ USING: kernel namespaces search-dequeues assocs fry sequences
disjoint-sets
compiler.tree
compiler.tree.def-use
compiler.tree.copy-equiv
compiler.tree.escape-analysis.allocations
compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.branches

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences math combinators accessors namespaces
fry disjoint-sets
compiler.tree
compiler.tree.copy-equiv
compiler.tree.combinators
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.branches
@ -17,9 +17,10 @@ IN: compiler.tree.escape-analysis.recursive
[ [ [ allocation ] bi@ congruent? ] 2all? ]
} cond ;
: check-fixed-point ( node alloc1 alloc2 -- node )
[ congruent? ] 2all?
[ dup label>> f >>fixed-point drop ] unless ; inline
: check-fixed-point ( node alloc1 alloc2 -- )
[ congruent? ] 2all? [ drop ] [
label>> f >>fixed-point drop
] if ;
: node-input-allocations ( node -- allocations )
in-d>> [ allocation ] map ;
@ -35,31 +36,26 @@ IN: compiler.tree.escape-analysis.recursive
[ [ merge-values ] 2each ]
[
[ (merge-allocations) ] dip
[ [ allocation ] map check-fixed-point drop ]
[ [ allocation ] map check-fixed-point ]
[ record-allocations ]
2bi
] 2bi ;
M: #recursive escape-analysis* ( #recursive -- )
[
! copies [ clone ] change
child>>
[ first analyze-recursive-phi ]
[ (escape-analysis) ]
bi
] until-fixed-point ;
M: #call-recursive escape-analysis* ( #call-label -- )
dup
[ node-output-allocations ]
[ label>> return>> node-input-allocations ] bi
[ check-fixed-point ] keep
swap out-d>> record-allocations ;
: return-allocations ( node -- allocations )
label>> return>> node-input-allocations ;
! M: #return-recursive escape-analysis* ( #return-recursive -- )
! dup dup label>> calls>> dup empty? [ 3drop ] [
! [ node-input-allocations ]
! [ first node-output-allocations ] bi*
! check-fixed-point drop
! ] if ;
M: #call-recursive escape-analysis* ( #call-label -- )
[ ] [ return-allocations ] [ node-output-allocations ] tri
[ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
M: #return-recursive escape-analysis* ( #return-recursive -- )
[ in-d>> ] [ label>> calls>> ] bi
[ out-d>> escaping-values get '[ , equate ] 2each ] with each ;

View File

@ -128,6 +128,10 @@ M: #recursive normalize*
dup dup label>> introductions>>
eliminate-recursive-introductions ;
M: #enter-recursive normalize*
dup [ label>> ] keep >>enter-recursive drop
dup [ label>> ] [ out-d>> ] bi >>enter-out drop ;
: unchanged-underneath ( #call-recursive -- n )
[ out-d>> length ] [ label>> return>> in-d>> length ] bi - ;

View File

@ -9,7 +9,6 @@ IN: compiler.tree.optimizer
: optimize-tree ( nodes -- nodes' )
normalize
compute-copy-equiv
propagate
cleanup
compute-def-use

View File

@ -90,7 +90,7 @@ M: #phi propagate-before ( #phi -- )
[
drop condition-value get
[ [ =t ] [ =t ] bi* <--> ]
[ [ =f ] [ =f ] bi* <--> ] 2bi /\ assume
[ [ =f ] [ =f ] bi* <--> ] 2bi /\
]
}
{
@ -98,19 +98,43 @@ M: #phi propagate-before ( #phi -- )
[
drop condition-value get
[ [ =t ] [ =f ] bi* <--> ]
[ [ =f ] [ =t ] bi* <--> ] 2bi /\ assume
[ [ =f ] [ =t ] bi* <--> ] 2bi /\
]
}
{
{ { t f } { f } }
[ first =t condition-value get =t /\ swap t--> assume ]
[
first =t
condition-value get =t /\
swap t-->
]
}
{
{ { f } { t f } }
[ second =t condition-value get =f /\ swap t--> assume ]
[
second =t
condition-value get =f /\
swap t-->
]
}
[ 3drop ]
} case ;
! {
! { { t f } { } }
! [ B
! first
! [ [ =t ] bi@ <--> ]
! [ [ =f ] bi@ <--> ] 2bi /\
! ]
! }
! {
! { { } { t f } }
! [
! second
! [ [ =t ] bi@ <--> ]
! [ [ =f ] bi@ <--> ] 2bi /\
! ]
! }
[ 3drop f ]
} case assume ;
M: #phi propagate-after ( #phi -- )
condition-value get [

View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra kernel
accessors math math.intervals namespaces sequences words
combinators arrays compiler.tree.copy-equiv ;
combinators combinators.short-circuit arrays
compiler.tree.copy-equiv ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
@ -218,6 +219,28 @@ DEFER: (value-info-union)
[ drop null-info ]
[ dup first [ value-info-union ] reduce ] if ;
: literals<= ( info1 info2 -- ? )
{
{ [ dup literal?>> not ] [ 2drop t ] }
{ [ over literal?>> not ] [ 2drop f ] }
[ [ literal>> ] bi@ eql? ]
} cond ;
: value-info<= ( info1 info2 -- ? )
{
{ [ dup not ] [ 2drop t ] }
{ [ over not ] [ 2drop f ] }
[
{
[ [ class>> ] bi@ class<= ]
[ [ interval>> ] bi@ interval-subset? ]
[ literals<= ]
[ [ length>> ] bi@ value-info<= ]
[ [ slots>> ] bi@ [ value-info<= ] 2all? ]
} 2&&
]
} cond ;
! Current value --> info mapping
SYMBOL: value-infos

View File

@ -6,7 +6,6 @@ classes.union sets quotations assocs combinators words
namespaces
compiler.tree
compiler.tree.builder
compiler.tree.copy-equiv
compiler.tree.normalization
compiler.tree.propagation.info
compiler.tree.propagation.nodes ;
@ -25,7 +24,7 @@ M: quotation splicing-nodes
normalize ;
: propagate-body ( #call -- )
body>> [ amend-copy-equiv ] [ (propagate) ] bi ;
body>> (propagate) ;
! Dispatch elimination
: eliminate-dispatch ( #call word/quot/f -- ? )

View File

@ -3,6 +3,7 @@
USING: sequences accessors kernel assocs sequences
compiler.tree
compiler.tree.def-use
compiler.tree.copy-equiv
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.nodes
@ -15,7 +16,8 @@ GENERIC: propagate-after ( node -- )
GENERIC: propagate-around ( node -- )
: (propagate) ( node -- ) [ propagate-around ] each ;
: (propagate) ( node -- )
[ [ compute-copy-equiv ] [ propagate-around ] bi ] each ;
: extract-value-info ( values -- assoc )
[ dup value-info ] H{ } map>assoc ;

View File

@ -1,5 +1,5 @@
USING: kernel compiler.tree.builder compiler.tree
compiler.tree.propagation compiler.tree.copy-equiv
compiler.tree.propagation
compiler.tree.normalization tools.test math math.order
accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private
@ -14,7 +14,6 @@ IN: compiler.tree.propagation.tests
: final-info ( quot -- seq )
build-tree
normalize
compute-copy-equiv
propagate
peek node-input-infos ;
@ -145,6 +144,8 @@ IN: compiler.tree.propagation.tests
[ dup string? t xor [ "A" throw ] [ ] if ] final-classes
] unit-test
[ f ] [ [ t xor ] final-classes first null-class? ] unit-test
[ t ] [ [ t or ] final-classes first true-class? ] unit-test
[ t ] [ [ t swap or ] final-classes first true-class? ] unit-test
@ -155,12 +156,20 @@ IN: compiler.tree.propagation.tests
[ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup t xor or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup t xor swap or ] final-classes first true-class? ] unit-test
[ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
[ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test
[ t ] [ [ dup not swap and ] final-classes first false-class? ] unit-test
[ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test
[ t ] [ [ over [ drop f ] when [ "A" throw ] unless ] final-classes first false-class? ] unit-test
[ V{ fixnum } ] [

View File

@ -3,6 +3,7 @@
USING: accessors kernel sequences namespaces hashtables
compiler.tree
compiler.tree.def-use
compiler.tree.copy-equiv
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.simple
@ -13,8 +14,7 @@ compiler.tree.propagation.known-words ;
IN: compiler.tree.propagation
: propagate ( node -- node )
[
H{ } clone constraints set
H{ } clone value-infos set
dup (propagate)
] with-scope ;
H{ } clone copies set
H{ } clone constraints set
H{ } clone value-infos set
dup (propagate) ;

View File

@ -13,8 +13,9 @@ compiler.tree.propagation.branches
compiler.tree.propagation.constraints ;
IN: compiler.tree.propagation.recursive
: check-fixed-point ( node infos1 infos2 -- node )
sequence= [ dup label>> f >>fixed-point drop ] unless ; inline
: check-fixed-point ( node infos1 infos2 -- )
[ value-info<= ] 2all?
[ drop ] [ label>> f >>fixed-point drop ] if ;
: recursive-stacks ( #enter-recursive -- stacks initial )
[ label>> calls>> [ node-input-infos ] map flip ]
@ -46,19 +47,21 @@ IN: compiler.tree.propagation.recursive
: propagate-recursive-phi ( #enter-recursive -- )
[ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
[ node-output-infos check-fixed-point drop ] 2keep
out-d>> set-value-infos ;
[ node-output-infos check-fixed-point ]
[ out-d>> set-value-infos drop ]
3bi ;
M: #recursive propagate-around ( #recursive -- )
[
copies [ clone ] change
{ 0 } clone [ USE: math
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
constraints [ clone ] change
child>>
[ first compute-copy-equiv ]
[ first propagate-recursive-phi ]
[ (propagate) ]
bi
] until-fixed-point ;
tri
] curry until-fixed-point ;
: generalize-return-interval ( info -- info' )
dup [ literal?>> ] [ class>> null-class? ] bi or
@ -67,11 +70,9 @@ M: #recursive propagate-around ( #recursive -- )
: generalize-return ( infos -- infos' )
[ generalize-return-interval ] map ;
M: #call-recursive propagate-before ( #call-label -- )
dup [ node-output-infos ] [ label>> return>> node-input-infos ] bi
[ check-fixed-point ] keep
generalize-return swap out-d>> set-value-infos ;
: return-infos ( node -- infos )
label>> return>> node-input-infos generalize-return ;
M: #return-recursive propagate-before ( #return-recursive -- )
dup [ node-input-infos ] [ in-d>> [ value-info ] map ] bi
check-fixed-point drop ;
M: #call-recursive propagate-before ( #call-label -- )
[ ] [ return-infos ] [ node-output-infos ] tri
[ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;

View File

@ -17,7 +17,12 @@ IN: stack-checker.inlining
: (inline-word) ( word label -- )
[ [ def>> ] keep ] dip infer-quot-recursive ;
TUPLE: inline-recursive word enter-out return calls fixed-point introductions ;
TUPLE: inline-recursive
word
enter-out enter-recursive
return calls
fixed-point
introductions ;
: <inline-recursive> ( word -- label )
inline-recursive new swap >>word ;