core/optimizer/math/math.factor

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