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
   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? specific-method
  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? ( value -- ? )
  46     value-info literal>> positive-fixnum? ;
  47
  48 {
  49     bitand-integer-integer
  50     bitand-integer-fixnum
  51     bitand-fixnum-integer
  52     bitand
  53 } [
  54     [
  55         {
  56             {
  57                 [ dup in-d>> first simplify-bitand? ]
  58                 [ drop [ >fixnum fixnum-bitand ] ]
  59             }
  60             {
  61                 [ dup in-d>> second simplify-bitand? ]
  62                 [ drop [ [ >fixnum ] dip fixnum-bitand ] ]
  63             }
  64             [ drop f ]
  65         } cond
  66     ] "custom-inlining" set-word-prop
  67 ] each
  68
  69 ! Speeds up 2^
  70 \ shift [
  71     in-d>> first value-info literal>> 1 = [
  72         cell-bits tag-bits get - 1 -
  73         '[
  74             >fixnum dup 0 < [ 2drop 0 ] [
  75                 dup _ < [ fixnum-shift ] [
  76                     fixnum-shift
  77                 ] if
  78             ] if
  79         ]
  80     ] [ f ] if
  81 ] "custom-inlining" set-word-prop
  82
  83 { /i fixnum/i fixnum/i-fast bignum/i } [
  84     [
  85         in-d>> first2 [ value-info ] bi@ {
  86             [ drop class>> integer class<= ]
  87             [ drop interval>> 0 [a,a] interval>= ]
  88             [ nip literal>> integer? ]
  89             [ nip literal>> power-of-2? ]
  90         } 2&& [ [ log2 neg shift ] ] [ f ] if
  91     ] "custom-inlining" set-word-prop
  92 ] each
  93
  94 ! Integrate this with generic arithmetic optimization instead?
  95 : both-inputs? ( #call class -- ? )
  96     [ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ;
  97
  98 \ min [
  99     {
 100         { [ dup fixnum both-inputs? ] [ [ fixnum-min ] ] }
 101         { [ dup float both-inputs? ] [ [ float-min ] ] }
 102         [ f ]
 103     } cond nip
 104 ] "custom-inlining" set-word-prop
 105
 106 \ max [
 107     {
 108         { [ dup fixnum both-inputs? ] [ [ fixnum-max ] ] }
 109         { [ dup float both-inputs? ] [ [ float-max ] ] }
 110         [ f ]
 111     } cond nip
 112 ] "custom-inlining" set-word-prop
 113
 114 ! Generate more efficient code for common idiom
 115 \ clone [
 116     in-d>> first value-info literal>> {
 117         { V{ } [ [ drop { } 0 vector boa ] ] }
 118         { H{ } [ [ drop 0 <hashtable> ] ] }
 119         [ drop f ]
 120     } case
 121 ] "custom-inlining" set-word-prop
 122
 123 ERROR: bad-partial-eval quot word ;
 124
 125 : check-effect ( quot word -- )
 126     2dup [ infer ] [ stack-effect ] bi* effect<=
 127     [ 2drop ] [ bad-partial-eval ] if ;
 128
 129 :: define-partial-eval ( word quot n -- )
 130     word [
 131         in-d>> n tail*
 132         [ value-info ] map
 133         dup [ literal?>> ] all? [
 134             [ literal>> ] map
 135             n firstn
 136             quot call dup [
 137                 [ n ndrop ] prepose
 138                 dup word check-effect
 139             ] when
 140         ] [ drop f ] if
 141     ] "custom-inlining" set-word-prop ;
 142
 143 : inline-new ( class -- quot/f )
 144     dup tuple-class? [
 145         dup inlined-dependency depends-on
 146         [ all-slots [ initial>> literalize ] map ]
 147         [ tuple-layout '[ _ <tuple-boa> ] ]
 148         bi append >quotation
 149     ] [ drop f ] if ;
 150
 151 \ new [ inline-new ] 1 define-partial-eval
 152
 153 \ instance? [
 154     dup class?
 155     [ "predicate" word-prop ] [ drop f ] if
 156 ] 1 define-partial-eval
 157
 158 ! Shuffling
 159 : nths-quot ( indices -- quot )
 160     [ [ '[ _ swap nth ] ] map ] [ length ] bi
 161     '[ _ cleave _ narray ] ;
 162
 163 \ shuffle [
 164     shuffle-mapping nths-quot
 165 ] 1 define-partial-eval
 166
 167 ! Index search
 168 \ index [
 169     dup sequence? [
 170         dup length 4 >= [
 171             dup length zip >hashtable '[ _ at ]
 172         ] [ drop f ] if
 173     ] [ drop f ] if
 174 ] 1 define-partial-eval
 175
 176 : memq-quot ( seq -- newquot )
 177     [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
 178     [ drop f ] suffix [ cond ] curry ;
 179
 180 \ memq? [
 181     dup sequence? [ memq-quot ] [ drop f ] if
 182 ] 1 define-partial-eval
 183
 184 ! Membership testing
 185 : member-quot ( seq -- newquot )
 186     dup length 4 <= [
 187         [ drop f ] swap
 188         [ literalize [ t ] ] { } map>assoc linear-case-quot
 189     ] [
 190         unique [ key? ] curry
 191     ] if ;
 192
 193 \ member? [
 194     dup sequence? [ member-quot ] [ drop f ] if
 195 ] 1 define-partial-eval
 196
 197 ! Fast at for integer maps
 198 CONSTANT: lookup-table-at-max 256
 199
 200 : lookup-table-at? ( assoc -- ? )
 201     #! Can we use a fast byte array test here?
 202     {
 203         [ assoc-size 4 > ]
 204         [ values [ ] all? ]
 205         [ keys [ integer? ] all? ]
 206         [ keys [ 0 lookup-table-at-max between? ] all? ]
 207     } 1&& ;
 208
 209 : lookup-table-seq ( assoc -- table )
 210     [ keys supremum 1 + ] keep '[ _ at ] { } map-as ;
 211
 212 : lookup-table-quot ( seq -- newquot )
 213     lookup-table-seq
 214     '[
 215         _ over integer? [
 216             2dup bounds-check? [
 217                 nth-unsafe dup >boolean
 218             ] [ 2drop f f ] if
 219         ] [ 2drop f f ] if
 220     ] ;
 221
 222 : fast-lookup-table-at? ( assoc -- ? )
 223     values {
 224         [ [ integer? ] all? ]
 225         [ [ 0 254 between? ] all? ]
 226     } 1&& ;
 227
 228 : fast-lookup-table-seq ( assoc -- table )
 229     lookup-table-seq [ 255 or ] B{ } map-as ;
 230
 231 : fast-lookup-table-quot ( seq -- newquot )
 232     fast-lookup-table-seq
 233     '[
 234         _ over integer? [
 235             2dup bounds-check? [
 236                 nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
 237             ] [ 2drop f f ] if
 238         ] [ 2drop f f ] if
 239     ] ;
 240
 241 : at-quot ( assoc -- quot )
 242     dup assoc? [
 243         dup lookup-table-at? [
 244             dup fast-lookup-table-at? [
 245                 fast-lookup-table-quot
 246             ] [
 247                 lookup-table-quot
 248             ] if
 249         ] [ drop f ] if
 250     ] [ drop f ] if ;
 251
 252 \ at* [ at-quot ] 1 define-partial-eval