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

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