1 ! Copyright (C) 2008, 2011 Slava Pestov, Daniel Ehrenberg.
2 ! See https://factorcode.org/license.txt for BSD license.
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
16 IN: compiler.tree.propagation.transforms
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
25 ] "custom-inlining" set-word-prop
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
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
46 in-d>> rem-custom-inlining
47 ] "custom-inlining" set-word-prop
49 : non-negative-fixnum? ( obj -- ? )
50 { [ fixnum? ] [ 0 >= ] } 1&& ;
52 : simplify-bitand? ( value1 value2 -- ? )
53 [ literal>> non-negative-fixnum? ]
54 [ class>> fixnum swap class<= ]
57 : all-ones? ( n -- ? ) dup 1 + bitand zero? ; inline
59 : redundant-bitand? ( value1 value2 -- ? )
60 [ interval>> ] [ literal>> ] bi* {
63 [ [0,b] interval-subset? ]
66 : zero-bitand? ( value1 value2 -- ? )
67 [ interval>> ] [ literal>> ] bi* {
69 [ nip bitnot all-ones? ]
70 [ 0 swap bitnot [a,b] interval-subset? ]
74 bitand-integer-integer
80 in-d>> first2 [ value-info ] bi@ {
83 [ nip class>> bignum = 0 >bignum 0 ? '[ 2drop _ ] ]
86 [ 2dup swap zero-bitand? ]
87 [ drop class>> bignum = 0 >bignum 0 ? '[ 2drop _ ] ]
90 [ 2dup redundant-bitand? ]
91 [ nip class>> bignum = [ drop >bignum ] [ drop ] ? ]
94 [ 2dup swap redundant-bitand? ]
95 [ drop class>> bignum = [ nip >bignum ] [ nip ] ? ]
98 [ 2dup simplify-bitand? ]
99 [ 2drop [ integer>fixnum fixnum-bitand ] ]
102 [ 2dup swap simplify-bitand? ]
103 [ 2drop [ [ integer>fixnum ] dip fixnum-bitand ] ]
107 ] "custom-inlining" set-word-prop
112 in-d>> first value-info literal>> 1 eq? ;
114 : shift-2^ ( -- quot )
115 cell-bits tag-bits get - 1 -
117 integer>fixnum-strict dup 0 < [ 2drop 0 ] [
118 dup _ < [ fixnum-shift ] [
126 in-d>> second value-info literal>> -1 eq? ;
128 : shift-2/ ( -- quot )
131 { [ over fixnum? ] [ fixnum-shift ] }
132 { [ over bignum? ] [ bignum-shift ] }
133 [ drop \ shift no-method ]
139 { [ dup 2^? ] [ drop shift-2^ ] }
140 { [ dup 2/? ] [ drop shift-2/ ] }
143 ] "custom-inlining" set-word-prop
145 { /i fixnum/i fixnum/i-fast bignum/i } [
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
156 ! Generate more efficient code for common idiom
158 in-d>> first value-info literal>> {
159 { V{ } [ [ drop { } 0 vector boa ] ] }
160 { H{ } [ [ drop 0 <hashtable> ] ] }
161 { HS{ } [ [ drop 0 <hash-set> ] ] }
164 ] "custom-inlining" set-word-prop
166 ERROR: bad-partial-eval quot word ;
168 : check-effect ( quot word -- )
169 2dup [ infer ] [ stack-effect ] bi* effect<=
170 [ 2drop ] [ bad-partial-eval ] if ;
172 :: define-partial-eval ( word quot n -- )
176 dup [ literal?>> ] all? [
181 dup word check-effect
184 ] "custom-inlining" set-word-prop ;
186 : inline-new ( class -- quot/f )
188 { [ dup struct-class? ] [
189 dup dup struct-slots add-depends-on-struct-slots
191 { [ dup tuple-class? ] [
193 [ add-depends-on-tuple-layout ]
194 [ drop all-slots [ initial>> literalize ] [ ] map-as ]
202 \ new [ inline-new ] 1 define-partial-eval
207 [ add-depends-on-tuple-layout ]
208 [ [ "boa-check" word-prop [ ] or ] dip ] 2bi
211 ] 1 define-partial-eval
217 ! union{ and intersection{ and not{ have useless
218 ! expansions, and recurse infinitely
219 dup { [ length 2 >= ] [ second \ instance? = ] } 1&& [
223 ] 1 define-partial-eval
226 : nths-quot ( indices -- quot )
227 [ [ '[ _ swap nth ] ] map ] [ length ] bi
228 '[ _ cleave _ narray ] ;
231 shuffle-mapping nths-quot
232 ] 1 define-partial-eval
238 H{ } zip-index-as '[ _ at ]
241 ] 1 define-partial-eval
243 : member-eq-quot ( seq -- newquot )
244 [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
245 [ drop f ] suffix [ cond ] curry ;
248 dup sequence? [ member-eq-quot ] [ drop f ] if
249 ] 1 define-partial-eval
252 : member-quot ( seq -- newquot )
255 [ literalize [ t ] ] { } map>assoc linear-case-quot
261 dup sequence? [ member-quot ] [ drop f ] if
262 ] 1 define-partial-eval
264 ! Fast at for integer maps
265 CONSTANT: lookup-table-at-max 256
267 : lookup-table-at? ( assoc -- ? )
268 ! Can we use a fast byte array test here?
272 [ keys [ integer? ] all? ]
273 [ keys [ 0 lookup-table-at-max between? ] all? ]
276 : lookup-table-seq ( assoc -- table )
277 [ keys maximum 1 + <iota> ] keep '[ _ at ] { } map-as ;
279 : lookup-table-quot ( seq -- newquot )
284 nth-unsafe dup >boolean
289 : fast-lookup-table-at? ( assoc -- ? )
291 [ [ integer? ] all? ]
292 [ [ 0 254 between? ] all? ]
295 : fast-lookup-table-seq ( assoc -- table )
296 lookup-table-seq [ 255 or ] B{ } map-as ;
298 : fast-lookup-table-quot ( seq -- newquot )
299 fast-lookup-table-seq
303 nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
308 : at-quot ( assoc -- quot )
310 dup lookup-table-at? [
311 dup fast-lookup-table-at? [
312 fast-lookup-table-quot
319 \ at* [ at-quot ] 1 define-partial-eval
321 : diff-quot ( seq -- quot: ( seq' -- seq'' ) )
322 [ tester ] keep '[ members _ reject _ set-like ] ;
324 M\ sets:set diff [ diff-quot ] 1 define-partial-eval
326 : intersect-quot ( seq -- quot: ( seq' -- seq'' ) )
327 [ tester ] keep '[ members _ filter _ set-like ] ;
329 M\ sets:set intersect [ intersect-quot ] 1 define-partial-eval
331 : intersects?-quot ( seq -- quot: ( seq' -- seq'' ) )
332 tester '[ members _ any? ] ;
334 M\ sets:set intersects? [ intersects?-quot ] 1 define-partial-eval
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 ? ;
340 \ bit? [ bit-quot ] "custom-inlining" set-word-prop
342 ! Speeds up sum-file, sort and reverse-complement benchmarks by
343 ! compiling decoder-readln better
345 in-d>> second value-info class>> growable class<=
346 [ \ push def>> ] [ f ] if
347 ] "custom-inlining" set-word-prop
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 ;
353 ! Speeds up fasta benchmark
354 { >fixnum integer>fixnum integer>fixnum-strict } [
355 dup '[ _ custom-inline-fixnum ] "custom-inlining" set-word-prop
358 ! We want to constant-fold calls to heap-size, and recompile those
359 ! calls when a C type is redefined
361 [ add-depends-on-c-type ] [ heap-size '[ _ ] ] bi
362 ] 1 define-partial-eval
364 ! Eliminates a few redundant checks here and there
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? ] ] }
373 ] "custom-inlining" set-word-prop
375 : constant-number-info? ( info -- ? )
376 { [ value-info-state? ] [ literal?>> ] [ class>> integer class<= ] } 1&& ;
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&&
383 ] [ "custom-inlining" set-word-prop ] curry each