basis/compiler/tree/propagation/transforms/transforms.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien.c-types kernel sequences words fry generic accessors
   4 classes.tuple classes classes.algebra definitions
   5 stack-checker.dependencies quotations classes.tuple.private math
   6 math.partial-dispatch math.private math.intervals sets.private
   7 math.floats.private math.integers.private layouts math.order
   8 vectors hashtables combinators effects generalizations assocs
   9 sets combinators.short-circuit sequences.private locals growable
  10 stack-checker namespaces compiler.tree.propagation.info ;
  11 FROM: math => float ;
  12 IN: compiler.tree.propagation.transforms
  13
  14 \ equal? [
  15     ! If first input has a known type and second input is an
  16     ! object, we convert this to [ swap equal? ].
  17     in-d>> first2 value-info class>> object class= [
  18         value-info class>> \ equal? method-for-class
  19         [ swap equal? ] f ?
  20     ] [ drop f ] if
  21 ] "custom-inlining" set-word-prop
  22
  23 : rem-custom-inlining ( #call -- quot/f )
  24     second value-info literal>> dup integer?
  25     [ power-of-2? [ 1 - bitand ] f ? ] [ drop f ] if ;
  26
  27 {
  28     mod-integer-integer
  29     mod-integer-fixnum
  30     mod-fixnum-integer
  31     fixnum-mod
  32 } [
  33     [
  34         in-d>> dup first value-info interval>> [0,inf] interval-subset?
  35         [ rem-custom-inlining ] [ drop f ] if
  36     ] "custom-inlining" set-word-prop
  37 ] each
  38
  39 \ rem [
  40     in-d>> rem-custom-inlining
  41 ] "custom-inlining" set-word-prop
  42
  43 : positive-fixnum? ( obj -- ? )
  44     { [ fixnum? ] [ 0 >= ] } 1&& ;
  45
  46 : simplify-bitand? ( value1 value2 -- ? )
  47     [ literal>> positive-fixnum? ]
  48     [ class>> fixnum swap class<= ]
  49     bi* and ;
  50
  51 : all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline
  52
  53 : redundant-bitand? ( value1 value2 -- ? )
  54     [ interval>> ] [ literal>> ] bi* {
  55         [ nip integer? ]
  56         [ nip all-ones? ]
  57         [ 0 swap [a,b] interval-subset? ]
  58     } 2&& ;
  59
  60 : zero-bitand? ( value1 value2 -- ? )
  61     [ interval>> ] [ literal>> ] bi* {
  62         [ nip integer? ]
  63         [ nip bitnot all-ones? ]
  64         [ 0 swap bitnot [a,b] interval-subset? ]
  65     } 2&& ;
  66
  67 {
  68     bitand-integer-integer
  69     bitand-integer-fixnum
  70     bitand-fixnum-integer
  71     bitand
  72 } [
  73     [
  74         in-d>> first2 [ value-info ] bi@ {
  75             {
  76                 [ 2dup zero-bitand? ]
  77                 [ 2drop [ 2drop 0 ] ]
  78             }
  79             {
  80                 [ 2dup swap zero-bitand? ]
  81                 [ 2drop [ 2drop 0 ] ]
  82             }
  83             {
  84                 [ 2dup redundant-bitand? ]
  85                 [ 2drop [ drop ] ]
  86             }
  87             {
  88                 [ 2dup swap redundant-bitand? ]
  89                 [ 2drop [ nip ] ]
  90             }
  91             {
  92                 [ 2dup simplify-bitand? ]
  93                 [ 2drop [ >fixnum fixnum-bitand ] ]
  94             }
  95             {
  96                 [ 2dup swap simplify-bitand? ]
  97                 [ 2drop [ [ >fixnum ] dip fixnum-bitand ] ]
  98             }
  99             [ 2drop f ]
 100         } cond
 101     ] "custom-inlining" set-word-prop
 102 ] each
 103
 104 ! Speeds up 2^
 105 : 2^? ( #call -- ? )
 106     in-d>> first2 [ value-info ] bi@
 107     [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ]
 108     [ class>> fixnum class<= ]
 109     bi* and ;
 110
 111 \ shift [
 112      2^? [
 113         cell-bits tag-bits get - 1 -
 114         '[
 115             >fixnum dup 0 < [ 2drop 0 ] [
 116                 dup _ < [ fixnum-shift ] [
 117                     fixnum-shift
 118                 ] if
 119             ] if
 120         ]
 121     ] [ f ] if
 122 ] "custom-inlining" set-word-prop
 123
 124 { /i fixnum/i fixnum/i-fast bignum/i } [
 125     [
 126         in-d>> first2 [ value-info ] bi@ {
 127             [ drop class>> integer class<= ]
 128             [ drop interval>> 0 [a,a] interval>= ]
 129             [ nip literal>> integer? ]
 130             [ nip literal>> power-of-2? ]
 131         } 2&& [ [ log2 neg shift ] ] [ f ] if
 132     ] "custom-inlining" set-word-prop
 133 ] each
 134
 135 ! Generate more efficient code for common idiom
 136 \ clone [
 137     in-d>> first value-info literal>> {
 138         { V{ } [ [ drop { } 0 vector boa ] ] }
 139         { H{ } [ [ drop 0 <hashtable> ] ] }
 140         [ drop f ]
 141     } case
 142 ] "custom-inlining" set-word-prop
 143
 144 ERROR: bad-partial-eval quot word ;
 145
 146 : check-effect ( quot word -- )
 147     2dup [ infer ] [ stack-effect ] bi* effect<=
 148     [ 2drop ] [ bad-partial-eval ] if ;
 149
 150 :: define-partial-eval ( word quot n -- )
 151     word [
 152         in-d>> n tail*
 153         [ value-info ] map
 154         dup [ literal?>> ] all? [
 155             [ literal>> ] map
 156             n firstn
 157             quot call dup [
 158                 [ n ndrop ] prepose
 159                 dup word check-effect
 160             ] when
 161         ] [ drop f ] if
 162     ] "custom-inlining" set-word-prop ;
 163
 164 : inline-new ( class -- quot/f )
 165     dup tuple-class? [
 166         dup tuple-layout
 167         [ depends-on-tuple-layout ]
 168         [ drop all-slots [ initial>> literalize ] [ ] map-as ]
 169         [ nip ]
 170         2tri
 171         '[ @ _ <tuple-boa> ]
 172     ] [ drop f ] if ;
 173
 174 \ new [ inline-new ] 1 define-partial-eval
 175
 176 \ instance? [
 177     dup class?
 178     [ "predicate" word-prop ] [ drop f ] if
 179 ] 1 define-partial-eval
 180
 181 ! Shuffling
 182 : nths-quot ( indices -- quot )
 183     [ [ '[ _ swap nth ] ] map ] [ length ] bi
 184     '[ _ cleave _ narray ] ;
 185
 186 \ shuffle [
 187     shuffle-mapping nths-quot
 188 ] 1 define-partial-eval
 189
 190 ! Index search
 191 \ index [
 192     dup sequence? [
 193         dup length 4 >= [
 194             dup length iota zip >hashtable '[ _ at ]
 195         ] [ drop f ] if
 196     ] [ drop f ] if
 197 ] 1 define-partial-eval
 198
 199 : member-eq-quot ( seq -- newquot )
 200     [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
 201     [ drop f ] suffix [ cond ] curry ;
 202
 203 \ member-eq? [
 204     dup sequence? [ member-eq-quot ] [ drop f ] if
 205 ] 1 define-partial-eval
 206
 207 ! Membership testing
 208 : member-quot ( seq -- newquot )
 209     dup length 4 <= [
 210         [ drop f ] swap
 211         [ literalize [ t ] ] { } map>assoc linear-case-quot
 212     ] [
 213         unique [ key? ] curry
 214     ] if ;
 215
 216 \ member? [
 217     dup sequence? [ member-quot ] [ drop f ] if
 218 ] 1 define-partial-eval
 219
 220 ! Fast at for integer maps
 221 CONSTANT: lookup-table-at-max 256
 222
 223 : lookup-table-at? ( assoc -- ? )
 224     #! Can we use a fast byte array test here?
 225     {
 226         [ assoc-size 4 > ]
 227         [ values [ ] all? ]
 228         [ keys [ integer? ] all? ]
 229         [ keys [ 0 lookup-table-at-max between? ] all? ]
 230     } 1&& ;
 231
 232 : lookup-table-seq ( assoc -- table )
 233     [ keys supremum 1 + iota ] keep '[ _ at ] { } map-as ;
 234
 235 : lookup-table-quot ( seq -- newquot )
 236     lookup-table-seq
 237     '[
 238         _ over integer? [
 239             2dup bounds-check? [
 240                 nth-unsafe dup >boolean
 241             ] [ 2drop f f ] if
 242         ] [ 2drop f f ] if
 243     ] ;
 244
 245 : fast-lookup-table-at? ( assoc -- ? )
 246     values {
 247         [ [ integer? ] all? ]
 248         [ [ 0 254 between? ] all? ]
 249     } 1&& ;
 250
 251 : fast-lookup-table-seq ( assoc -- table )
 252     lookup-table-seq [ 255 or ] B{ } map-as ;
 253
 254 : fast-lookup-table-quot ( seq -- newquot )
 255     fast-lookup-table-seq
 256     '[
 257         _ over integer? [
 258             2dup bounds-check? [
 259                 nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
 260             ] [ 2drop f f ] if
 261         ] [ 2drop f f ] if
 262     ] ;
 263
 264 : at-quot ( assoc -- quot )
 265     dup assoc? [
 266         dup lookup-table-at? [
 267             dup fast-lookup-table-at? [
 268                 fast-lookup-table-quot
 269             ] [
 270                 lookup-table-quot
 271             ] if
 272         ] [ drop f ] if
 273     ] [ drop f ] if ;
 274
 275 \ at* [ at-quot ] 1 define-partial-eval
 276
 277 : diff-quot ( seq -- quot: ( seq' -- seq'' ) )
 278     tester '[ [ @ not ] filter ] ;
 279
 280 \ diff [ diff-quot ] 1 define-partial-eval
 281
 282 : intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
 283     tester '[ _ filter ] ;
 284
 285 \ intersect [ intersect-quot ] 1 define-partial-eval
 286
 287 : fixnum-bits ( -- n )
 288     cell-bits tag-bits get - ;
 289
 290 : bit-quot ( #call -- quot/f )
 291     in-d>> second value-info interval>> 0 fixnum-bits [a,b] interval-subset?
 292     [ [ >fixnum ] dip fixnum-bit? ] f ? ;
 293
 294 \ bit? [ bit-quot ] "custom-inlining" set-word-prop
 295
 296 ! Speeds up sum-file, sort and reverse-complement benchmarks by
 297 ! compiling decoder-readln better
 298 \ push [
 299     in-d>> second value-info class>> growable class<=
 300     [ \ push def>> ] [ f ] if
 301 ] "custom-inlining" set-word-prop
 302
 303 ! We want to constant-fold calls to heap-size, and recompile those
 304 ! calls when a C type is redefined
 305 \ heap-size [
 306     dup word? [
 307         [ depends-on-definition ] [ heap-size '[ _ ] ] bi
 308     ] [ drop f ] if
 309 ] 1 define-partial-eval