Finishing up with propagation and escape analysis
parent
bd35994d3c
commit
c6b310228e
unfinished
compiler/tree
cleanup
copy-equiv
escape-analysis
normalization
optimizer
propagation
branches
info
inlining
nodes
recursive
stack-checker/inlining
|
@ -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
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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? ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 - ;
|
||||
|
||||
|
|
|
@ -9,7 +9,6 @@ IN: compiler.tree.optimizer
|
|||
|
||||
: optimize-tree ( nodes -- nodes' )
|
||||
normalize
|
||||
compute-copy-equiv
|
||||
propagate
|
||||
cleanup
|
||||
compute-def-use
|
||||
|
|
|
@ -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 [
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 -- ? )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 } ] [
|
||||
|
|
|
@ -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) ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue