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