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