Working on predicate constraint propagation
Slava Pestov
parent
ed7ad146d8
commit
d817efe1dd
|
|
@ -34,6 +34,19 @@ M: #copy compute-copy-equiv*
|
|||
M: #return-recursive compute-copy-equiv*
|
||||
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
|
||||
|
||||
: compute-phi-equiv ( inputs outputs -- )
|
||||
#! An output is a copy of every input if all inputs are
|
||||
#! copies of the same original value.
|
||||
[
|
||||
swap [ resolve-copy ] map sift
|
||||
dup [ all-equal? ] [ empty? not ] bi and
|
||||
[ first swap is-copy-of ] [ 2drop ] if
|
||||
] 2each ;
|
||||
|
||||
M: #phi compute-copy-equiv*
|
||||
[ [ phi-in-d>> ] [ out-d>> ] bi compute-phi-equiv ]
|
||||
[ [ phi-in-r>> ] [ out-r>> ] bi compute-phi-equiv ] bi ;
|
||||
|
||||
M: node compute-copy-equiv* drop ;
|
||||
|
||||
: compute-copy-equiv ( node -- node )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: compiler.tree.elaboration
|
||||
|
||||
: elaborate ( nodes -- nodes' ) ;
|
||||
|
|
@ -18,4 +18,5 @@ IN: compiler.tree.optimizer
|
|||
remove-dead-code
|
||||
strength-reduce
|
||||
detect-loops
|
||||
fuse-branches ;
|
||||
fuse-branches
|
||||
elaborate ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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 locals
|
||||
math.intervals arrays classes.algebra combinators
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -33,12 +33,15 @@ M: #dispatch live-children
|
|||
|
||||
SYMBOL: infer-children-data
|
||||
|
||||
: copy-value-info ( -- )
|
||||
value-infos [ clone ] change
|
||||
constraints [ clone ] change ;
|
||||
|
||||
: infer-children ( node -- )
|
||||
[ live-children ] [ child-constraints ] bi [
|
||||
[
|
||||
over [
|
||||
value-infos [ clone ] change
|
||||
constraints [ clone ] change
|
||||
copy-value-info
|
||||
assume
|
||||
(propagate)
|
||||
] [
|
||||
|
|
@ -49,31 +52,86 @@ SYMBOL: infer-children-data
|
|||
] H{ } make-assoc
|
||||
] 2map infer-children-data set ;
|
||||
|
||||
: (merge-value-infos) ( inputs results -- infos )
|
||||
'[ , [ [ value-info ] bind ] 2map value-infos-union ] map ;
|
||||
: compute-phi-input-infos ( phi-in -- phi-info )
|
||||
infer-children-data get
|
||||
'[ , [ [ value-info ] bind ] 2map ] map ;
|
||||
|
||||
: merge-value-infos ( results inputs outputs -- )
|
||||
[ swap (merge-value-infos) ] dip set-value-infos ;
|
||||
: annotate-phi-node ( #phi -- )
|
||||
dup phi-in-d>> compute-phi-input-infos >>phi-info-d
|
||||
dup phi-in-r>> compute-phi-input-infos >>phi-info-r
|
||||
dup [ out-d>> ] [ out-r>> ] bi append extract-value-info >>info
|
||||
drop ;
|
||||
|
||||
: merge-value-infos ( infos outputs -- )
|
||||
[ [ value-infos-union ] map ] dip set-value-infos ;
|
||||
|
||||
SYMBOL: condition-value
|
||||
|
||||
! :: branch-phi-constraints ( x #phi -- )
|
||||
! #phi [ out-d>> ] [ phi-in-d>> ] bi [
|
||||
! first2 2dup and [ USE: prettyprint
|
||||
! [ [ =t x =t /\ ] [ =t x =f /\ ] bi* \/ swap t--> dup . assume ]
|
||||
! [ [ =f x =t /\ ] [ =f x =f /\ ] bi* \/ swap f--> dup . assume ]
|
||||
! 3bi
|
||||
! ] [ 3drop ] if
|
||||
! ] 2each ;
|
||||
|
||||
M: #phi propagate-before ( #phi -- )
|
||||
infer-children-data get swap
|
||||
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
|
||||
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
|
||||
2bi ;
|
||||
[ annotate-phi-node ]
|
||||
[ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ]
|
||||
[ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ]
|
||||
tri ;
|
||||
|
||||
:: branch-phi-constraints ( x #phi -- )
|
||||
#phi [ out-d>> ] [ phi-in-d>> ] bi [
|
||||
first2 2dup and [ USE: prettyprint
|
||||
[ [ =t x =t /\ ] [ =t x =f /\ ] bi* \/ swap t--> dup . assume ]
|
||||
[ [ =f x =t /\ ] [ =f x =f /\ ] bi* \/ swap f--> dup . assume ]
|
||||
3bi
|
||||
] [ 3drop ] if
|
||||
] 2each ;
|
||||
: branch-phi-constraints ( output values booleans -- )
|
||||
{
|
||||
{
|
||||
{ { t } { f } }
|
||||
[
|
||||
drop condition-value get
|
||||
[ [ =t ] [ =t ] bi* <--> ]
|
||||
[ [ =f ] [ =f ] bi* <--> ] 2bi /\ assume
|
||||
]
|
||||
}
|
||||
{
|
||||
{ { f } { t } }
|
||||
[
|
||||
drop condition-value get
|
||||
[ [ =t ] [ =f ] bi* <--> ]
|
||||
[ [ =f ] [ =t ] bi* <--> ] 2bi /\ assume
|
||||
]
|
||||
}
|
||||
{
|
||||
{ { t f } { f } }
|
||||
[ first =t condition-value get =t /\ swap t--> assume ]
|
||||
}
|
||||
{
|
||||
{ { f } { t f } }
|
||||
[ second =t condition-value get =f /\ swap t--> assume ]
|
||||
}
|
||||
! {
|
||||
! { { f } { t f } }
|
||||
! [ ]
|
||||
! }
|
||||
[ 3drop ]
|
||||
} case ;
|
||||
|
||||
! : merge-children
|
||||
! [ successor>> propagate-branch-phi ]
|
||||
! [ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ]
|
||||
! bi ;
|
||||
M: #phi propagate-after ( #phi -- )
|
||||
condition-value get [
|
||||
[ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
|
||||
3array flip [
|
||||
first3 [ possible-boolean-values ] map
|
||||
branch-phi-constraints
|
||||
] each
|
||||
] [ drop ] if ;
|
||||
|
||||
M: #phi propagate-around ( #phi -- )
|
||||
[ propagate-before ] [ propagate-after ] bi ;
|
||||
|
||||
M: #branch propagate-around
|
||||
[ infer-children ] [ annotate-node ] bi ;
|
||||
|
||||
M: #if propagate-around
|
||||
[ in-d>> first condition-value set ] [ call-next-method ] bi ;
|
||||
|
||||
M: #dispatch propagate-around
|
||||
condition-value off call-next-method ;
|
||||
|
|
|
|||
|
|
@ -12,38 +12,42 @@ IN: compiler.tree.propagation.constraints
|
|||
! Maps constraints to constraints ("A implies B")
|
||||
SYMBOL: constraints
|
||||
|
||||
GENERIC: assume ( constraint -- )
|
||||
GENERIC: assume* ( constraint -- )
|
||||
GENERIC: satisfied? ( constraint -- ? )
|
||||
GENERIC: satisfiable? ( constraint -- ? )
|
||||
|
||||
M: f assume* drop ;
|
||||
|
||||
! satisfied? is inaccurate. It's just used to prevent infinite
|
||||
! loops so its only implemented for true-constraints and
|
||||
! false-constraints.
|
||||
M: object satisfied? drop f ;
|
||||
|
||||
: assume ( constraint -- ) dup satisfied? [ drop ] [ assume* ] if ;
|
||||
|
||||
! Boolean constraints
|
||||
TUPLE: true-constraint value ;
|
||||
|
||||
: =t ( value -- constriant ) resolve-copy true-constraint boa ;
|
||||
|
||||
M: true-constraint assume
|
||||
[ constraints get at [ assume ] when* ]
|
||||
M: true-constraint assume*
|
||||
[ \ f class-not <class-info> swap value>> refine-value-info ]
|
||||
[ constraints get at [ assume ] when* ]
|
||||
bi ;
|
||||
|
||||
M: true-constraint satisfied? value>> \ f class-not value-is? ;
|
||||
|
||||
M: true-constraint satisfiable? value>> \ f class-not value-is? ;
|
||||
M: true-constraint satisfied?
|
||||
value>> value-info class>> true-class? ;
|
||||
|
||||
TUPLE: false-constraint value ;
|
||||
|
||||
: =f ( value -- constriant ) resolve-copy false-constraint boa ;
|
||||
|
||||
M: false-constraint assume
|
||||
[ constraints get at [ assume ] when* ]
|
||||
M: false-constraint assume*
|
||||
[ \ f <class-info> swap value>> refine-value-info ]
|
||||
[ constraints get at [ assume ] when* ]
|
||||
bi ;
|
||||
|
||||
M: false-constraint satisfied?
|
||||
value>> value-info class>> \ f class<= ;
|
||||
|
||||
M: false-constraint satisfiable?
|
||||
value>> value-info class>> \ f classes-intersect? ;
|
||||
value>> value-info class>> false-class? ;
|
||||
|
||||
! Class constraints
|
||||
TUPLE: class-constraint value class ;
|
||||
|
|
@ -51,7 +55,7 @@ TUPLE: class-constraint value class ;
|
|||
: is-instance-of ( value class -- constraint )
|
||||
[ resolve-copy ] dip class-constraint boa ;
|
||||
|
||||
M: class-constraint assume
|
||||
M: class-constraint assume*
|
||||
[ class>> <class-info> ] [ value>> ] bi refine-value-info ;
|
||||
|
||||
! Interval constraints
|
||||
|
|
@ -60,7 +64,7 @@ TUPLE: interval-constraint value interval ;
|
|||
: is-in-interval ( value interval -- constraint )
|
||||
[ resolve-copy ] dip interval-constraint boa ;
|
||||
|
||||
M: interval-constraint assume
|
||||
M: interval-constraint assume*
|
||||
[ interval>> <interval-info> ] [ value>> ] bi refine-value-info ;
|
||||
|
||||
! Literal constraints
|
||||
|
|
@ -69,7 +73,7 @@ TUPLE: literal-constraint value literal ;
|
|||
: is-equal-to ( value literal -- constraint )
|
||||
[ resolve-copy ] dip literal-constraint boa ;
|
||||
|
||||
M: literal-constraint assume
|
||||
M: literal-constraint assume*
|
||||
[ literal>> <literal-info> ] [ value>> ] bi refine-value-info ;
|
||||
|
||||
! Implication constraints
|
||||
|
|
@ -77,46 +81,32 @@ TUPLE: implication p q ;
|
|||
|
||||
C: --> implication
|
||||
|
||||
M: implication assume
|
||||
[ q>> ] [ p>> ] bi
|
||||
[ constraints get set-at ]
|
||||
: assume-implication ( p q -- )
|
||||
[ constraints get [ swap suffix ] change-at ]
|
||||
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
|
||||
|
||||
M: implication satisfiable?
|
||||
[ q>> satisfiable? ] [ p>> satisfiable? not ] bi or ;
|
||||
M: implication assume*
|
||||
[ q>> ] [ p>> ] bi assume-implication ;
|
||||
|
||||
! Conjunction constraints
|
||||
TUPLE: conjunction p q ;
|
||||
! Equivalence constraints
|
||||
TUPLE: equivalence p q ;
|
||||
|
||||
C: /\ conjunction
|
||||
C: <--> equivalence
|
||||
|
||||
M: conjunction assume [ p>> assume ] [ q>> assume ] bi ;
|
||||
M: equivalence assume*
|
||||
[ p>> ] [ q>> ] bi
|
||||
[ assume-implication ]
|
||||
[ swap assume-implication ] 2bi ;
|
||||
|
||||
M: conjunction satisfiable?
|
||||
[ p>> satisfiable? ] [ q>> satisfiable? ] bi and ;
|
||||
! Conjunction constraints -- sequences act as conjunctions
|
||||
M: sequence assume* [ assume ] each ;
|
||||
|
||||
! Disjunction constraints
|
||||
TUPLE: disjunction p q ;
|
||||
|
||||
C: \/ disjunction
|
||||
|
||||
M: disjunction assume
|
||||
{
|
||||
{ [ dup p>> satisfiable? not ] [ q>> assume ] }
|
||||
{ [ dup q>> satisfiable? not ] [ p>> assume ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
M: disjunction satisfiable?
|
||||
[ p>> satisfiable? ] [ q>> satisfiable? ] bi or ;
|
||||
|
||||
! No-op
|
||||
M: f assume drop ;
|
||||
: /\ ( p q -- constraint ) 2array ;
|
||||
|
||||
! Utilities
|
||||
: t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
|
||||
|
||||
: f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
|
||||
|
||||
: <conditional> ( true-constr false-constr boolean-value -- constraint )
|
||||
tuck [ t--> ] [ f--> ] 2bi* /\ ;
|
||||
: save-constraints ( quot -- )
|
||||
constraints get clone slip constraints set ; inline
|
||||
|
|
|
|||
|
|
@ -220,21 +220,22 @@ SYMBOL: value-infos
|
|||
: value-literal ( value -- obj ? )
|
||||
value-info >literal< ;
|
||||
|
||||
: false-class? ( class -- ? ) \ f class<= ;
|
||||
|
||||
: true-class? ( class -- ? ) \ f class-not class<= ;
|
||||
|
||||
: possible-boolean-values ( info -- values )
|
||||
dup literal?>> [
|
||||
literal>> 1array
|
||||
] [
|
||||
class>> {
|
||||
{ [ dup null class<= ] [ { } ] }
|
||||
{ [ dup \ f class-not class<= ] [ { t } ] }
|
||||
{ [ dup \ f class<= ] [ { f } ] }
|
||||
{ [ dup true-class? ] [ { t } ] }
|
||||
{ [ dup false-class? ] [ { f } ] }
|
||||
[ { t f } ]
|
||||
} cond nip
|
||||
] if ;
|
||||
|
||||
: value-is? ( value class -- ? )
|
||||
[ value-info class>> ] dip class<= ;
|
||||
|
||||
: node-value-info ( node value -- info )
|
||||
swap info>> at* [ drop null-info ] unless ;
|
||||
|
||||
|
|
|
|||
|
|
@ -149,12 +149,9 @@ most-negative-fixnum most-positive-fixnum [a,b]
|
|||
/\
|
||||
] ;
|
||||
|
||||
: comparison-constraints ( in1 in2 out op -- constraint )
|
||||
swap [
|
||||
[ (comparison-constraints) ]
|
||||
[ negate-comparison (comparison-constraints) ]
|
||||
3bi
|
||||
] dip <conditional> ;
|
||||
:: comparison-constraints ( in1 in2 out op -- constraint )
|
||||
in1 in2 op (comparison-constraints) out t-->
|
||||
in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
|
||||
|
||||
: define-comparison-constraints ( word op -- )
|
||||
'[ , comparison-constraints ] +constraints+ set-word-prop ;
|
||||
|
|
@ -204,7 +201,7 @@ generic-comparison-ops [
|
|||
\ eq? [
|
||||
[ info-intervals-intersect? ]
|
||||
[ info-classes-intersect? ]
|
||||
bi or maybe-or-never
|
||||
2bi or maybe-or-never
|
||||
] +outputs+ set-word-prop
|
||||
|
||||
{
|
||||
|
|
|
|||
|
|
@ -129,6 +129,36 @@ IN: compiler.tree.propagation.tests
|
|||
] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ string } ] [
|
||||
[ dup string? not [ "Oops" throw ] [ ] if ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ string } ] [
|
||||
[ dup string? not not >boolean [ ] [ "Oops" throw ] if ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ string } ] [
|
||||
[ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ t ] [ [ t or ] final-classes first true-class? ] unit-test
|
||||
|
||||
[ t ] [ [ t swap or ] final-classes first true-class? ] unit-test
|
||||
|
||||
[ t ] [ [ f and ] final-classes first false-class? ] unit-test
|
||||
|
||||
[ t ] [ [ f swap and ] final-classes first false-class? ] unit-test
|
||||
|
||||
[ t ] [ [ dup not or ] final-classes first true-class? ] unit-test
|
||||
|
||||
[ t ] [ [ dup not swap or ] final-classes first true-class? ] unit-test
|
||||
|
||||
[ t ] [ [ dup not and ] final-classes first false-class? ] unit-test
|
||||
|
||||
[ t ] [ [ dup not 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 } ] [
|
||||
[
|
||||
>fixnum
|
||||
|
|
@ -240,6 +270,12 @@ IN: compiler.tree.propagation.tests
|
|||
[ 0 * 10 < ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ V{ 27 } ] [
|
||||
[
|
||||
123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if
|
||||
] final-literals
|
||||
] unit-test
|
||||
|
||||
[ V{ string string } ] [
|
||||
[
|
||||
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
|
||||
|
|
@ -413,3 +449,5 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
|
|||
[ V{ fixnum } ] [ [ 0 recursive-test-7 ] final-classes ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [ [ 1 10 [ dup 10 < [ 2 * ] when ] times ] final-classes ] unit-test
|
||||
|
||||
[ V{ integer } ] [ [ 0 2 100 ^ [ nip ] each-integer ] final-classes ] unit-test
|
||||
|
|
|
|||
|
|
@ -7,7 +7,8 @@ compiler.tree
|
|||
compiler.tree.propagation.info
|
||||
compiler.tree.propagation.nodes
|
||||
compiler.tree.propagation.simple
|
||||
compiler.tree.propagation.branches ;
|
||||
compiler.tree.propagation.branches
|
||||
compiler.tree.propagation.constraints ;
|
||||
IN: compiler.tree.propagation.recursive
|
||||
|
||||
: check-fixed-point ( node infos1 infos2 -- node )
|
||||
|
|
@ -50,10 +51,14 @@ SYMBOL: iter-counter
|
|||
M: #recursive propagate-around ( #recursive -- )
|
||||
iter-counter inc
|
||||
iter-counter get 10 > [ "Oops" throw ] when
|
||||
dup label>> t >>fixed-point drop
|
||||
[ child>> [ first propagate-recursive-phi ] [ (propagate) ] bi ]
|
||||
[ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ]
|
||||
bi ;
|
||||
dup label>> t >>fixed-point drop [
|
||||
[
|
||||
child>>
|
||||
[ first propagate-recursive-phi ]
|
||||
[ (propagate) ]
|
||||
bi
|
||||
] save-constraints
|
||||
] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ;
|
||||
|
||||
: generalize-return-interval ( info -- info' )
|
||||
dup literal?>> [
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ M: #introduce propagate-before
|
|||
value>> object <class-info> swap set-value-info ;
|
||||
|
||||
M: #push propagate-before
|
||||
[ literal>> value>> <literal-info> ] [ out-d>> first ] bi
|
||||
[ literal>> <literal-info> ] [ out-d>> first ] bi
|
||||
set-value-info ;
|
||||
|
||||
: refine-value-infos ( classes values -- )
|
||||
|
|
@ -117,10 +117,13 @@ M: #call propagate-after
|
|||
|
||||
M: node propagate-after drop ;
|
||||
|
||||
: extract-value-info ( values -- assoc )
|
||||
[ dup value-info ] H{ } map>assoc ;
|
||||
|
||||
: annotate-node ( node -- )
|
||||
dup
|
||||
[ node-defs-values ] [ node-uses-values ] bi append
|
||||
[ dup value-info ] H{ } map>assoc
|
||||
extract-value-info
|
||||
>>info drop ;
|
||||
|
||||
M: node propagate-around
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
bi value-info-intersect 1array ;
|
||||
|
||||
: length-accessor? ( node -- ? )
|
||||
dup in-d>> first fixed-length-sequence value-is?
|
||||
dup in-d>> first value-info class>> fixed-length-sequence class<=
|
||||
[ word>> \ length eq? ] [ drop f ] if ;
|
||||
|
||||
: propagate-length ( node -- infos )
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@ TUPLE: #dispatch < #branch ;
|
|||
: #dispatch ( n branches -- node )
|
||||
\ #dispatch new-branch ;
|
||||
|
||||
TUPLE: #phi < node phi-in-d phi-in-r out-d out-r ;
|
||||
TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r ;
|
||||
|
||||
: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out -- node )
|
||||
\ #phi new
|
||||
|
|
|
|||
|
|
@ -74,7 +74,7 @@ SYMBOL: visited
|
|||
GENERIC: apply-object ( obj -- )
|
||||
|
||||
: push-literal ( obj -- )
|
||||
<literal> dup make-known [ nip push-d ] [ #push, ] 2bi ;
|
||||
dup <literal> make-known [ nip push-d ] [ #push, ] 2bi ;
|
||||
|
||||
M: wrapper apply-object
|
||||
wrapped>>
|
||||
|
|
|
|||
Loading…
Reference in New Issue