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