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

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