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