compiler.tree.propagation.*: better to use 2array than the "cuter" /\ word
parent
9369f8216f
commit
44092bf78d
|
@ -110,7 +110,7 @@ M: #phi propagate-before ( #phi -- )
|
|||
[
|
||||
drop condition-value get
|
||||
[ [ =t ] [ =t ] bi* <--> ]
|
||||
[ [ =f ] [ =f ] bi* <--> ] 2bi /\
|
||||
[ [ =f ] [ =f ] bi* <--> ] 2bi 2array
|
||||
]
|
||||
}
|
||||
{
|
||||
|
@ -118,14 +118,14 @@ M: #phi propagate-before ( #phi -- )
|
|||
[
|
||||
drop condition-value get
|
||||
[ [ =t ] [ =f ] bi* <--> ]
|
||||
[ [ =f ] [ =t ] bi* <--> ] 2bi /\
|
||||
[ [ =f ] [ =t ] bi* <--> ] 2bi 2array
|
||||
]
|
||||
}
|
||||
{
|
||||
{ { t f } { f } }
|
||||
[
|
||||
first =t
|
||||
condition-value get =t /\
|
||||
condition-value get =t 2array
|
||||
swap t-->
|
||||
]
|
||||
}
|
||||
|
@ -133,7 +133,7 @@ M: #phi propagate-before ( #phi -- )
|
|||
{ { f } { t f } }
|
||||
[
|
||||
second =t
|
||||
condition-value get =f /\
|
||||
condition-value get =f 2array
|
||||
swap t-->
|
||||
]
|
||||
}
|
||||
|
@ -141,7 +141,7 @@ M: #phi propagate-before ( #phi -- )
|
|||
{ { t f } { t } }
|
||||
[
|
||||
first =f
|
||||
condition-value get =t /\
|
||||
condition-value get =t 2array
|
||||
swap f-->
|
||||
]
|
||||
}
|
||||
|
@ -149,7 +149,7 @@ M: #phi propagate-before ( #phi -- )
|
|||
{ { t } { t f } }
|
||||
[
|
||||
second =f
|
||||
condition-value get =f /\
|
||||
condition-value get =f 2array
|
||||
swap f-->
|
||||
]
|
||||
}
|
||||
|
@ -158,7 +158,7 @@ M: #phi propagate-before ( #phi -- )
|
|||
[
|
||||
first
|
||||
[ [ =t ] bi@ <--> ]
|
||||
[ [ =f ] bi@ <--> ] 2bi /\
|
||||
[ [ =f ] bi@ <--> ] 2bi 2array
|
||||
0 include-child-constraints
|
||||
]
|
||||
}
|
||||
|
@ -167,7 +167,7 @@ M: #phi propagate-before ( #phi -- )
|
|||
[
|
||||
second
|
||||
[ [ =t ] bi@ <--> ]
|
||||
[ [ =f ] bi@ <--> ] 2bi /\
|
||||
[ [ =f ] bi@ <--> ] 2bi 2array
|
||||
1 include-child-constraints
|
||||
]
|
||||
}
|
||||
|
|
|
@ -26,6 +26,8 @@ HELP: satisfied?
|
|||
ARTICLE: "compiler.tree.propagation.constraints" "Support for predicated value info"
|
||||
"A constraint is a statement about a value."
|
||||
$nl
|
||||
"Boolean constraints:"
|
||||
{ $subsections true-constraint true-constraint }
|
||||
"Utilities:"
|
||||
{ $subsections t--> f--> } ;
|
||||
|
||||
|
|
|
@ -16,7 +16,6 @@ M: object satisfied? drop f ;
|
|||
|
||||
: assume ( constraint -- ) dup satisfied? [ drop ] [ assume* ] if ;
|
||||
|
||||
! Boolean constraints
|
||||
TUPLE: true-constraint value ;
|
||||
|
||||
: =t ( value -- constraint ) resolve-copy true-constraint boa ;
|
||||
|
@ -96,8 +95,6 @@ M: equivalence assume*
|
|||
! Conjunction constraints -- sequences act as conjunctions
|
||||
M: sequence assume* [ assume ] each ;
|
||||
|
||||
: /\ ( p q -- constraint ) 2array ;
|
||||
|
||||
: t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
|
||||
|
||||
: f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
|
||||
|
|
|
@ -184,11 +184,11 @@ IN: compiler.tree.propagation.known-words
|
|||
in2 value-info interval>> :> i2
|
||||
in1 i1 i2 op assumption is-in-interval
|
||||
in2 i2 i1 op swap-comparison assumption is-in-interval
|
||||
/\ ;
|
||||
2array ;
|
||||
|
||||
:: comparison-constraints ( in1 in2 out op -- constraint )
|
||||
in1 in2 op (comparison-constraints) out t-->
|
||||
in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
|
||||
in1 in2 op negate-comparison (comparison-constraints) out f--> 2array ;
|
||||
|
||||
: define-comparison-constraints ( word op -- )
|
||||
'[ _ comparison-constraints ] "constraints" set-word-prop ;
|
||||
|
|
|
@ -54,7 +54,7 @@ M: #declare propagate-before
|
|||
: predicate-constraints ( value class boolean-value -- constraint )
|
||||
[ [ is-instance-of ] dip t--> ]
|
||||
[ [ class-not is-instance-of ] dip f--> ]
|
||||
3bi /\ ;
|
||||
3bi 2array ;
|
||||
|
||||
: custom-constraints ( #call quot -- )
|
||||
[ [ in-d>> ] [ out-d>> ] bi append ] dip
|
||||
|
|
Loading…
Reference in New Issue