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