Working on predicate constraint propagation

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 )

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

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 ;

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
+                copy-value-info
-                constraints [ clone ] change
                 assume
                 (propagate)
             ] [
@@ -49,31 +52,86 @@ SYMBOL: infer-children-data
         ] H{ } make-assoc
     ] 2map infer-children-data set ;
 
-: (merge-value-infos) ( inputs results -- infos )
+: compute-phi-input-infos ( phi-in -- phi-info )
-    '[ , [ [ value-info ] bind ] 2map value-infos-union ] map ;
+    infer-children-data get
+    '[ , [ [ value-info ] bind ] 2map ] map ;
 
-: merge-value-infos ( results inputs outputs -- )
+: annotate-phi-node ( #phi -- )
-    [ swap (merge-value-infos) ] dip set-value-infos ;
+    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
+    [ annotate-phi-node ]
-    [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
+    [ [ phi-info-d>> ] [ out-d>> ] bi merge-value-infos ]
-    [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
+    [ [ phi-info-r>> ] [ out-r>> ] bi merge-value-infos ]
-    2bi ;
+    tri ;
 
-:: branch-phi-constraints ( x #phi -- )
+: branch-phi-constraints ( output values booleans -- )
-    #phi [ out-d>> ] [ phi-in-d>> ] bi [
+     {
-        first2 2dup and [ USE: prettyprint
+        {
-            [ [ =t x =t /\ ] [ =t x =f /\ ] bi* \/ swap t--> dup  . assume ]
+            { { t } { f } }
-            [ [ =f x =t /\ ] [ =f x =f /\ ] bi* \/ swap f--> dup  . assume ]
+            [
-            3bi
+                drop condition-value get
-        ] [ 3drop ] if
+                [ [ =t ] [ =t ] bi* <--> ]
-    ] 2each ;
+                [ [ =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
+M: #phi propagate-after ( #phi -- )
-!     [ successor>> propagate-branch-phi ]
+    condition-value get [
-!     [ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ]
+        [ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
-!     bi ;
+        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 ;

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
+M: true-constraint assume*
-    [ constraints get at [ assume ] when* ]
     [ \ 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 satisfied?
-
+    value>> value-info class>> true-class? ;
-M: true-constraint satisfiable? value>> \ f class-not value-is? ;
 
 TUPLE: false-constraint value ;
 
 : =f ( value -- constriant ) resolve-copy false-constraint boa ;
 
-M: false-constraint assume
+M: false-constraint assume*
-    [ constraints get at [ assume ] when* ]
     [ \ f <class-info> swap value>> refine-value-info ]
+    [ constraints get at [ assume ] when* ]
     bi ;
 
 M: false-constraint satisfied?
-    value>> value-info class>> \ f class<= ;
+    value>> value-info class>> false-class? ;
-
-M: false-constraint satisfiable?
-    value>> value-info class>> \ f classes-intersect? ;
 
 ! 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
+: assume-implication ( p q -- )
-    [ q>> ] [ p>> ] bi
+    [ constraints get [ swap suffix ] change-at ]
-    [ constraints get set-at ]
     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
 
-M: implication satisfiable?
+M: implication assume*
-    [ q>> satisfiable? ] [ p>> satisfiable? not ] bi or ;
+    [ q>> ] [ p>> ] bi assume-implication ;
 
-! Conjunction constraints
+! Equivalence constraints
-TUPLE: conjunction p q ;
+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?
+! Conjunction constraints -- sequences act as conjunctions
-    [ p>> satisfiable? ] [ q>> satisfiable? ] bi and ;
+M: sequence assume* [ assume ] each ;
 
-! Disjunction constraints
+: /\ ( p q -- constraint ) 2array ;
-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 ;
 
 ! Utilities
 : t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
 
 : f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
 
-: <conditional> ( true-constr false-constr boolean-value -- constraint )
+: save-constraints ( quot -- )
-    tuck [ t--> ] [ f--> ] 2bi* /\ ;
+    constraints get clone slip constraints set ; inline

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 true-class? ] [ { t } ] }
-            { [ dup \ f class<= ] [ { f } ] }
+            { [ 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 ;
 

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 )
+:: comparison-constraints ( in1 in2 out op -- constraint )
-    swap [
+    in1 in2 op (comparison-constraints) out t-->
-        [ (comparison-constraints) ]
+    in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
-        [ negate-comparison (comparison-constraints) ]
-        3bi
-    ] dip <conditional> ;
 
 : 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
 
 {

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

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
+    dup label>> t >>fixed-point drop [
-    [ child>> [ first propagate-recursive-phi ] [ (propagate) ] bi ]
+        [
-    [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ]
+            child>>
-    bi ;
+            [ first propagate-recursive-phi ]
+            [ (propagate) ]
+            bi
+        ] save-constraints
+    ] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ;
 
 : generalize-return-interval ( info -- info' )
     dup literal?>> [

unfinished/compiler/tree/propagation/simple/simple.factor

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

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 )

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

unfinished/stack-checker/backend/backend.factor

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