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

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.accessors alien.data.private arrays
   4 assocs byte-arrays byte-vectors classes classes.algebra classes.tuple
   5 classes.tuple.private combinators compiler.tree.comparisons
   6 compiler.tree.propagation.constraints compiler.tree.propagation.info
   7 compiler.tree.propagation.simple compiler.tree.propagation.slots fry
   8 generic.math hashtables kernel kernel.private layouts locals math
   9 math.floats.private math.functions math.integers.private
  10 math.intervals math.libm math.parser math.partial-dispatch
  11 math.private namespaces sbufs sequences slots.private splitting
  12 stack-checker.dependencies strings strings.private vectors words ;
  13 FROM: alien.c-types => (signed-interval) (unsigned-interval) ;
  14 IN: compiler.tree.propagation.known-words
  15
  16 { + - * / }
  17 [ { number number } "input-classes" set-word-prop ] each
  18
  19 { /f /i mod < > <= >= u< u> u<= u>= }
  20 [ { real real } "input-classes" set-word-prop ] each
  21
  22 \ /mod { rational rational } "input-classes" set-word-prop
  23
  24 { bitand bitor bitxor shift }
  25 [ { integer integer } "input-classes" set-word-prop ] each
  26
  27 \ bitnot { integer } "input-classes" set-word-prop
  28
  29 : math-closure ( class -- newclass )
  30     { fixnum bignum integer rational float real number object }
  31     [ class<= ] with find nip ;
  32
  33 : fits-in-fixnum? ( interval -- ? )
  34     fixnum-interval interval-subset? ;
  35
  36 : won't-overflow? ( class interval -- ? )
  37     [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ;
  38
  39 : may-overflow ( class interval -- class' interval' )
  40     over null-class? [
  41         2dup won't-overflow?
  42         [ [ integer math-class-max ] dip ] unless
  43     ] unless ;
  44
  45 : may-be-rational ( class interval -- class' interval' )
  46     over null-class? [
  47         [ rational math-class-max ] dip
  48     ] unless ;
  49
  50 : ensure-math-class ( class must-be -- class' )
  51     [ class<= ] most ;
  52
  53 : number-valued ( class interval -- class' interval' )
  54     [ number ensure-math-class ] dip ;
  55
  56 : fixnum-valued ( class interval -- class' interval' )
  57     over null-class? [
  58         [ drop fixnum ] dip
  59     ] unless ;
  60
  61 : integer-valued ( class interval -- class' interval' )
  62     [ integer ensure-math-class ] dip ;
  63
  64 : real-valued ( class interval -- class' interval' )
  65     [ real ensure-math-class ] dip ;
  66
  67 : float-valued ( class interval -- class' interval' )
  68     over null-class? [
  69         [ drop float ] dip
  70     ] unless ;
  71
  72 : unary-op-class ( info -- newclass )
  73     class>> dup null-class? [ drop null ] [ math-closure ] if ;
  74
  75 : unary-op-interval ( info quot -- newinterval )
  76     [
  77         dup class>> real classes-intersect?
  78         [ interval>> ] [ drop full-interval ] if
  79     ] dip call ; inline
  80
  81 : unary-op ( word interval-quot post-proc-quot -- )
  82     '[
  83         [ unary-op-class ] [ _ unary-op-interval ] bi
  84         @
  85         <class/interval-info>
  86     ] "outputs" set-word-prop ;
  87
  88 { bitnot fixnum-bitnot bignum-bitnot } [
  89     [ interval-bitnot ] [ integer-valued ] unary-op
  90 ] each
  91
  92 \ abs [ interval-abs ] [ may-overflow real-valued ] unary-op
  93
  94 \ absq [ interval-absq ] [ may-overflow real-valued ] unary-op
  95
  96 : merge-classes ( class1 class2 -- class3 )
  97     2dup [ null-class? ] either? [ 2drop null ] [
  98         [ math-closure ] bi@ math-class-max
  99     ] if ;
 100
 101 : binary-op-class ( info1 info2 -- newclass )
 102     [ class>> ] bi@ merge-classes ;
 103
 104 : binary-op-interval ( info1 info2 quot -- newinterval )
 105     [ [ interval>> ] bi@ ] dip call ; inline
 106
 107 : binary-op ( word interval-quot post-proc-quot -- )
 108     '[
 109         [ binary-op-class ] [ _ binary-op-interval ] 2bi
 110         @
 111         <class/interval-info>
 112     ] "outputs" set-word-prop ;
 113
 114 \ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
 115 \ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
 116
 117 \ - [ [ interval- ] [ may-overflow number-valued ] binary-op ] each-derived-op
 118 \ - [ [ interval- ] [ number-valued ] binary-op ] each-fast-derived-op
 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/-safe ] [ may-be-rational number-valued ] binary-op ] each-derived-op
 124 \ /i [ [ interval/i ] [ may-overflow integer-valued ] binary-op ] each-derived-op
 125 \ /f [ [ interval/f ] [ float-valued ] binary-op ] each-derived-op
 126
 127 : mod-merge-classes/intervals ( c1 c2 i1 i2 -- c3 i3 )
 128     [ merge-classes dup bignum = [ drop integer ] when ]
 129     [ interval-mod ] 2bi*
 130     over integer class<= [
 131         integral-closure dup fixnum-interval interval-subset? [
 132             nip fixnum swap
 133         ] when
 134     ] when ;
 135
 136 : mod-outputs-info ( info1 info2 fixer-word -- info3 )
 137     [
 138         [ [ class>> ] bi@ ] [ [ interval>> ] bi@ ] 2bi
 139         mod-merge-classes/intervals
 140     ] dip execute( cls int -- cls' int' ) <class/interval-info> ;
 141
 142 {
 143     { mod real-valued }
 144     { fmod real-valued }
 145     { mod-integer-integer integer-valued }
 146     { mod-fixnum-integer integer-valued }
 147     { mod-integer-fixnum integer-valued }
 148     { bignum-mod integer-valued }
 149     { fixnum-mod fixnum-valued }
 150 } [ '[ _ mod-outputs-info ] "outputs" set-word-prop ] assoc-each
 151
 152 \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
 153
 154 ! /mod is the combination of /i and mod, fixnum/mod of /i and fixnum-mod
 155 \ /mod
 156 \ /i \ mod [ "outputs" word-prop ] bi@
 157 '[ _ _ 2bi ] "outputs" set-word-prop
 158
 159 \ fixnum/mod
 160 \ /i \ fixnum-mod [ "outputs" word-prop ] bi@
 161 '[ _ _ 2bi ] "outputs" set-word-prop
 162
 163 : shift-op-class ( info1 info2 -- newclass )
 164     [ class>> ] bi@
 165     2dup [ null-class? ] either? [ 2drop null ] [ drop math-closure ] if ;
 166
 167 : shift-op ( word interval-quot post-proc-quot -- )
 168     '[
 169         [ shift-op-class ] [ _ binary-op-interval ] 2bi
 170         @
 171         <class/interval-info>
 172     ] "outputs" set-word-prop ;
 173
 174 \ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] shift-op ] each-derived-op
 175 \ shift [ [ interval-shift-safe ] [ integer-valued ] shift-op ] each-fast-derived-op
 176
 177 \ bitand [ [ interval-bitand ] [ integer-valued ] binary-op ] each-derived-op
 178 \ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
 179 \ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
 180
 181 :: (comparison-constraints) ( in1 in2 op -- constraint )
 182     in1 value-info interval>> :> i1
 183     in2 value-info interval>> :> i2
 184     in1 i1 i2 op assumption is-in-interval
 185     in2 i2 i1 op swap-comparison assumption is-in-interval
 186     2array ;
 187
 188 :: comparison-constraints ( in1 in2 out op -- constraint )
 189     in1 in2 op (comparison-constraints) out t-->
 190     in1 in2 op negate-comparison (comparison-constraints) out f--> 2array ;
 191
 192 : define-comparison-constraints ( word op -- )
 193     '[ _ comparison-constraints ] "constraints" set-word-prop ;
 194
 195 comparison-ops
 196 [ dup '[ _ define-comparison-constraints ] each-derived-op ] each
 197
 198 ! Remove redundant comparisons
 199 : fold-comparison ( info1 info2 word -- info )
 200     [ [ interval>> ] bi@ ] dip interval-comparison {
 201         { incomparable [ object-info ] }
 202         { t [ t <literal-info> ] }
 203         { f [ f <literal-info> ] }
 204     } case ;
 205
 206 comparison-ops [
 207     dup '[
 208         [ _ fold-comparison ] "outputs" set-word-prop
 209     ] each-derived-op
 210 ] each
 211
 212 generic-comparison-ops [
 213     dup specific-comparison
 214     '[ _ fold-comparison ] "outputs" set-word-prop
 215 ] each
 216
 217 : maybe-or-never ( ? -- info )
 218     [ object-info ] [ f <literal-info> ] if ;
 219
 220 : info-intervals-intersect? ( info1 info2 -- ? )
 221     2dup [ class>> real class<= ] both?
 222     [ [ interval>> ] bi@ intervals-intersect? ] [ 2drop t ] if ;
 223
 224 { number= bignum= float= } [
 225     [
 226         info-intervals-intersect? maybe-or-never
 227     ] "outputs" set-word-prop
 228 ] each
 229
 230 : info-classes-intersect? ( info1 info2 -- ? )
 231     [ class>> ] bi@ classes-intersect? ;
 232
 233 \ eq? [
 234     over value-info literal>> fixnum? [
 235         [ value-info literal>> is-equal-to ] dip t-->
 236     ] [ 3drop f ] if
 237 ] "constraints" set-word-prop
 238
 239 \ eq? [
 240     [ info-intervals-intersect? ]
 241     [ info-classes-intersect? ]
 242     2bi and maybe-or-never
 243 ] "outputs" set-word-prop
 244
 245 {
 246     { >fixnum fixnum }
 247     { bignum>fixnum fixnum }
 248     { bignum>fixnum-strict fixnum }
 249     { integer>fixnum fixnum }
 250     { integer>fixnum-strict fixnum }
 251
 252     { >bignum bignum }
 253     { float>bignum bignum }
 254
 255     { >float float }
 256     { bignum>float float }
 257
 258     { >integer integer }
 259 } [
 260     '[ _ swap interval>> <class/interval-info> ] "outputs" set-word-prop
 261 ] assoc-each
 262
 263 ! For these we limit the outputted interval
 264 {
 265     { fixnum>bignum bignum }
 266     { fixnum>float float }
 267 } [
 268     '[
 269         _ swap interval>> fixnum-interval interval-intersect
 270         <class/interval-info>
 271     ] "outputs" set-word-prop
 272 ] assoc-each
 273
 274 {
 275     { >array array }
 276     { >vector vector }
 277     { >string string }
 278     { >sbuf sbuf }
 279     { >byte-array byte-array }
 280     { >byte-vector byte-vector }
 281     { >hashtable hashtable }
 282 } [
 283     '[ drop _ <class-info> ] "outputs" set-word-prop
 284 ] assoc-each
 285
 286 { numerator denominator }
 287 [ [ drop integer <class-info> ] "outputs" set-word-prop ] each
 288
 289 \ >fraction [
 290     drop integer <class-info> dup
 291 ] "outputs" set-word-prop
 292
 293 { (log2) fixnum-log2 bignum-log2 } [
 294     [
 295         [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
 296     ] "outputs" set-word-prop
 297 ] each
 298
 299 \ string-nth-fast [
 300     2drop fixnum 0 255 [a,b] <class/interval-info>
 301 ] "outputs" set-word-prop
 302
 303 {
 304     alien-signed-1
 305     alien-unsigned-1
 306     alien-signed-2
 307     alien-unsigned-2
 308     alien-signed-4
 309     alien-unsigned-4
 310     alien-signed-8
 311     alien-unsigned-8
 312 } [
 313     dup name>> {
 314         { [ "alien-signed-" ?head ] [ string>number (signed-interval) ] }
 315         { [ "alien-unsigned-" ?head ] [ string>number (unsigned-interval) ] }
 316     } cond [a,b]
 317     [ fits-in-fixnum? fixnum integer ? ] keep <class/interval-info>
 318     '[ 2drop _ ] "outputs" set-word-prop
 319 ] each
 320
 321 \ alien-cell [
 322     2drop alien \ f class-or <class-info>
 323 ] "outputs" set-word-prop
 324
 325 \ <displaced-alien> [
 326     [ interval>> 0 swap interval-contains? ] dip
 327     class>> alien class-or alien ? <class-info>
 328 ] "outputs" set-word-prop
 329
 330 { <tuple> <tuple-boa> } [
 331     [
 332         literal>> dup array? [ first ] [ drop tuple ] if <class-info>
 333         [ clear ] dip
 334     ] "outputs" set-word-prop
 335 ] each
 336
 337 \ new [
 338     literal>> dup tuple-class? [ drop tuple ] unless <class-info>
 339 ] "outputs" set-word-prop
 340
 341 ! the output of (clone) has the same type as the input
 342 : cloned-value-info ( value-info -- value-info' )
 343     clone f >>literal f >>literal?
 344     [ [ dup [ cloned-value-info ] when ] map ] change-slots ;
 345
 346 \ (clone) [ cloned-value-info ] "outputs" set-word-prop
 347
 348 \ slot [
 349     dup literal?>>
 350     [ literal>> swap value-info-slot ] [ 2drop object-info ] if
 351 ] "outputs" set-word-prop
 352
 353 \ instance? [
 354     [ value-info ] dip over literal>> classoid? [
 355         [ literal>> ] dip predicate-constraints
 356     ] [ 3drop f ] if
 357 ] "constraints" set-word-prop
 358
 359 \ instance? [
 360     ! We need to force the caller word to recompile when the class
 361     ! is redefined, since now we're making assumptions about the
 362     ! class definition itself.
 363     dup literal>> classoid?
 364     [
 365         literal>>
 366         [ add-depends-on-class ]
 367         [ predicate-output-infos ]
 368         bi
 369     ] [ 2drop object-info ] if
 370 ] "outputs" set-word-prop
 371
 372 ! Unlike the other words in math.libm, fsqrt is not inline
 373 ! since it has an intrinsic, so we need to give it outputs here.
 374 \ fsqrt { float } "default-output-classes" set-word-prop
 375
 376 ! Find a less repetitive way of doing this
 377 \ float-min { float float } "input-classes" set-word-prop
 378 \ float-min [ interval-min ] [ float-valued ] binary-op
 379
 380 \ float-max { float float } "input-classes" set-word-prop
 381 \ float-max [ interval-max ] [ float-valued ] binary-op
 382
 383 \ fixnum-min { fixnum fixnum } "input-classes" set-word-prop
 384 \ fixnum-min [ interval-min ] [ fixnum-valued ] binary-op
 385
 386 \ fixnum-max { fixnum fixnum } "input-classes" set-word-prop
 387 \ fixnum-max [ interval-max ] [ fixnum-valued ] binary-op
 388
 389 \ local-allot { alien } "default-output-classes" set-word-prop
 390
 391 \ tag [
 392     drop fixnum 0 num-types get [a,b) <class/interval-info>
 393 ] "outputs" set-word-prop
 394
 395 ! Primitive resize operations
 396
 397 : propagate-resize-fixed-length-sequence ( n-info in-info class -- out-info )
 398     nip <sequence-info> ;
 399
 400 { { resize-array array }
 401   { resize-byte-array byte-array }
 402   { resize-string string } }
 403 [
 404     [ propagate-resize-fixed-length-sequence ] curry
 405     "outputs" set-word-prop
 406 ] assoc-each