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 classes.tuple
   4 classes classes.algebra definitions stack-checker.state quotations
   5 classes.tuple.private math math.partial-dispatch math.private
   6 math.intervals layouts math.order vectors hashtables
   7 combinators effects generalizations assocs sets
   8 combinators.short-circuit sequences.private locals
   9 stack-checker namespaces compiler.tree.propagation.info ;
  10 IN: compiler.tree.propagation.transforms
  11
  12 \ equal? [
  13     ! If first input has a known type and second input is an
  14     ! object, we convert this to [ swap equal? ].
  15     in-d>> first2 value-info class>> object class= [
  16         value-info class>> \ equal? specific-method
  17         [ swap equal? ] f ?
  18     ] [ drop f ] if
  19 ] "custom-inlining" set-word-prop
  20
  21 : rem-custom-inlining ( #call -- quot/f )
  22     second value-info literal>> dup integer?
  23     [ power-of-2? [ 1 - bitand ] f ? ] [ drop f ] if ;
  24
  25 {
  26     mod-integer-integer
  27     mod-integer-fixnum
  28     mod-fixnum-integer
  29     fixnum-mod
  30 } [
  31     [
  32         in-d>> dup first value-info interval>> [0,inf] interval-subset?
  33         [ rem-custom-inlining ] [ drop f ] if
  34     ] "custom-inlining" set-word-prop
  35 ] each
  36
  37 \ rem [
  38     in-d>> rem-custom-inlining
  39 ] "custom-inlining" set-word-prop
  40
  41 {
  42     bitand-integer-integer
  43     bitand-integer-fixnum
  44     bitand-fixnum-integer
  45     bitand
  46 } [
  47     [
  48         in-d>> second value-info >literal< [
  49             0 most-positive-fixnum between?
  50             [ [ >fixnum ] bi@ fixnum-bitand ] f ?
  51         ] when
  52     ] "custom-inlining" set-word-prop
  53 ] each
  54
  55 ! Speeds up 2^
  56 \ shift [
  57     in-d>> first value-info literal>> 1 = [
  58         cell-bits tag-bits get - 1 -
  59         '[
  60             >fixnum dup 0 < [ 2drop 0 ] [
  61                 dup _ < [ fixnum-shift ] [
  62                     fixnum-shift
  63                 ] if
  64             ] if
  65         ]
  66     ] [ f ] if
  67 ] "custom-inlining" set-word-prop
  68
  69 ! Generate more efficient code for common idiom
  70 \ clone [
  71     in-d>> first value-info literal>> {
  72         { V{ } [ [ drop { } 0 vector boa ] ] }
  73         { H{ } [ [ drop 0 <hashtable> ] ] }
  74         [ drop f ]
  75     } case
  76 ] "custom-inlining" set-word-prop
  77
  78 ERROR: bad-partial-eval quot word ;
  79
  80 : check-effect ( quot word -- )
  81     2dup [ infer ] [ stack-effect ] bi* effect<=
  82     [ 2drop ] [ bad-partial-eval ] if ;
  83
  84 :: define-partial-eval ( word quot n -- )
  85     word [
  86         in-d>> n tail*
  87         [ value-info ] map
  88         dup [ literal?>> ] all? [
  89             [ literal>> ] map
  90             n firstn
  91             quot call dup [
  92                 [ n ndrop ] prepose
  93                 dup word check-effect
  94             ] when
  95         ] [ drop f ] if
  96     ] "custom-inlining" set-word-prop ;
  97
  98 : inline-new ( class -- quot/f )
  99     dup tuple-class? [
 100         dup inlined-dependency depends-on
 101         [ all-slots [ initial>> literalize ] map ]
 102         [ tuple-layout '[ _ <tuple-boa> ] ]
 103         bi append >quotation
 104     ] [ drop f ] if ;
 105
 106 \ new [ inline-new ] 1 define-partial-eval
 107
 108 \ instance? [
 109     dup class?
 110     [ "predicate" word-prop ] [ drop f ] if
 111 ] 1 define-partial-eval
 112
 113 ! Shuffling
 114 : nths-quot ( indices -- quot )
 115     [ [ '[ _ swap nth ] ] map ] [ length ] bi
 116     '[ _ cleave _ narray ] ;
 117
 118 \ shuffle [
 119     shuffle-mapping nths-quot
 120 ] 1 define-partial-eval
 121
 122 ! Index search
 123 \ index [
 124     dup sequence? [
 125         dup length 4 >= [
 126             dup length zip >hashtable '[ _ at ]
 127         ] [ drop f ] if
 128     ] [ drop f ] if
 129 ] 1 define-partial-eval
 130
 131 : memq-quot ( seq -- newquot )
 132     [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
 133     [ drop f ] suffix [ cond ] curry ;
 134
 135 \ memq? [
 136     dup sequence? [ memq-quot ] [ drop f ] if
 137 ] 1 define-partial-eval
 138
 139 ! Membership testing
 140 : member-quot ( seq -- newquot )
 141     dup length 4 <= [
 142         [ drop f ] swap
 143         [ literalize [ t ] ] { } map>assoc linear-case-quot
 144     ] [
 145         unique [ key? ] curry
 146     ] if ;
 147
 148 \ member? [
 149     dup sequence? [ member-quot ] [ drop f ] if
 150 ] 1 define-partial-eval
 151
 152 ! Fast at for integer maps
 153 CONSTANT: lookup-table-at-max 256
 154
 155 : lookup-table-at? ( assoc -- ? )
 156     #! Can we use a fast byte array test here?
 157     {
 158         [ assoc-size 4 > ]
 159         [ values [ ] all? ]
 160         [ keys [ integer? ] all? ]
 161         [ keys [ 0 lookup-table-at-max between? ] all? ]
 162     } 1&& ;
 163
 164 : lookup-table-seq ( assoc -- table )
 165     [ keys supremum 1 + ] keep '[ _ at ] { } map-as ;
 166
 167 : lookup-table-quot ( seq -- newquot )
 168     lookup-table-seq
 169     '[
 170         _ over integer? [
 171             2dup bounds-check? [
 172                 nth-unsafe dup >boolean
 173             ] [ 2drop f f ] if
 174         ] [ 2drop f f ] if
 175     ] ;
 176
 177 : fast-lookup-table-at? ( assoc -- ? )
 178     values {
 179         [ [ integer? ] all? ]
 180         [ [ 0 254 between? ] all? ]
 181     } 1&& ;
 182
 183 : fast-lookup-table-seq ( assoc -- table )
 184     lookup-table-seq [ 255 or ] B{ } map-as ;
 185
 186 : fast-lookup-table-quot ( seq -- newquot )
 187     fast-lookup-table-seq
 188     '[
 189         _ over integer? [
 190             2dup bounds-check? [
 191                 nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
 192             ] [ 2drop f f ] if
 193         ] [ 2drop f f ] if
 194     ] ;
 195
 196 : at-quot ( assoc -- quot )
 197     dup lookup-table-at? [
 198         dup fast-lookup-table-at? [
 199             fast-lookup-table-quot
 200         ] [
 201             lookup-table-quot
 202         ] if
 203     ] [ drop f ] if ;
 204
 205 \ at* [ at-quot ] 1 define-partial-eval