factor/basis/compiler/tree/propagation/recursive/recursive.factor

116 lines
3.3 KiB
Factor
Raw Normal View History

2008-07-20 05:24:37 -04:00
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
2008-07-27 03:32:40 -04:00
USING: kernel sequences accessors arrays fry math.intervals
2008-08-02 00:31:43 -04:00
combinators namespaces
stack-checker.inlining
2008-07-22 05:45:03 -04:00
compiler.tree
2008-08-02 00:31:43 -04:00
compiler.tree.combinators
2008-08-07 07:34:28 -04:00
compiler.tree.propagation.copy
2008-07-22 05:45:03 -04:00
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.simple
compiler.tree.propagation.branches
compiler.tree.propagation.constraints ;
2008-07-20 05:24:37 -04:00
IN: compiler.tree.propagation.recursive
: check-fixed-point ( node infos1 infos2 -- )
[ value-info<= ] 2all?
[ drop ] [ label>> f >>fixed-point drop ] if ;
2008-07-27 03:32:40 -04:00
: latest-input-infos ( node -- infos )
in-d>> [ value-info ] map ;
2008-07-27 03:32:40 -04:00
: recursive-stacks ( #enter-recursive -- stacks initial )
[ label>> calls>> [ node-input-infos ] map flip ]
[ latest-input-infos ] bi ;
2008-07-27 03:32:40 -04:00
: generalize-counter-interval ( interval initial-interval -- interval' )
2008-07-27 03:32:40 -04:00
{
2008-07-30 18:36:24 -04:00
{ [ 2dup interval-subset? ] [ empty-interval ] }
{ [ over empty-interval eq? ] [ empty-interval ] }
{ [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] }
{ [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] }
2008-07-27 03:32:40 -04:00
[ [-inf,inf] ]
2008-07-30 18:36:24 -04:00
} cond interval-union nip ;
2008-07-27 03:32:40 -04:00
: generalize-counter ( info' initial -- info )
2dup [ class>> null-class? ] either? [ drop ] [
[ drop clone ] [ [ interval>> ] bi@ ] 2bi
generalize-counter-interval >>interval
] if ;
2008-07-27 03:32:40 -04:00
: unify-recursive-stacks ( stacks initial -- infos )
over empty? [ nip ] [
[
2008-08-10 00:00:27 -04:00
[ value-infos-union ] dip
2008-07-27 03:32:40 -04:00
[ generalize-counter ] keep
value-info-union
] 2map
] if ;
2008-07-22 05:45:03 -04:00
2008-07-27 03:32:40 -04:00
: propagate-recursive-phi ( #enter-recursive -- )
[ recursive-stacks unify-recursive-stacks ] keep
out-d>> set-value-infos ;
2008-07-22 05:45:03 -04:00
M: #recursive propagate-around ( #recursive -- )
constraints [ H{ } clone suffix ] change
2008-08-22 16:30:57 -04:00
[
loop-nesting inc
constraints [ but-last H{ } clone suffix ] change
2008-08-02 00:31:43 -04:00
child>>
[ first compute-copy-equiv ]
2008-08-02 00:31:43 -04:00
[ first propagate-recursive-phi ]
[ (propagate) ]
tri
loop-nesting dec
2008-08-22 16:30:57 -04:00
] until-fixed-point ;
2008-07-27 03:32:40 -04:00
: recursive-phi-infos ( node -- infos )
label>> enter-recursive>> node-output-infos ;
2008-07-27 03:32:40 -04:00
: generalize-return-interval ( info -- info' )
2008-08-02 00:31:43 -04:00
dup [ literal?>> ] [ class>> null-class? ] bi or
[ clone [-inf,inf] >>interval ] unless ;
2008-07-27 03:32:40 -04:00
: generalize-return ( infos -- infos' )
[ generalize-return-interval ] map ;
2008-07-22 05:45:03 -04:00
: return-infos ( node -- infos )
label>> return>> node-input-infos generalize-return ;
: save-return-infos ( node infos -- )
swap out-d>> set-value-infos ;
2008-07-27 03:32:40 -04:00
2008-11-11 10:10:33 -05:00
: unless-loop ( node quot -- )
[ dup label>> loop?>> [ drop ] ] dip if ; inline
M: #call-recursive propagate-before ( #call-recursive -- )
[
[ ] [ latest-input-infos ] [ recursive-phi-infos ] tri
check-fixed-point
]
[
2008-11-11 10:10:33 -05:00
[
[ ] [ return-infos ] [ node-output-infos ] tri
[ check-fixed-point ] [ drop save-return-infos ] 3bi
2008-11-11 10:10:33 -05:00
] unless-loop
] bi ;
M: #call-recursive annotate-node
dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
M: #enter-recursive annotate-node
dup out-d>> (annotate-node) ;
M: #return-recursive propagate-before ( #return-recursive -- )
2008-11-11 10:10:33 -05:00
[
[ ] [ latest-input-infos ] [ node-input-infos ] tri
check-fixed-point
2008-11-11 10:10:33 -05:00
] unless-loop ;
M: #return-recursive annotate-node
dup in-d>> (annotate-node) ;