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

   1 ! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences words fry generic accessors
   4 classes.tuple classes classes.algebra definitions
   5 stack-checker.state quotations classes.tuple.private math
   6 math.partial-dispatch math.private math.intervals sets.private
   7 math.floats.private math.integers.private layouts math.order
   8 vectors hashtables combinators effects generalizations assocs
   9 sets combinators.short-circuit sequences.private locals
  10 stack-checker namespaces compiler.tree.propagation.info ;
  11 IN: compiler.tree.propagation.transforms
  12
  13 \ equal? [
  14     ! If first input has a known type and second input is an
  15     ! object, we convert this to [ swap equal? ].
  16     in-d>> first2 value-info class>> object class= [
  17         value-info class>> \ equal? method-for-class
  18         [ swap equal? ] f ?
  19     ] [ drop f ] if
  20 ] "custom-inlining" set-word-prop
  21
  22 : rem-custom-inlining ( #call -- quot/f )
  23     second value-info literal>> dup integer?
  24     [ power-of-2? [ 1 - bitand ] f ? ] [ drop f ] if ;
  25
  26 {
  27     mod-integer-integer
  28     mod-integer-fixnum
  29     mod-fixnum-integer
  30     fixnum-mod
  31 } [
  32     [
  33         in-d>> dup first value-info interval>> [0,inf] interval-subset?
  34         [ rem-custom-inlining ] [ drop f ] if
  35     ] "custom-inlining" set-word-prop
  36 ] each
  37
  38 \ rem [
  39     in-d>> rem-custom-inlining
  40 ] "custom-inlining" set-word-prop
  41
  42 : positive-fixnum? ( obj -- ? )
  43     { [ fixnum? ] [ 0 >= ] } 1&& ;
  44
  45 : simplify-bitand? ( value1 value2 -- ? )
  46     [ literal>> positive-fixnum? ]
  47     [ class>> fixnum swap class<= ]
  48     bi* and ;
  49
  50 : all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline
  51
  52 : redundant-bitand? ( value1 value2 -- ? )
  53     [ interval>> ] [ literal>> ] bi* {
  54         [ nip integer? ]
  55         [ nip all-ones? ]
  56         [ 0 swap [a,b] interval-subset? ]
  57     } 2&& ;
  58
  59 : zero-bitand? ( value1 value2 -- ? )
  60     [ interval>> ] [ literal>> ] bi* {
  61         [ nip integer? ]
  62         [ nip bitnot all-ones? ]
  63         [ 0 swap bitnot [a,b] interval-subset? ]
  64     } 2&& ;
  65
  66 {
  67     bitand-integer-integer
  68     bitand-integer-fixnum
  69     bitand-fixnum-integer
  70     bitand
  71 } [
  72     [
  73         in-d>> first2 [ value-info ] bi@ {
  74             {
  75                 [ 2dup zero-bitand? ]
  76                 [ 2drop [ 2drop 0 ] ]
  77             }
  78             {
  79                 [ 2dup swap zero-bitand? ]
  80                 [ 2drop [ 2drop 0 ] ]
  81             }
  82             {
  83                 [ 2dup redundant-bitand? ]
  84                 [ 2drop [ drop ] ]
  85             }
  86             {
  87                 [ 2dup swap redundant-bitand? ]
  88                 [ 2drop [ nip ] ]
  89             }
  90             {
  91                 [ 2dup simplify-bitand? ]
  92                 [ 2drop [ >fixnum fixnum-bitand ] ]
  93             }
  94             {
  95                 [ 2dup swap simplify-bitand? ]
  96                 [ 2drop [ [ >fixnum ] dip fixnum-bitand ] ]
  97             }
  98             [ 2drop f ]
  99         } cond
 100     ] "custom-inlining" set-word-prop
 101 ] each
 102
 103 ! Speeds up 2^
 104 : 2^? ( #call -- ? )
 105     in-d>> first2 [ value-info ] bi@
 106     [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ]
 107     [ class>> fixnum class<= ]
 108     bi* and ;
 109
 110 \ shift [
 111      2^? [
 112         cell-bits tag-bits get - 1 -
 113         '[
 114             >fixnum dup 0 < [ 2drop 0 ] [
 115                 dup _ < [ fixnum-shift ] [
 116                     fixnum-shift
 117                 ] if
 118             ] if
 119         ]
 120     ] [ f ] if
 121 ] "custom-inlining" set-word-prop
 122
 123 { /i fixnum/i fixnum/i-fast bignum/i } [
 124     [
 125         in-d>> first2 [ value-info ] bi@ {
 126             [ drop class>> integer class<= ]
 127             [ drop interval>> 0 [a,a] interval>= ]
 128             [ nip literal>> integer? ]
 129             [ nip literal>> power-of-2? ]
 130         } 2&& [ [ log2 neg shift ] ] [ f ] if
 131     ] "custom-inlining" set-word-prop
 132 ] each
 133
 134 ! Integrate this with generic arithmetic optimization instead?
 135 : both-inputs? ( #call class -- ? )
 136     [ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ;
 137
 138 \ min [
 139     {
 140         { [ dup fixnum both-inputs? ] [ [ fixnum-min ] ] }
 141         { [ dup float both-inputs? ] [ [ float-min ] ] }
 142         [ f ]
 143     } cond nip
 144 ] "custom-inlining" set-word-prop
 145
 146 \ max [
 147     {
 148         { [ dup fixnum both-inputs? ] [ [ fixnum-max ] ] }
 149         { [ dup float both-inputs? ] [ [ float-max ] ] }
 150         [ f ]
 151     } cond nip
 152 ] "custom-inlining" set-word-prop
 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         [ 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 inlined-dependency depends-on
 186         [ all-slots [ initial>> literalize ] map ]
 187         [ tuple-layout '[ _ <tuple-boa> ] ]
 188         bi append >quotation
 189     ] [ drop f ] if ;
 190
 191 \ new [ inline-new ] 1 define-partial-eval
 192
 193 \ instance? [
 194     dup class?
 195     [ "predicate" word-prop ] [ drop f ] if
 196 ] 1 define-partial-eval
 197
 198 ! Shuffling
 199 : nths-quot ( indices -- quot )
 200     [ [ '[ _ swap nth ] ] map ] [ length ] bi
 201     '[ _ cleave _ narray ] ;
 202
 203 \ shuffle [
 204     shuffle-mapping nths-quot
 205 ] 1 define-partial-eval
 206
 207 ! Index search
 208 \ index [
 209     dup sequence? [
 210         dup length 4 >= [
 211             dup length zip >hashtable '[ _ at ]
 212         ] [ drop f ] if
 213     ] [ drop f ] if
 214 ] 1 define-partial-eval
 215
 216 : member-eq-quot ( seq -- newquot )
 217     [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
 218     [ drop f ] suffix [ cond ] curry ;
 219
 220 \ member-eq? [
 221     dup sequence? [ member-eq-quot ] [ drop f ] if
 222 ] 1 define-partial-eval
 223
 224 ! Membership testing
 225 : member-quot ( seq -- newquot )
 226     dup length 4 <= [
 227         [ drop f ] swap
 228         [ literalize [ t ] ] { } map>assoc linear-case-quot
 229     ] [
 230         unique [ key? ] curry
 231     ] if ;
 232
 233 \ member? [
 234     dup sequence? [ member-quot ] [ drop f ] if
 235 ] 1 define-partial-eval
 236
 237 ! Fast at for integer maps
 238 CONSTANT: lookup-table-at-max 256
 239
 240 : lookup-table-at? ( assoc -- ? )
 241     #! Can we use a fast byte array test here?
 242     {
 243         [ assoc-size 4 > ]
 244         [ values [ ] all? ]
 245         [ keys [ integer? ] all? ]
 246         [ keys [ 0 lookup-table-at-max between? ] all? ]
 247     } 1&& ;
 248
 249 : lookup-table-seq ( assoc -- table )
 250     [ keys supremum 1 + ] keep '[ _ at ] { } map-as ;
 251
 252 : lookup-table-quot ( seq -- newquot )
 253     lookup-table-seq
 254     '[
 255         _ over integer? [
 256             2dup bounds-check? [
 257                 nth-unsafe dup >boolean
 258             ] [ 2drop f f ] if
 259         ] [ 2drop f f ] if
 260     ] ;
 261
 262 : fast-lookup-table-at? ( assoc -- ? )
 263     values {
 264         [ [ integer? ] all? ]
 265         [ [ 0 254 between? ] all? ]
 266     } 1&& ;
 267
 268 : fast-lookup-table-seq ( assoc -- table )
 269     lookup-table-seq [ 255 or ] B{ } map-as ;
 270
 271 : fast-lookup-table-quot ( seq -- newquot )
 272     fast-lookup-table-seq
 273     '[
 274         _ over integer? [
 275             2dup bounds-check? [
 276                 nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
 277             ] [ 2drop f f ] if
 278         ] [ 2drop f f ] if
 279     ] ;
 280
 281 : at-quot ( assoc -- quot )
 282     dup assoc? [
 283         dup lookup-table-at? [
 284             dup fast-lookup-table-at? [
 285                 fast-lookup-table-quot
 286             ] [
 287                 lookup-table-quot
 288             ] if
 289         ] [ drop f ] if
 290     ] [ drop f ] if ;
 291
 292 \ at* [ at-quot ] 1 define-partial-eval
 293
 294 : diff-quot ( seq -- quot: ( seq' -- seq'' ) )
 295     tester '[ [ @ not ] filter ] ;
 296
 297 \ diff [ diff-quot ] 1 define-partial-eval
 298
 299 : intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
 300     tester '[ _ filter ] ;
 301
 302 \ intersect [ intersect-quot ] 1 define-partial-eval
 303
 304 : fixnum-bits ( -- n )
 305     cell-bits tag-bits get - ;
 306
 307 : bit-quot ( #call -- quot/f )
 308     in-d>> second value-info interval>> 0 fixnum-bits [a,b] interval-subset?
 309     [ [ >fixnum ] dip fixnum-bit? ] f ? ;
 310
 311 \ bit? [ bit-quot ] "custom-inlining" set-word-prop