basis/compiler/tree/propagation/known-words/known-words.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel effects accessors math math.private math.libm
   4 math.partial-dispatch math.intervals math.parser math.order
   5 layouts words sequences sequences.private arrays assocs classes
   6 classes.algebra combinators generic.math splitting fry locals
   7 classes.tuple alien.accessors classes.tuple.private slots.private
   8 definitions
   9 stack-checker.state
  10 compiler.intrinsics
  11 compiler.tree.comparisons
  12 compiler.tree.propagation.info
  13 compiler.tree.propagation.nodes
  14 compiler.tree.propagation.slots
  15 compiler.tree.propagation.simple
  16 compiler.tree.propagation.constraints ;
  17 IN: compiler.tree.propagation.known-words
  18
  19 \ fixnum
  20 most-negative-fixnum most-positive-fixnum [a,b]
  21 "interval" set-word-prop
  22
  23 \ array-capacity
  24 0 max-array-capacity [a,b]
  25 "interval" set-word-prop
  26
  27 { + - * / }
  28 [ { number number } "input-classes" set-word-prop ] each
  29
  30 { /f < > <= >= }
  31 [ { real real } "input-classes" set-word-prop ] each
  32
  33 { /i mod /mod }
  34 [ { rational rational } "input-classes" set-word-prop ] each
  35
  36 { bitand bitor bitxor bitnot shift }
  37 [ { integer integer } "input-classes" set-word-prop ] each
  38
  39 \ bitnot { integer } "input-classes" set-word-prop
  40
  41 {
  42     fcosh
  43     flog
  44     fsinh
  45     fexp
  46     fasin
  47     facosh
  48     fasinh
  49     ftanh
  50     fatanh
  51     facos
  52     fpow
  53     fatan
  54     fatan2
  55     fcos
  56     ftan
  57     fsin
  58     fsqrt
  59 } [
  60     dup stack-effect
  61     [ in>> length real <repetition> "input-classes" set-word-prop ]
  62     [ out>> length float <repetition> "default-output-classes" set-word-prop ]
  63     2bi
  64 ] each
  65
  66 : ?change-interval ( info quot -- quot' )
  67     over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
  68
  69 { bitnot fixnum-bitnot bignum-bitnot } [
  70     [ [ interval-bitnot ] ?change-interval ] "outputs" set-word-prop
  71 ] each
  72
  73 \ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop
  74
  75 : math-closure ( class -- newclass )
  76     { fixnum bignum integer rational float real number object }
  77     [ class<= ] with find nip ;
  78
  79 : fits? ( interval class -- ? )
  80     "interval" word-prop interval-subset? ;
  81
  82 : binary-op-class ( info1 info2 -- newclass )
  83     [ class>> ] bi@
  84     2dup [ null-class? ] either? [ 2drop null ] [
  85         [ math-closure ] bi@ math-class-max
  86     ] if ;
  87
  88 : binary-op-interval ( info1 info2 quot -- newinterval )
  89     [ [ interval>> ] bi@ ] dip call ; inline
  90
  91 : won't-overflow? ( class interval -- ? )
  92     [ fixnum class<= ] [ fixnum fits? ] bi* and ;
  93
  94 : may-overflow ( class interval -- class' interval' )
  95     over null-class? [
  96         2dup won't-overflow?
  97         [ [ integer math-class-max ] dip ] unless
  98     ] unless ;
  99
 100 : may-be-rational ( class interval -- class' interval' )
 101     over null-class? [
 102         [ rational math-class-max ] dip
 103     ] unless ;
 104
 105 : number-valued ( class interval -- class' interval' )
 106     [ number math-class-min ] dip ;
 107
 108 : integer-valued ( class interval -- class' interval' )
 109     [ integer math-class-min ] dip ;
 110
 111 : real-valued ( class interval -- class' interval' )
 112     [ real math-class-min ] dip ;
 113
 114 : float-valued ( class interval -- class' interval' )
 115     over null-class? [
 116         [ drop float ] dip
 117     ] unless ;
 118
 119 : binary-op ( word interval-quot post-proc-quot -- )
 120     '[
 121         [ binary-op-class ] [ , binary-op-interval ] 2bi
 122         @
 123         <class/interval-info>
 124     ] "outputs" set-word-prop ;
 125
 126 \ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
 127 \ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
 128
 129 \ - [ [ interval- ] [ may-overflow number-valued ] binary-op ] each-derived-op
 130 \ - [ [ interval- ] [ number-valued ] binary-op ] each-fast-derived-op
 131
 132 \ * [ [ interval* ] [ may-overflow number-valued ] binary-op ] each-derived-op
 133 \ * [ [ interval* ] [ number-valued ] binary-op ] each-fast-derived-op
 134
 135 \ / [ [ interval/-safe ] [ may-be-rational number-valued ] binary-op ] each-derived-op
 136 \ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
 137 \ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
 138
 139 \ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
 140 \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
 141
 142 \ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
 143 \ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op
 144
 145 \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
 146 \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
 147 \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
 148
 149 :: (comparison-constraints) ( in1 in2 op -- constraint )
 150     [let | i1 [ in1 value-info interval>> ]
 151            i2 [ in2 value-info interval>> ] |
 152        in1 i1 i2 op assumption is-in-interval
 153        in2 i2 i1 op swap-comparison assumption is-in-interval
 154        /\
 155     ] ;
 156
 157 :: comparison-constraints ( in1 in2 out op -- constraint )
 158     in1 in2 op (comparison-constraints) out t-->
 159     in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
 160
 161 : define-comparison-constraints ( word op -- )
 162     '[ , comparison-constraints ] "constraints" set-word-prop ;
 163
 164 comparison-ops
 165 [ dup '[ , define-comparison-constraints ] each-derived-op ] each
 166
 167 generic-comparison-ops [
 168     dup specific-comparison
 169     '[ , , define-comparison-constraints ] each-derived-op
 170 ] each
 171
 172 ! Remove redundant comparisons
 173 : fold-comparison ( info1 info2 word -- info )
 174     [ [ interval>> ] bi@ ] dip interval-comparison {
 175         { incomparable [ object-info ] }
 176         { t [ t <literal-info> ] }
 177         { f [ f <literal-info> ] }
 178     } case ;
 179
 180 comparison-ops [
 181     dup '[
 182         [ , fold-comparison ] "outputs" set-word-prop
 183     ] each-derived-op
 184 ] each
 185
 186 generic-comparison-ops [
 187     dup specific-comparison
 188     '[ , fold-comparison ] "outputs" set-word-prop
 189 ] each
 190
 191 : maybe-or-never ( ? -- info )
 192     [ object-info ] [ f <literal-info> ] if ;
 193
 194 : info-intervals-intersect? ( info1 info2 -- ? )
 195     [ interval>> ] bi@ intervals-intersect? ;
 196
 197 { number= bignum= float= } [
 198     [
 199         info-intervals-intersect? maybe-or-never
 200     ] "outputs" set-word-prop
 201 ] each
 202
 203 : info-classes-intersect? ( info1 info2 -- ? )
 204     [ class>> ] bi@ classes-intersect? ;
 205
 206 \ eq? [
 207     over value-info literal>> fixnum? [
 208         [ value-info literal>> is-equal-to ] dip t-->
 209     ] [ 3drop f ] if
 210 ] "constraints" set-word-prop
 211
 212 \ eq? [
 213     [ info-intervals-intersect? ]
 214     [ info-classes-intersect? ]
 215     2bi and maybe-or-never
 216 ] "outputs" set-word-prop
 217
 218 {
 219     { >fixnum fixnum }
 220     { >bignum bignum }
 221     { >float float }
 222 } [
 223     '[
 224         ,
 225         [ nip ] [
 226             [ interval>> ] [ class-interval ] bi*
 227             interval-intersect
 228         ] 2bi
 229         <class/interval-info>
 230     ] "outputs" set-word-prop
 231 ] assoc-each
 232
 233 {
 234     alien-signed-1
 235     alien-unsigned-1
 236     alien-signed-2
 237     alien-unsigned-2
 238     alien-signed-4
 239     alien-unsigned-4
 240     alien-signed-8
 241     alien-unsigned-8
 242 } [
 243     dup name>> {
 244         {
 245             [ "alien-signed-" ?head ]
 246             [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
 247         }
 248         {
 249             [ "alien-unsigned-" ?head ]
 250             [ string>number 8 * 2^ 1- 0 swap [a,b] ]
 251         }
 252     } cond
 253     [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
 254     [ 2nip ] curry "outputs" set-word-prop
 255 ] each
 256
 257 { <tuple> <tuple-boa> (tuple) } [
 258     [
 259         literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
 260         [ clear ] dip
 261     ] "outputs" set-word-prop
 262 ] each
 263
 264 \ new [
 265     literal>> dup tuple-class? [ drop tuple ] unless <class-info>
 266 ] "outputs" set-word-prop
 267
 268 ! the output of clone has the same type as the input
 269 { clone (clone) } [
 270     [ clone f >>literal f >>literal? ]
 271     "outputs" set-word-prop
 272 ] each
 273
 274 \ slot [
 275     dup literal?>>
 276     [ literal>> swap value-info-slot ] [ 2drop object-info ] if
 277 ] "outputs" set-word-prop
 278
 279 \ instance? [
 280     [ value-info ] dip over literal>> class? [
 281         [ literal>> ] dip predicate-constraints
 282     ] [ 3drop f ] if
 283 ] "constraints" set-word-prop
 284
 285 \ instance? [
 286     ! We need to force the caller word to recompile when the class
 287     ! is redefined, since now we're making assumptions but the
 288     ! class definition itself.
 289     dup literal>> class?
 290     [
 291         literal>>
 292         [ inlined-dependency depends-on ]
 293         [ predicate-output-infos ]
 294         bi
 295     ] [ 2drop object-info ] if
 296 ] "outputs" set-word-prop