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