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