113 lines
3.1 KiB
Factor
113 lines
3.1 KiB
Factor
! Copyright (C) 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: fry accessors kernel sequences assocs words namespaces
|
|
combinators classes.algebra compiler.tree
|
|
compiler.tree.propagation.constraints ;
|
|
IN: compiler.tree.propagation.simple
|
|
|
|
GENERIC: propagate-before ( node -- )
|
|
|
|
M: #introduce propagate-before
|
|
values>> [ object swap set-value-class ] each ;
|
|
|
|
M: #push propagate-before
|
|
[ literal>> ] [ out-d>> first ] bi set-value-literal ;
|
|
|
|
M: #declare propagate-before
|
|
[ [ in-d>> ] [ out-d>> ] bi are-copies-of ]
|
|
[ [ declaration>> ] [ out-d>> ] bi [ intersect-value-class ] 2each ]
|
|
bi ;
|
|
|
|
M: #shuffle propagate-before
|
|
[ out-r>> dup ] [ mapping>> ] bi '[ , at ] map are-copies-of ;
|
|
|
|
M: #>r propagate-before
|
|
[ in-d>> ] [ out-r>> ] bi are-copies-of ;
|
|
|
|
M: #r> propagate-before
|
|
[ in-r>> ] [ out-d>> ] bi are-copies-of ;
|
|
|
|
M: #copy propagate-before
|
|
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
|
|
|
|
: intersect-classes ( classes values -- )
|
|
[ intersect-value-class ] 2each ;
|
|
|
|
: intersect-intervals ( intervals values -- )
|
|
[ intersect-value-interval ] 2each ;
|
|
|
|
: predicate-constraints ( class #call -- )
|
|
[
|
|
! If word outputs true, input is an instance of class
|
|
[
|
|
0 `input class,
|
|
\ f class-not 0 `output class,
|
|
] set-constraints
|
|
] [
|
|
! If word outputs false, input is not an instance of class
|
|
[
|
|
class-not 0 `input class,
|
|
\ f 0 `output class,
|
|
] set-constraints
|
|
] 2bi ;
|
|
|
|
: compute-constraints ( #call -- )
|
|
dup word>> "constraints" word-prop [
|
|
call
|
|
] [
|
|
dup word>> "predicating" word-prop dup
|
|
[ swap predicate-constraints ] [ 2drop ] if
|
|
] if* ;
|
|
|
|
: compute-output-classes ( node word -- classes intervals )
|
|
dup word>> "output-classes" word-prop
|
|
dup [ call ] [ 2drop f f ] if ;
|
|
|
|
: output-classes ( node -- classes intervals )
|
|
dup compute-output-classes [
|
|
[ ] [ word>> "default-output-classes" word-prop ] ?if
|
|
] dip ;
|
|
|
|
: intersect-values ( classes intervals values -- )
|
|
tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
|
|
|
|
M: #call propagate-before
|
|
[ compute-constraints ]
|
|
[ [ output-classes ] [ out-d>> ] bi intersect-values ] bi ;
|
|
|
|
M: node propagate-before drop ;
|
|
|
|
GENERIC: propagate-after ( node -- )
|
|
|
|
: input-classes ( #call -- classes )
|
|
word>> "input-classes" word-prop ;
|
|
|
|
M: #call propagate-after
|
|
[ input-classes ] [ in-d>> ] bi intersect-classes ;
|
|
|
|
M: node propagate-after drop ;
|
|
|
|
GENERIC: propagate-around ( node -- )
|
|
|
|
: valid-keys ( seq assoc -- newassoc )
|
|
'[ dup resolve-copy , at ] H{ } map>assoc
|
|
[ nip ] assoc-filter
|
|
f assoc-like ;
|
|
|
|
: annotate-node ( node -- )
|
|
#! Annotate the node with the currently-inferred set of
|
|
#! value classes.
|
|
dup node-values {
|
|
[ value-intervals get valid-keys >>intervals ]
|
|
[ value-classes get valid-keys >>classes ]
|
|
[ value-literals get valid-keys >>literals ]
|
|
[ 2drop ]
|
|
} cleave ;
|
|
|
|
M: object propagate-around
|
|
{
|
|
[ propagate-before ]
|
|
[ annotate-node ]
|
|
[ propagate-after ]
|
|
} cleave ;
|