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

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