From d817efe1dd4dad34323b51876b48d6f514057504 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 28 Jul 2008 06:31:26 -0500 Subject: [PATCH] Working on predicate constraint propagation --- .../tree/copy-equiv/copy-equiv.factor | 13 +++ .../tree/elaboration/elaboration.factor | 5 + .../compiler/tree/optimizer/optimizer.factor | 3 +- .../tree/propagation/branches/branches.factor | 104 ++++++++++++++---- .../constraints/constraints.factor | 82 ++++++-------- .../tree/propagation/info/info.factor | 11 +- .../known-words/known-words.factor | 11 +- .../tree/propagation/propagation-tests.factor | 38 +++++++ .../propagation/recursive/recursive.factor | 15 ++- .../tree/propagation/simple/simple.factor | 7 +- .../tree/propagation/slots/slots.factor | 2 +- unfinished/compiler/tree/tree.factor | 2 +- .../stack-checker/backend/backend.factor | 2 +- 13 files changed, 203 insertions(+), 92 deletions(-) create mode 100644 unfinished/compiler/tree/elaboration/elaboration.factor diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor index a414554efc..b45bc4bbe2 100644 --- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor +++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor @@ -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 ) diff --git a/unfinished/compiler/tree/elaboration/elaboration.factor b/unfinished/compiler/tree/elaboration/elaboration.factor new file mode 100644 index 0000000000..b0f4306964 --- /dev/null +++ b/unfinished/compiler/tree/elaboration/elaboration.factor @@ -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' ) ; diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor index bb33deb7e7..753c962061 100644 --- a/unfinished/compiler/tree/optimizer/optimizer.factor +++ b/unfinished/compiler/tree/optimizer/optimizer.factor @@ -18,4 +18,5 @@ IN: compiler.tree.optimizer remove-dead-code strength-reduce detect-loops - fuse-branches ; + fuse-branches + elaborate ; diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor index a8b623eb51..9480033ccc 100644 --- a/unfinished/compiler/tree/propagation/branches/branches.factor +++ b/unfinished/compiler/tree/propagation/branches/branches.factor @@ -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 ; diff --git a/unfinished/compiler/tree/propagation/constraints/constraints.factor b/unfinished/compiler/tree/propagation/constraints/constraints.factor index 42c094db5a..0b19d34a20 100644 --- a/unfinished/compiler/tree/propagation/constraints/constraints.factor +++ b/unfinished/compiler/tree/propagation/constraints/constraints.factor @@ -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 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 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>> ] [ 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>> ] [ 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>> ] [ 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 --> ; -: ( true-constr false-constr boolean-value -- constraint ) - tuck [ t--> ] [ f--> ] 2bi* /\ ; +: save-constraints ( quot -- ) + constraints get clone slip constraints set ; inline diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index 8c76f9330c..166cc08c17 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -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 ; diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor index eef34f6f8f..e0a341f66a 100644 --- a/unfinished/compiler/tree/propagation/known-words/known-words.factor +++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor @@ -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 ; +:: 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 { diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 6deb80947a..4da40f8a2d 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -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 diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 8f50add191..005199afaf 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -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?>> [ diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor index 42468dff8d..f30f154285 100644 --- a/unfinished/compiler/tree/propagation/simple/simple.factor +++ b/unfinished/compiler/tree/propagation/simple/simple.factor @@ -16,7 +16,7 @@ M: #introduce propagate-before value>> object swap set-value-info ; M: #push propagate-before - [ literal>> value>> ] [ out-d>> first ] bi + [ literal>> ] [ 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 diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor index c0a445d237..b92479490c 100644 --- a/unfinished/compiler/tree/propagation/slots/slots.factor +++ b/unfinished/compiler/tree/propagation/slots/slots.factor @@ -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 ) diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor index b0dde22112..7ff798de8f 100755 --- a/unfinished/compiler/tree/tree.factor +++ b/unfinished/compiler/tree/tree.factor @@ -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 diff --git a/unfinished/stack-checker/backend/backend.factor b/unfinished/stack-checker/backend/backend.factor index 658a1e9fa1..853579217b 100755 --- a/unfinished/stack-checker/backend/backend.factor +++ b/unfinished/stack-checker/backend/backend.factor @@ -74,7 +74,7 @@ SYMBOL: visited GENERIC: apply-object ( obj -- ) : push-literal ( obj -- ) - dup make-known [ nip push-d ] [ #push, ] 2bi ; + dup make-known [ nip push-d ] [ #push, ] 2bi ; M: wrapper apply-object wrapped>>