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
  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 ! generic-comparison-ops [
 152 !     dup specific-comparison define-comparison-constraints
 153 ! ] each
 154
 155 ! Remove redundant comparisons
 156 : fold-comparison ( info1 info2 word -- info )
 157     [ [ interval>> ] bi@ ] dip interval-comparison {
 158         { incomparable [ object-info ] }
 159         { t [ t <literal-info> ] }
 160         { f [ f <literal-info> ] }
 161     } case ;
 162
 163 comparison-ops [
 164     dup '[
 165         [ _ fold-comparison ] "outputs" set-word-prop
 166     ] each-derived-op
 167 ] each
 168
 169 generic-comparison-ops [
 170     dup specific-comparison
 171     '[ _ fold-comparison ] "outputs" set-word-prop
 172 ] each
 173
 174 : maybe-or-never ( ? -- info )
 175     [ object-info ] [ f <literal-info> ] if ;
 176
 177 : info-intervals-intersect? ( info1 info2 -- ? )
 178     [ interval>> ] bi@ intervals-intersect? ;
 179
 180 { number= bignum= float= } [
 181     [
 182         info-intervals-intersect? maybe-or-never
 183     ] "outputs" set-word-prop
 184 ] each
 185
 186 : info-classes-intersect? ( info1 info2 -- ? )
 187     [ class>> ] bi@ classes-intersect? ;
 188
 189 \ eq? [
 190     over value-info literal>> fixnum? [
 191         [ value-info literal>> is-equal-to ] dip t-->
 192     ] [ 3drop f ] if
 193 ] "constraints" set-word-prop
 194
 195 \ eq? [
 196     [ info-intervals-intersect? ]
 197     [ info-classes-intersect? ]
 198     2bi and maybe-or-never
 199 ] "outputs" set-word-prop
 200
 201 \ both-fixnums? [
 202     [ class>> fixnum classes-intersect? not ] either?
 203     f <literal-info> object-info ?
 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     '[
 219         _
 220         [ nip ] [
 221             [ interval>> ] [ class-interval ] bi*
 222             interval-intersect
 223         ] 2bi
 224         <class/interval-info>
 225     ] "outputs" set-word-prop
 226 ] assoc-each
 227
 228 {
 229     mod-integer-integer
 230     mod-integer-fixnum
 231     mod-fixnum-integer
 232     fixnum-mod
 233     rem
 234 } [
 235     [
 236         in-d>> second value-info >literal<
 237         [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
 238     ] "custom-inlining" set-word-prop
 239 ] each
 240
 241 {
 242     bitand-integer-integer
 243     bitand-integer-fixnum
 244     bitand-fixnum-integer
 245 } [
 246     [
 247         in-d>> second value-info >literal< [
 248             0 most-positive-fixnum between?
 249             [ [ >fixnum ] bi@ fixnum-bitand ] f ?
 250         ] when
 251     ] "custom-inlining" set-word-prop
 252 ] each
 253
 254 { numerator denominator }
 255 [ [ drop integer <class-info> ] "outputs" set-word-prop ] each
 256
 257 { (log2) fixnum-log2 bignum-log2 } [
 258     [
 259         [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
 260     ] "outputs" set-word-prop
 261 ] each
 262
 263 \ string-nth [
 264     2drop fixnum 0 23 2^ [a,b] <class/interval-info>
 265 ] "outputs" set-word-prop
 266
 267 {
 268     alien-signed-1
 269     alien-unsigned-1
 270     alien-signed-2
 271     alien-unsigned-2
 272     alien-signed-4
 273     alien-unsigned-4
 274     alien-signed-8
 275     alien-unsigned-8
 276 } [
 277     dup name>> {
 278         {
 279             [ "alien-signed-" ?head ]
 280             [ string>number 8 * 1- 2^ dup neg swap 1- [a,b] ]
 281         }
 282         {
 283             [ "alien-unsigned-" ?head ]
 284             [ string>number 8 * 2^ 1- 0 swap [a,b] ]
 285         }
 286     } cond
 287     [ fixnum fits? fixnum integer ? ] keep <class/interval-info>
 288     '[ 2drop _ ] "outputs" set-word-prop
 289 ] each
 290
 291 { <tuple> <tuple-boa> } [
 292     [
 293         literal>> dup array? [ first ] [ drop tuple ] if <class-info>
 294         [ clear ] dip
 295     ] "outputs" set-word-prop
 296 ] each
 297
 298 \ new [
 299     literal>> dup tuple-class? [ drop tuple ] unless <class-info>
 300 ] "outputs" set-word-prop
 301
 302 ! the output of clone has the same type as the input
 303 { clone (clone) } [
 304     [ clone f >>literal f >>literal? ]
 305     "outputs" set-word-prop
 306 ] each
 307
 308 ! Generate more efficient code for common idiom
 309 \ clone [
 310     in-d>> first value-info literal>> {
 311         { V{ } [ [ drop { } 0 vector boa ] ] }
 312         { H{ } [ [ drop hashtable new ] ] }
 313         [ drop f ]
 314     } case
 315 ] "custom-inlining" set-word-prop
 316
 317 \ slot [
 318     dup literal?>>
 319     [ literal>> swap value-info-slot ] [ 2drop object-info ] if
 320 ] "outputs" set-word-prop
 321
 322 \ instance? [
 323     [ value-info ] dip over literal>> class? [
 324         [ literal>> ] dip predicate-constraints
 325     ] [ 3drop f ] if
 326 ] "constraints" set-word-prop
 327
 328 \ instance? [
 329     ! We need to force the caller word to recompile when the class
 330     ! is redefined, since now we're making assumptions but the
 331     ! class definition itself.
 332     dup literal>> class?
 333     [
 334         literal>>
 335         [ inlined-dependency depends-on ]
 336         [ predicate-output-infos ]
 337         bi
 338     ] [ 2drop object-info ] if
 339 ] "outputs" set-word-prop