core/optimizer/math/math.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: effects alien alien.accessors arrays generic hashtables
   4 kernel assocs math math.libm math.private kernel.private
   5 sequences words parser vectors strings sbufs io namespaces
   6 assocs quotations math.intervals sequences.private combinators
   7 splitting layouts math.parser classes classes.algebra
   8 generic.math inference.class inference.dataflow
   9 optimizer.pattern-match optimizer.backend optimizer.def-use
  10 optimizer.inlining optimizer.math.partial generic.standard
  11 system accessors ;
  12 IN: optimizer.math
  13
  14 : define-math-identities ( word identities -- )
  15     >r all-derived-ops r> define-identities ;
  16
  17 \ number= {
  18     { { @ @ } [ 2drop t ] }
  19 } define-math-identities
  20
  21 \ + {
  22     { { number 0 } [ drop ] }
  23     { { 0 number } [ nip ] }
  24 } define-math-identities
  25
  26 \ - {
  27     { { number 0 } [ drop ] }
  28     { { @ @ } [ 2drop 0 ] }
  29 } define-math-identities
  30
  31 \ < {
  32     { { @ @ } [ 2drop f ] }
  33 } define-math-identities
  34
  35 \ <= {
  36     { { @ @ } [ 2drop t ] }
  37 } define-math-identities
  38
  39 \ > {
  40     { { @ @ } [ 2drop f ] }
  41 } define-math-identities
  42
  43 \ >= {
  44     { { @ @ } [ 2drop t ] }
  45 } define-math-identities
  46
  47 \ * {
  48     { { number 1 } [ drop ] }
  49     { { 1 number } [ nip ] }
  50     { { number 0 } [ nip ] }
  51     { { 0 number } [ drop ] }
  52     { { number -1 } [ drop 0 swap - ] }
  53     { { -1 number } [ nip 0 swap - ] }
  54 } define-math-identities
  55
  56 \ / {
  57     { { number 1 } [ drop ] }
  58     { { number -1 } [ drop 0 swap - ] }
  59 } define-math-identities
  60
  61 \ mod {
  62     { { integer 1 } [ 2drop 0 ] }
  63 } define-math-identities
  64
  65 \ rem {
  66     { { integer 1 } [ 2drop 0 ] }
  67 } define-math-identities
  68
  69 \ bitand {
  70     { { number -1 } [ drop ] }
  71     { { -1 number } [ nip ] }
  72     { { @ @ } [ drop ] }
  73     { { number 0 } [ nip ] }
  74     { { 0 number } [ drop ] }
  75 } define-math-identities
  76
  77 \ bitor {
  78     { { number 0 } [ drop ] }
  79     { { 0 number } [ nip ] }
  80     { { @ @ } [ drop ] }
  81     { { number -1 } [ nip ] }
  82     { { -1 number } [ drop ] }
  83 } define-math-identities
  84
  85 \ bitxor {
  86     { { number 0 } [ drop ] }
  87     { { 0 number } [ nip ] }
  88     { { number -1 } [ drop bitnot ] }
  89     { { -1 number } [ nip bitnot ] }
  90     { { @ @ } [ 2drop 0 ] }
  91 } define-math-identities
  92
  93 \ shift {
  94     { { 0 number } [ drop ] }
  95     { { number 0 } [ drop ] }
  96 } define-math-identities
  97
  98 : math-closure ( class -- newclass )
  99     { null fixnum bignum integer rational float real number }
 100     [ class<= ] with find nip number or ;
 101
 102 : fits? ( interval class -- ? )
 103     "interval" word-prop dup
 104     [ interval-subset? ] [ 2drop t ] if ;
 105
 106 : math-output-class ( node upgrades -- newclass )
 107     >r
 108     in-d>> null [ value-class* math-closure math-class-max ] reduce
 109     dup r> at swap or ;
 110
 111 : won't-overflow? ( interval node -- ? )
 112     node-in-d [ value-class* fixnum class<= ] all?
 113     swap fixnum fits? and ;
 114
 115 : post-process ( class interval node -- classes intervals )
 116     dupd won't-overflow?
 117     [ >r dup { f integer } member? [ drop fixnum ] when r> ] when
 118     [ dup [ 1array ] when ] bi@ ;
 119
 120 : math-output-interval-1 ( node word -- interval )
 121     dup [
 122         >r node-in-d first value-interval* dup
 123         [ r> execute ] [ r> 2drop f ] if
 124     ] [
 125         2drop f
 126     ] if ; inline
 127
 128 : math-output-class/interval-1 ( node word -- classes intervals )
 129     [ drop { } math-output-class 1array ]
 130     [ math-output-interval-1 1array ] 2bi ;
 131
 132 {
 133     { bitnot interval-bitnot }
 134     { fixnum-bitnot interval-bitnot }
 135     { bignum-bitnot interval-bitnot }
 136 } [
 137     [ math-output-class/interval-1 ] curry
 138     "output-classes" set-word-prop
 139 ] assoc-each
 140
 141 : intervals ( node -- i1 i2 )
 142     node-in-d first2 [ value-interval* ] bi@ ;
 143
 144 : math-output-interval-2 ( node word -- interval )
 145     dup [
 146         >r intervals 2dup and [ r> execute ] [ r> 3drop f ] if
 147     ] [
 148         2drop f
 149     ] if ; inline
 150
 151 : math-output-class/interval-2 ( node upgrades word -- classes intervals )
 152     pick >r
 153     >r over r>
 154     math-output-interval-2
 155     >r math-output-class r>
 156     r> post-process ; inline
 157
 158 {
 159     { + { { fixnum integer } } interval+ }
 160     { - { { fixnum integer } } interval- }
 161     { * { { fixnum integer } } interval* }
 162     { / { { fixnum rational } { integer rational } } interval/-safe }
 163     { /i { { fixnum integer } } interval/i }
 164     { shift { { fixnum integer } } interval-shift-safe }
 165 } [
 166     first3 [
 167         [
 168             math-output-class/interval-2
 169         ] 2curry "output-classes" set-word-prop
 170     ] 2curry each-derived-op
 171 ] each
 172
 173 : math-output-class/interval-2-fast ( node word -- classes intervals )
 174     math-output-interval-2 fixnum [ 1array ] bi@ swap ; inline
 175
 176 [
 177     { + interval+ }
 178     { - interval- }
 179     { * interval* }
 180     { shift interval-shift-safe }
 181 ] [
 182     first2 [
 183         [
 184             math-output-class/interval-2-fast
 185         ] curry "output-classes" set-word-prop
 186     ] curry each-fast-derived-op
 187 ] each
 188
 189 : real-value? ( value -- n ? )
 190     dup value? [ value-literal dup real? ] [ drop f f ] if ;
 191
 192 : mod-range ( n -- interval )
 193     dup neg swap (a,b) ;
 194
 195 : rem-range ( n -- interval )
 196     0 swap [a,b) ;
 197
 198 : bitand-range ( n -- interval )
 199     dup 0 < [ drop f ] [ 0 swap [a,b] ] if ;
 200
 201 : math-output-interval-special ( node word -- interval )
 202     dup [
 203         >r node-in-d second real-value?
 204         [ r> execute ] [ r> 2drop f ] if
 205     ] [
 206         2drop f
 207     ] if ; inline
 208
 209 : math-output-class/interval-special ( node min word -- classes intervals )
 210     pick >r
 211     >r over r>
 212     math-output-interval-special
 213     >r math-output-class r>
 214     r> post-process ; inline
 215
 216 {
 217     { mod { } mod-range }
 218     { rem { { fixnum integer } } rem-range }
 219
 220     { bitand { } bitand-range }
 221     { bitor { } f }
 222     { bitxor { } f }
 223 } [
 224     first3 [
 225         [
 226             math-output-class/interval-special
 227         ] 2curry "output-classes" set-word-prop
 228     ] 2curry each-derived-op
 229 ] each
 230
 231 : twiddle-interval ( i1 -- i2 )
 232     dup [
 233         node get node-in-d
 234         [ value-class* integer class<= ] all?
 235         [ integral-closure ] when
 236     ] when ;
 237
 238 : (comparison-constraints) ( i1 i2 word class -- )
 239     node get [
 240         >r execute twiddle-interval 0 `input interval,
 241         r> 0 `output class,
 242     ] set-constraints ; inline
 243
 244 : comparison-constraints ( node true false -- )
 245     >r >r dup node set intervals dup [
 246         2dup
 247         r> \ f class-not (comparison-constraints)
 248         r> \ f (comparison-constraints)
 249     ] [
 250         r> r> 2drop 2drop
 251     ] if ; inline
 252
 253 {
 254     { < assume< assume>= }
 255     { <= assume<= assume> }
 256     { > assume> assume<= }
 257     { >= assume>= assume< }
 258 } [
 259     first3 [
 260         [
 261             [ comparison-constraints ] with-scope
 262         ] 2curry "constraints" set-word-prop
 263     ] 2curry each-derived-op
 264 ] each
 265
 266 {
 267     alien-signed-1
 268     alien-unsigned-1
 269     alien-signed-2
 270     alien-unsigned-2
 271     alien-signed-4
 272     alien-unsigned-4
 273     alien-signed-8
 274     alien-unsigned-8
 275 } [
 276     dup name>> {
 277         {
 278             [ "alien-signed-" ?head ]
 279             [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
 280         }
 281         {
 282             [ "alien-unsigned-" ?head ]
 283             [ string>number 8 * 2^ 1- 0 swap [a,b] ]
 284         }
 285     } cond 1array
 286     [ nip f swap ] curry "output-classes" set-word-prop
 287 ] each
 288
 289 ! Associate intervals to classes
 290 \ fixnum
 291 most-negative-fixnum most-positive-fixnum [a,b]
 292 "interval" set-word-prop
 293
 294 \ array-capacity
 295 0 max-array-capacity [a,b]
 296 "interval" set-word-prop
 297
 298 {
 299     { >fixnum fixnum }
 300     { >bignum bignum }
 301     { >float float }
 302 } [
 303     [
 304         over node-in-d first value-interval*
 305         dup pick fits? [ drop f ] unless
 306         rot post-process
 307     ] curry "output-classes" set-word-prop
 308 ] assoc-each
 309
 310 ! Removing overflow checks
 311 : remove-overflow-check? ( #call -- ? )
 312     dup out-d>> first node-class
 313     [ fixnum class<= ] [ null eq? not ] bi and ;
 314
 315 {
 316     { + [ fixnum+fast ] }
 317     { +-integer-fixnum [ fixnum+fast ] }
 318     { - [ fixnum-fast ] }
 319     { * [ fixnum*fast ] }
 320     { *-integer-fixnum [ fixnum*fast ] }
 321     { shift [ fixnum-shift-fast ] }
 322     { fixnum+ [ fixnum+fast ] }
 323     { fixnum- [ fixnum-fast ] }
 324     { fixnum* [ fixnum*fast ] }
 325     { fixnum-shift [ fixnum-shift-fast ] }
 326 } [
 327     [
 328         [ dup remove-overflow-check? ] ,
 329         [ f splice-quot ] curry ,
 330     ] { } make 1array define-optimizers
 331 ] assoc-each
 332
 333 ! Remove redundant comparisons
 334 : intervals-first2 ( #call -- first second )
 335     dup dup node-in-d first node-interval
 336     swap dup node-in-d second node-interval ;
 337
 338 : known-comparison? ( #call -- ? )
 339     intervals-first2 and ;
 340
 341 : perform-comparison ( #call word -- result )
 342     >r intervals-first2 r> execute ; inline
 343
 344 : foldable-comparison? ( #call word -- ? )
 345     >r dup known-comparison? [
 346         r> perform-comparison incomparable eq? not
 347     ] [
 348         r> 2drop f
 349     ] if ; inline
 350
 351 : fold-comparison ( #call word -- node )
 352     dupd perform-comparison 1array inline-literals ;
 353
 354 {
 355     { < interval< }
 356     { <= interval<= }
 357     { > interval> }
 358     { >= interval>= }
 359 } [
 360     [
 361         [
 362             dup [ dupd foldable-comparison? ] curry ,
 363             [ fold-comparison ] curry ,
 364         ] { } make 1array define-optimizers
 365     ] curry each-derived-op
 366 ] assoc-each
 367
 368 ! The following words are handled in a similar way except if
 369 ! the only consumer is a >fixnum we remove the overflow check
 370 ! too
 371 : consumed-by? ( node word -- ? )
 372     swap sole-consumer
 373     dup #call? [ node-param eq? ] [ 2drop f ] if ;
 374
 375 : coerced-to-fixnum? ( #call -- ? )
 376     dup dup node-in-d [ node-class integer class<= ] with all?
 377     [ \ >fixnum consumed-by? ] [ drop f ] if ;
 378
 379 {
 380     { + [ [ >fixnum ] bi@ fixnum+fast ] }
 381     { - [ [ >fixnum ] bi@ fixnum-fast ] }
 382     { * [ [ >fixnum ] bi@ fixnum*fast ] }
 383 } [
 384     >r derived-ops r> [
 385         [
 386             [
 387                 dup remove-overflow-check?
 388                 over coerced-to-fixnum? or
 389             ] ,
 390             [ f splice-quot ] curry ,
 391         ] { } make 1array define-optimizers
 392     ] curry each
 393 ] assoc-each
 394
 395 : convert-rem-to-and? ( #call -- ? )
 396     dup node-in-d {
 397         { [ 2dup first node-class integer class<= not ] [ f ] }
 398         { [ 2dup second node-literal integer? not ] [ f ] }
 399         { [ 2dup second node-literal power-of-2? not ] [ f ] }
 400         [ t ]
 401     } cond 2nip ;
 402
 403 : convert-mod-to-and? ( #call -- ? )
 404     dup dup node-in-d first node-interval 0 [a,inf] interval-subset?
 405     [ convert-rem-to-and? ] [ drop f ] if ;
 406
 407 : convert-mod-to-and ( #call -- node )
 408     dup
 409     dup in-d>> second node-literal 1-
 410     [ nip bitand ] curry f splice-quot ;
 411
 412 \ mod [
 413     {
 414         {
 415             [ dup convert-mod-to-and? ]
 416             [ convert-mod-to-and ]
 417         }
 418     } define-optimizers
 419 ] each-derived-op
 420
 421 \ rem {
 422     {
 423         [ dup convert-rem-to-and? ]
 424         [ convert-mod-to-and ]
 425     }
 426 } define-optimizers
 427
 428 : fixnumify-bitand? ( #call -- ? )
 429     dup node-in-d second node-interval fixnum fits? ;
 430
 431 : fixnumify-bitand ( #call -- node )
 432     [ [ >fixnum ] bi@ fixnum-bitand ] f splice-quot ;
 433
 434 \ bitand {
 435     {
 436         [ dup fixnumify-bitand? ]
 437         [ fixnumify-bitand ]
 438     }
 439 } define-optimizers
 440
 441 : convert-*-to-shift? ( #call -- ? )
 442     dup in-d>> second node-literal
 443     dup integer? [ power-of-2? ] [ drop f ] if ;
 444
 445 : convert-*-to-shift ( #call -- ? )
 446     dup dup in-d>> second node-literal log2
 447     [ nip fixnum-shift-fast ] curry
 448     f splice-quot ;
 449
 450 \ fixnum*fast {
 451     { [ dup convert-*-to-shift? ] [ convert-*-to-shift ] }
 452 } define-optimizers
 453
 454 { + - * / }
 455 [ { number number } "input-classes" set-word-prop ] each
 456
 457 { /f < > <= >= }
 458 [ { real real } "input-classes" set-word-prop ] each
 459
 460 { /i mod /mod }
 461 [ { rational rational } "input-classes" set-word-prop ] each
 462
 463 { bitand bitor bitxor bitnot shift }
 464 [ { integer integer } "input-classes" set-word-prop ] each
 465
 466 {
 467     fcosh
 468     flog
 469     fsinh
 470     fexp
 471     fasin
 472     facosh
 473     fasinh
 474     ftanh
 475     fatanh
 476     facos
 477     fpow
 478     fatan
 479     fatan2
 480     fcos
 481     ftan
 482     fsin
 483     fsqrt
 484 } [
 485     dup stack-effect
 486     [ in>> length real <repetition> "input-classes" set-word-prop ]
 487     [ out>> length float <repetition> "default-output-classes" set-word-prop ]
 488     2bi
 489 ] each