Working on predicate constraint propagation

db4
Slava Pestov 2008-07-28 06:31:26 -05:00
parent ed7ad146d8
commit d817efe1dd
13 changed files with 203 additions and 92 deletions

View File

@ -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 )

View File

@ -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' ) ;

View File

@ -18,4 +18,5 @@ IN: compiler.tree.optimizer
remove-dead-code
strength-reduce
detect-loops
fuse-branches ;
fuse-branches
elaborate ;

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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
{

View File

@ -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

View File

@ -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?>> [

View File

@ -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

View File

@ -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 )

View File

@ -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

View File

@ -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>>