71 lines
2.0 KiB
Factor
71 lines
2.0 KiB
Factor
|
! Copyright (C) 2008 Slava Pestov.
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
|
USING: fry kernel sequences assocs accessors namespaces
|
||
|
|
math.intervals arrays classes.algebra
|
||
|
|
compiler.tree
|
||
|
|
compiler.tree.propagation.simple
|
||
|
|
compiler.tree.propagation.constraints ;
|
||
|
|
IN: compiler.tree.propagation.branches
|
||
|
|
|
||
|
|
! For conditionals, an assoc of child node # --> constraint
|
||
|
|
GENERIC: child-constraints ( node -- seq )
|
||
|
|
|
||
|
|
M: #if child-constraints
|
||
|
|
[
|
||
|
|
\ f class-not 0 `input class,
|
||
|
|
f 0 `input literal,
|
||
|
|
] make-constraints ;
|
||
|
|
|
||
|
|
M: #dispatch child-constraints
|
||
|
|
dup [
|
||
|
|
children>> length [ 0 `input literal, ] each
|
||
|
|
] make-constraints ;
|
||
|
|
|
||
|
|
DEFER: (propagate)
|
||
|
|
|
||
|
|
: infer-children ( node -- assocs )
|
||
|
|
[ children>> ] [ child-constraints ] bi [
|
||
|
|
[
|
||
|
|
value-classes [ clone ] change
|
||
|
|
value-literals [ clone ] change
|
||
|
|
value-intervals [ clone ] change
|
||
|
|
constraints [ clone ] change
|
||
|
|
apply-constraint
|
||
|
|
(propagate)
|
||
|
|
] H{ } make-assoc
|
||
|
|
] 2map ;
|
||
|
|
|
||
|
|
: merge-classes ( inputs outputs results -- )
|
||
|
|
'[
|
||
|
|
, null
|
||
|
|
[ [ value-class ] bind class-or ] 2reduce
|
||
|
|
_ set-value-class
|
||
|
|
] 2each ;
|
||
|
|
|
||
|
|
: merge-intervals ( inputs outputs results -- )
|
||
|
|
'[
|
||
|
|
, [ [ value-interval ] bind ] 2map
|
||
|
|
dup first [ interval-union ] reduce
|
||
|
|
_ set-value-interval
|
||
|
|
] 2each ;
|
||
|
|
|
||
|
|
: merge-literals ( inputs outputs results -- )
|
||
|
|
'[
|
||
|
|
, [ [ value-literal 2array ] bind ] 2map
|
||
|
|
dup all-eq? [ first first2 ] [ drop f f ] if
|
||
|
|
_ swap [ set-value-literal ] [ 2drop ] if
|
||
|
|
] 2each ;
|
||
|
|
|
||
|
|
: merge-stuff ( inputs outputs results -- )
|
||
|
|
[ merge-classes ] [ merge-intervals ] [ merge-literals ] 3tri ;
|
||
|
|
|
||
|
|
: merge-children ( results node -- )
|
||
|
|
successor>> dup #phi? [
|
||
|
|
[ [ phi-in-d>> ] [ out-d>> ] bi rot merge-stuff ]
|
||
|
|
[ [ phi-in-r>> ] [ out-r>> ] bi rot merge-stuff ]
|
||
|
|
2bi
|
||
|
|
] [ 2drop ] if ;
|
||
|
|
|
||
|
|
M: #branch propagate-around
|
||
|
|
[ infer-children ] [ merge-children ] [ annotate-node ] tri ;
|