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

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