1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes classes.algebra
4 combinators definitions generic hashtables kernel
5 kernel.private layouts math namespaces quotations
6 sequences words generic.single.private effects make
10 ERROR: no-method object generic ;
12 ERROR: inconsistent-next-method class generic ;
14 TUPLE: single-combination ;
16 PREDICATE: single-generic < generic
17 "combination" word-prop single-combination? ;
19 GENERIC: dispatch# ( word -- n )
21 M: generic dispatch# "combination" word-prop dispatch# ;
28 : with-combination ( combination quot -- )
29 [ combination ] dip with-variable ; inline
31 HOOK: picker combination ( -- quot )
33 M: single-combination next-method-quot* ( class generic combination -- quot )
35 2dup next-method dup [
37 pick "predicate" word-prop %
39 [ inconsistent-next-method ] 2curry ,
41 ] [ ] make picker prepend
45 : method-for-object ( obj word -- method )
46 [ [ method-classes [ instance? ] with filter smallest-class ] keep method ]
47 [ "default-method" word-prop ]
50 M: single-combination make-default-method
51 [ [ picker ] dip [ no-method ] curry append ] with-combination ;
53 ! ! ! Build an engine ! ! !
55 : find-default ( methods -- default )
56 #! Side-effects methods.
57 [ object bootstrap-word ] dip delete-at* [
58 drop generic-word get "default-method" word-prop
62 TUPLE: predicate-engine class methods ;
64 C: <predicate-engine> predicate-engine
66 : push-method ( method specializer atomic assoc -- )
68 [ ] [ H{ } clone <predicate-engine> ] ?if
69 [ methods>> set-at ] keep
72 : flatten-method ( class method assoc -- )
73 [ [ flatten-class keys ] keep ] 2dip [
74 [ spin ] dip push-method
77 : flatten-methods ( assoc -- assoc' )
78 H{ } clone [ [ flatten-method ] curry assoc-each ] keep ;
81 : split-methods ( assoc class -- first second )
82 [ [ nip class<= not ] curry assoc-filter ]
83 [ [ nip class<= ] curry assoc-filter ] 2bi ;
85 : convert-methods ( assoc class word -- assoc' )
86 over [ split-methods ] 2dip pick assoc-empty?
87 [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline
89 ! 2.1 Convert tuple methods
90 TUPLE: echelon-dispatch-engine n methods ;
92 C: <echelon-dispatch-engine> echelon-dispatch-engine
94 TUPLE: tuple-dispatch-engine echelons ;
96 : push-echelon ( class method assoc -- )
97 [ swap dup "layout" word-prop third ] dip
98 [ ?set-at ] change-at ;
100 : echelon-sort ( assoc -- assoc' )
101 #! Convert an assoc mapping classes to methods into an
102 #! assoc mapping echelons to assocs. The first echelon
104 H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ;
106 : <tuple-dispatch-engine> ( methods -- engine )
108 [ dupd <echelon-dispatch-engine> ] assoc-map
109 \ tuple-dispatch-engine boa ;
111 : convert-tuple-methods ( assoc -- assoc' )
113 \ <tuple-dispatch-engine> convert-methods ;
115 ! 2.2 Convert hi-tag methods
116 TUPLE: hi-tag-dispatch-engine methods ;
118 C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
120 : convert-hi-tag-methods ( assoc -- assoc' )
121 \ hi-tag bootstrap-word
122 \ <hi-tag-dispatch-engine> convert-methods ;
125 TUPLE: tag-dispatch-engine methods ;
127 C: <tag-dispatch-engine> tag-dispatch-engine
129 : <engine> ( assoc -- engine )
131 convert-tuple-methods
132 convert-hi-tag-methods
133 <tag-dispatch-engine> ;
135 ! ! ! Compile engine ! ! !
136 GENERIC: compile-engine ( engine -- obj )
138 : compile-engines ( assoc -- assoc' )
139 [ compile-engine ] assoc-map ;
141 : compile-engines* ( assoc -- assoc' )
142 [ over assumed [ compile-engine ] with-variable ] assoc-map ;
144 : direct-dispatch-table ( assoc n -- table )
145 default get <array> [ <enum> swap update ] keep ;
147 : lo-tag-number ( class -- n )
148 "type" word-prop dup num-tags get iota member?
149 [ drop object tag-number ] unless ;
151 M: tag-dispatch-engine compile-engine
152 methods>> compile-engines*
153 [ [ lo-tag-number ] dip ] assoc-map
154 num-tags get direct-dispatch-table ;
156 : num-hi-tags ( -- n ) num-types get num-tags get - ;
158 : hi-tag-number ( class -- n ) "type" word-prop ;
160 M: hi-tag-dispatch-engine compile-engine
161 methods>> compile-engines*
162 [ [ hi-tag-number num-tags get - ] dip ] assoc-map
163 num-hi-tags direct-dispatch-table ;
165 : build-fast-hash ( methods -- buckets )
166 >alist V{ } clone [ hashcode 1array ] distribute-buckets
167 [ compile-engines* >alist { } join ] map ;
169 M: echelon-dispatch-engine compile-engine
171 methods>> dup assoc-size {
172 { 0 [ drop default get ] }
173 { 1 [ >alist first second compile-engine ] }
176 methods>> compile-engines* build-fast-hash
179 M: tuple-dispatch-engine compile-engine
181 echelons>> compile-engines
182 dup keys supremum 1 + f <array>
183 [ <enum> swap update ] keep
186 PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
188 SYMBOL: predicate-engines
190 : sort-methods ( assoc -- assoc' )
191 >alist [ keys sort-classes ] keep extract-keys ;
193 : quote-methods ( assoc -- assoc' )
194 [ 1quotation \ drop prefix ] assoc-map ;
196 : find-predicate-engine ( classes -- word )
197 predicate-engines get [ at ] curry map-find drop ;
199 : next-predicate-engine ( engine -- word )
201 find-predicate-engine
204 : methods-with-default ( engine -- assoc )
205 [ methods>> clone ] [ next-predicate-engine ] bi
206 object bootstrap-word pick set-at ;
208 : keep-going? ( assoc -- ? )
209 assumed get swap second first class<= ;
213 : prune-redundant-predicates ( assoc -- default assoc' )
215 { [ dup empty? ] [ drop [ unreachable ] { } ] }
216 { [ dup length 1 = ] [ first second { } ] }
217 { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
218 [ [ first second ] [ rest-slice ] bi ]
221 : class-predicates ( assoc -- assoc )
222 [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
224 : <predicate-engine-word> ( -- word )
225 generic-word get name>> "/predicate-engine" append f <word>
226 dup generic-word get "owner-generic" set-word-prop ;
228 M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
230 : define-predicate-engine ( alist -- word )
231 [ <predicate-engine-word> ] dip
232 [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
234 : compile-predicate-engine ( engine -- word )
238 prune-redundant-predicates
240 [ last ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
242 M: predicate-engine compile-engine
243 [ compile-predicate-engine ] [ class>> ] bi
244 [ drop ] [ predicate-engines get set-at ] 2bi ;
246 M: word compile-engine ;
248 M: f compile-engine ;
250 : build-decision-tree ( generic -- methods )
251 [ "engines" word-prop forget-all ]
252 [ V{ } clone "engines" set-word-prop ]
254 "methods" word-prop clone
255 [ find-default default set ]
256 [ <engine> compile-engine ] bi
259 HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
261 M: single-combination inline-cache-quots 2drop f f ;
263 : define-inline-cache-quot ( word methods -- )
264 [ drop ] [ inline-cache-quots ] 2bi
265 [ >>pic-def ] [ >>pic-tail-def ] bi*
268 HOOK: mega-cache-quot combination ( methods -- quot/f )
270 M: single-combination perform-combination
272 H{ } clone predicate-engines set
274 dup build-decision-tree
275 [ "decision-tree" set-word-prop ]
276 [ mega-cache-quot define ]
277 [ define-inline-cache-quot ]