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