1 ! Copyright (C) 2005, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien arrays generic hashtables definitions
4 kernel assocs math math.order math.private kernel.private
5 sequences words parser vectors strings sbufs io namespaces
6 assocs quotations sequences.private io.binary io.streams.string
7 layouts splitting math.intervals math.floats.private
8 classes.tuple classes.predicate classes.tuple.private classes
9 classes.algebra sequences.private combinators byte-arrays
10 byte-vectors slots.private inference.dataflow inference.state
11 inference.class optimizer.def-use optimizer.backend
12 optimizer.pattern-match optimizer.inlining optimizer.allot ;
13 IN: optimizer.known-words
15 { <tuple> <tuple-boa> (tuple) } [
17 dup node-in-d peek node-literal
18 dup tuple-layout? [ class>> ] [ drop tuple ] if
20 ] "output-classes" set-word-prop
24 dup node-in-d peek node-literal
25 dup class? [ drop tuple ] unless 1array f
26 ] "output-classes" set-word-prop
28 ! the output of clone has the same type as the input
31 node-in-d [ value-class* ] map f
32 ] "output-classes" set-word-prop
35 ! not [ A ] [ B ] if ==> [ B ] [ A ] if
36 : flip-branches? ( #call -- ? ) sole-consumer #if? ;
38 : (flip-branches) ( #if -- )
39 dup node-children reverse swap set-node-children ;
41 : flip-branches ( #call -- #if )
42 #! If a not is followed by an #if, flip branches and
44 dup sole-consumer (flip-branches) [ ] f splice-quot ;
47 { [ dup flip-branches? ] [ flip-branches ] }
50 ! eq? on objects of disjoint types is always f
51 : disjoint-eq? ( node -- ? )
52 node-input-classes first2 2dup and
53 [ classes-intersect? not ] [ 2drop f ] if ;
56 { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
59 : literal-member? ( #call -- ? )
60 node-in-d peek dup value?
61 [ value-literal sequence? ] [ drop f ] if ;
63 : expand-member ( #call quot -- )
64 >r dup node-in-d peek value-literal r> call f splice-quot ;
66 : bit-member-n 256 ; inline
68 : bit-member? ( seq -- ? )
69 #! Can we use a fast byte array test here?
71 { [ dup length 8 < ] [ f ] }
72 { [ dup [ integer? not ] contains? ] [ f ] }
73 { [ dup [ 0 < ] contains? ] [ f ] }
74 { [ dup [ bit-member-n >= ] contains? ] [ f ] }
78 : bit-member-seq ( seq -- flags )
79 bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ;
81 : exact-float? ( f -- ? )
82 dup float? [ dup >integer >float = ] [ drop f ] if ; inline
84 : bit-member-quot ( seq -- newquot )
86 [ drop ] % ! drop the sequence itself; we don't use it at run time
90 { [ over fixnum? ] [ ?nth 1 eq? ] }
91 { [ over bignum? ] [ ?nth 1 eq? ] }
92 { [ over exact-float? ] [ ?nth 1 eq? ] }
98 : member-quot ( seq -- newquot )
102 [ literalize [ t ] ] { } map>assoc
103 [ drop f ] suffix [ nip case ] curry
107 { [ dup literal-member? ] [ [ member-quot ] expand-member ] }
110 : memq-quot ( seq -- newquot )
111 [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
112 [ drop f ] suffix [ nip cond ] curry ;
115 { [ dup literal-member? ] [ [ memq-quot ] expand-member ] }
118 ! if the result of eq? is t and the second input is a literal,
119 ! the first input is equal to the second
121 dup node-in-d second dup value? [
123 value-literal 0 `input literal,
124 \ f class-not 0 `output class,
129 ] "constraints" set-word-prop
131 ! Eliminate instance? checks when the outcome is known at compile time
132 : (optimize-instance) ( #call -- #call value class/f )
133 [ ] [ in-d>> first ] [ dup in-d>> second node-literal ] tri ;
135 : optimize-instance? ( #call -- ? )
136 (optimize-instance) dup class?
137 [ optimize-check? ] [ 3drop f ] if ;
139 : optimize-instance ( #call -- node )
140 (optimize-instance) optimize-check ;
143 { [ dup optimize-instance? ] [ optimize-instance ] }
146 ! This is a special-case hack
147 : redundant-array-capacity-check? ( #call -- ? )
148 dup in-d>> first node-literal [ 0 = ] [ fixnum? ] bi and ;
151 { [ dup redundant-array-capacity-check? ] [ [ drop t ] f splice-quot ] }
154 ! eq? on the same object is always t
156 { { @ @ } [ 2drop t ] }
160 { first first2 first3 first4 }
161 [ { array } "specializer" set-word-prop ] each
163 { peek pop* pop push } [
164 { vector } "specializer" set-word-prop
168 { { string sbuf } { array vector } { byte-array byte-vector } }
169 "specializer" set-word-prop
172 { { string string } { array array } }
173 "specializer" set-word-prop
176 { { fixnum fixnum string } { fixnum fixnum array } }
177 "specializer" set-word-prop
180 { { string } { array } }
181 "specializer" set-word-prop
185 "specializer" set-word-prop
187 \ find-last-sep { string sbuf } "specializer" set-word-prop
189 \ >string { sbuf } "specializer" set-word-prop
191 \ >array { { string } { vector } } "specializer" set-word-prop
193 \ >vector { { array } { vector } } "specializer" set-word-prop
195 \ >sbuf { string } "specializer" set-word-prop
197 \ split, { string string } "specializer" set-word-prop
199 \ memq? { array } "specializer" set-word-prop
201 \ member? { fixnum string } "specializer" set-word-prop
203 \ assoc-stack { vector } "specializer" set-word-prop
205 \ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
207 \ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop