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
   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 ;
  13 FROM: math => float ;
  14 FROM: sets => set ;
  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 ( #call -- quot/f )
  27     second value-info literal>> dup integer?
  28     [ power-of-2? [ 1 - bitand ] f ? ] [ 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 : positive-fixnum? ( obj -- ? )
  47     { [ fixnum? ] [ 0 >= ] } 1&& ;
  48
  49 : simplify-bitand? ( value1 value2 -- ? )
  50     [ literal>> positive-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 [ >fixnum fixnum-bitand ] ]
  97             }
  98             {
  99                 [ 2dup swap simplify-bitand? ]
 100                 [ 2drop [ [ >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 [
 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         { HS{ } [ [ drop f fast-set ] ] }
 141         [ drop f ]
 142     } case
 143 ] "custom-inlining" set-word-prop
 144
 145 :: inline-instance ( node -- quot/f )
 146     node in-d>> first2 [ value-info ] bi@ literal>> :> ( obj class )
 147     class class? [
 148         {
 149             [ class \ f = not ]
 150             [ obj class>> \ f class-not class-and class class<= ]
 151         } 0&& [
 152             ! TODO: replace this with an implicit null check when
 153             ! profitable, once Factor gets OSR implemented
 154             [ drop >boolean ]
 155         ] [
 156             class "predicate" word-prop '[ drop @ ]
 157         ] if
 158     ] [ f ] if ;
 159
 160 \ instance? [ inline-instance ] "custom-inlining" set-word-prop
 161
 162 ERROR: bad-partial-eval quot word ;
 163
 164 : check-effect ( quot word -- )
 165     2dup [ infer ] [ stack-effect ] bi* effect<=
 166     [ 2drop ] [ bad-partial-eval ] if ;
 167
 168 :: define-partial-eval ( word quot n -- )
 169     word [
 170         in-d>> n tail*
 171         [ value-info ] map
 172         dup [ literal?>> ] all? [
 173             [ literal>> ] map
 174             n firstn
 175             quot call dup [
 176                 [ n ndrop ] prepose
 177                 dup word check-effect
 178             ] when
 179         ] [ drop f ] if
 180     ] "custom-inlining" set-word-prop ;
 181
 182 : inline-new ( class -- quot/f )
 183     dup tuple-class? [
 184         dup tuple-layout
 185         [ depends-on-tuple-layout ]
 186         [ drop all-slots [ initial>> literalize ] [ ] map-as ]
 187         [ nip ]
 188         2tri
 189         '[ @ _ <tuple-boa> ]
 190     ] [ drop f ] if ;
 191
 192 \ new [ inline-new ] 1 define-partial-eval
 193
 194 ! Shuffling
 195 : nths-quot ( indices -- quot )
 196     [ [ '[ _ swap nth ] ] map ] [ length ] bi
 197     '[ _ cleave _ narray ] ;
 198
 199 \ shuffle [
 200     shuffle-mapping nths-quot
 201 ] 1 define-partial-eval
 202
 203 ! Index search
 204 \ index [
 205     dup sequence? [
 206         dup length 4 >= [
 207             dup length iota zip >hashtable '[ _ at ]
 208         ] [ drop f ] if
 209     ] [ drop f ] if
 210 ] 1 define-partial-eval
 211
 212 : member-eq-quot ( seq -- newquot )
 213     [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
 214     [ drop f ] suffix [ cond ] curry ;
 215
 216 \ member-eq? [
 217     dup sequence? [ member-eq-quot ] [ drop f ] if
 218 ] 1 define-partial-eval
 219
 220 ! Membership testing
 221 : member-quot ( seq -- newquot )
 222     dup length 4 <= [
 223         [ drop f ] swap
 224         [ literalize [ t ] ] { } map>assoc linear-case-quot
 225     ] [
 226         tester
 227     ] if ;
 228
 229 \ member? [
 230     dup sequence? [ member-quot ] [ drop f ] if
 231 ] 1 define-partial-eval
 232
 233 ! Fast at for integer maps
 234 CONSTANT: lookup-table-at-max 256
 235
 236 : lookup-table-at? ( assoc -- ? )
 237     #! Can we use a fast byte array test here?
 238     {
 239         [ assoc-size 4 > ]
 240         [ values [ ] all? ]
 241         [ keys [ integer? ] all? ]
 242         [ keys [ 0 lookup-table-at-max between? ] all? ]
 243     } 1&& ;
 244
 245 : lookup-table-seq ( assoc -- table )
 246     [ keys supremum 1 + iota ] keep '[ _ at ] { } map-as ;
 247
 248 : lookup-table-quot ( seq -- newquot )
 249     lookup-table-seq
 250     '[
 251         _ over integer? [
 252             2dup bounds-check? [
 253                 nth-unsafe dup >boolean
 254             ] [ 2drop f f ] if
 255         ] [ 2drop f f ] if
 256     ] ;
 257
 258 : fast-lookup-table-at? ( assoc -- ? )
 259     values {
 260         [ [ integer? ] all? ]
 261         [ [ 0 254 between? ] all? ]
 262     } 1&& ;
 263
 264 : fast-lookup-table-seq ( assoc -- table )
 265     lookup-table-seq [ 255 or ] B{ } map-as ;
 266
 267 : fast-lookup-table-quot ( seq -- newquot )
 268     fast-lookup-table-seq
 269     '[
 270         _ over integer? [
 271             2dup bounds-check? [
 272                 nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
 273             ] [ 2drop f f ] if
 274         ] [ 2drop f f ] if
 275     ] ;
 276
 277 : at-quot ( assoc -- quot )
 278     dup assoc? [
 279         dup lookup-table-at? [
 280             dup fast-lookup-table-at? [
 281                 fast-lookup-table-quot
 282             ] [
 283                 lookup-table-quot
 284             ] if
 285         ] [ drop f ] if
 286     ] [ drop f ] if ;
 287
 288 \ at* [ at-quot ] 1 define-partial-eval
 289
 290 : diff-quot ( seq -- quot: ( seq' -- seq'' ) )
 291     tester '[ [ [ @ not ] filter ] keep set-like ] ;
 292
 293 M\ set diff [ diff-quot ] 1 define-partial-eval
 294
 295 : intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
 296     tester '[ [ _ filter ] keep set-like ] ;
 297
 298 M\ set intersect [ intersect-quot ] 1 define-partial-eval
 299
 300 : fixnum-bits ( -- n )
 301     cell-bits tag-bits get - ;
 302
 303 : bit-quot ( #call -- quot/f )
 304     in-d>> second value-info interval>> 0 fixnum-bits [a,b] interval-subset?
 305     [ [ >fixnum ] dip fixnum-bit? ] f ? ;
 306
 307 \ bit? [ bit-quot ] "custom-inlining" set-word-prop
 308
 309 ! Speeds up sum-file, sort and reverse-complement benchmarks by
 310 ! compiling decoder-readln better
 311 \ push [
 312     in-d>> second value-info class>> growable class<=
 313     [ \ push def>> ] [ f ] if
 314 ] "custom-inlining" set-word-prop
 315
 316 ! We want to constant-fold calls to heap-size, and recompile those
 317 ! calls when a C type is redefined
 318 \ heap-size [
 319     [ depends-on-c-type ] [ heap-size '[ _ ] ] bi
 320 ] 1 define-partial-eval
 321
 322 ! Eliminates a few redundant checks here and there
 323 \ both-fixnums? [
 324     in-d>> first2 [ value-info class>> ] bi@ {
 325         { [ 2dup [ fixnum classes-intersect? not ] either? ] [ [ 2drop f ] ] }
 326         { [ 2dup [ fixnum class<= ] both? ] [ [ 2drop t ] ] }
 327         { [ dup fixnum class<= ] [ [ drop fixnum? ] ] }
 328         { [ over fixnum class<= ] [ [ nip fixnum? ] ] }
 329         [ f ]
 330     } cond 2nip
 331 ] "custom-inlining" set-word-prop