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
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
20 ] "custom-inlining" set-word-prop
22 : rem-custom-inlining ( #call -- quot/f )
23 second value-info literal>> dup integer?
24 [ power-of-2? [ 1 - bitand ] f ? ] [ drop f ] if ;
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
39 in-d>> rem-custom-inlining
40 ] "custom-inlining" set-word-prop
42 : positive-fixnum? ( obj -- ? )
43 { [ fixnum? ] [ 0 >= ] } 1&& ;
45 : simplify-bitand? ( value -- ? )
46 value-info literal>> positive-fixnum? ;
49 bitand-integer-integer
57 [ dup in-d>> first simplify-bitand? ]
58 [ drop [ >fixnum fixnum-bitand ] ]
61 [ dup in-d>> second simplify-bitand? ]
62 [ drop [ [ >fixnum ] dip fixnum-bitand ] ]
66 ] "custom-inlining" set-word-prop
71 in-d>> first value-info literal>> 1 = [
72 cell-bits tag-bits get - 1 -
74 >fixnum dup 0 < [ 2drop 0 ] [
75 dup _ < [ fixnum-shift ] [
81 ] "custom-inlining" set-word-prop
83 { /i fixnum/i fixnum/i-fast bignum/i } [
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
94 ! Integrate this with generic arithmetic optimization instead?
95 : both-inputs? ( #call class -- ? )
96 [ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ;
100 { [ dup fixnum both-inputs? ] [ [ fixnum-min ] ] }
101 { [ dup float both-inputs? ] [ [ float-min ] ] }
104 ] "custom-inlining" set-word-prop
108 { [ dup fixnum both-inputs? ] [ [ fixnum-max ] ] }
109 { [ dup float both-inputs? ] [ [ float-max ] ] }
112 ] "custom-inlining" set-word-prop
114 ! Generate more efficient code for common idiom
116 in-d>> first value-info literal>> {
117 { V{ } [ [ drop { } 0 vector boa ] ] }
118 { H{ } [ [ drop 0 <hashtable> ] ] }
121 ] "custom-inlining" set-word-prop
123 ERROR: bad-partial-eval quot word ;
125 : check-effect ( quot word -- )
126 2dup [ infer ] [ stack-effect ] bi* effect<=
127 [ 2drop ] [ bad-partial-eval ] if ;
129 :: define-partial-eval ( word quot n -- )
133 dup [ literal?>> ] all? [
138 dup word check-effect
141 ] "custom-inlining" set-word-prop ;
143 : inline-new ( class -- quot/f )
145 dup inlined-dependency depends-on
146 [ all-slots [ initial>> literalize ] map ]
147 [ tuple-layout '[ _ <tuple-boa> ] ]
151 \ new [ inline-new ] 1 define-partial-eval
155 [ "predicate" word-prop ] [ drop f ] if
156 ] 1 define-partial-eval
159 : nths-quot ( indices -- quot )
160 [ [ '[ _ swap nth ] ] map ] [ length ] bi
161 '[ _ cleave _ narray ] ;
164 shuffle-mapping nths-quot
165 ] 1 define-partial-eval
171 dup length zip >hashtable '[ _ at ]
174 ] 1 define-partial-eval
176 : memq-quot ( seq -- newquot )
177 [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
178 [ drop f ] suffix [ cond ] curry ;
181 dup sequence? [ memq-quot ] [ drop f ] if
182 ] 1 define-partial-eval
185 : member-quot ( seq -- newquot )
188 [ literalize [ t ] ] { } map>assoc linear-case-quot
190 unique [ key? ] curry
194 dup sequence? [ member-quot ] [ drop f ] if
195 ] 1 define-partial-eval
197 ! Fast at for integer maps
198 CONSTANT: lookup-table-at-max 256
200 : lookup-table-at? ( assoc -- ? )
201 #! Can we use a fast byte array test here?
205 [ keys [ integer? ] all? ]
206 [ keys [ 0 lookup-table-at-max between? ] all? ]
209 : lookup-table-seq ( assoc -- table )
210 [ keys supremum 1 + ] keep '[ _ at ] { } map-as ;
212 : lookup-table-quot ( seq -- newquot )
217 nth-unsafe dup >boolean
222 : fast-lookup-table-at? ( assoc -- ? )
224 [ [ integer? ] all? ]
225 [ [ 0 254 between? ] all? ]
228 : fast-lookup-table-seq ( assoc -- table )
229 lookup-table-seq [ 255 or ] B{ } map-as ;
231 : fast-lookup-table-quot ( seq -- newquot )
232 fast-lookup-table-seq
236 nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
241 : at-quot ( assoc -- quot )
243 dup lookup-table-at? [
244 dup fast-lookup-table-at? [
245 fast-lookup-table-quot
252 \ at* [ at-quot ] 1 define-partial-eval