1 ! Copyright (C) 2009, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs classes classes.algebra
4 combinators combinators.private definitions effects generic
5 hashtables kernel layouts make math namespaces quotations
7 FROM: assocs => change-at ;
11 PRIMITIVE: inline-cache-miss ( generic methods index cache -- )
12 PRIMITIVE: inline-cache-miss-tail ( generic methods index cache -- )
13 PRIMITIVE: lookup-method ( object methods -- method )
14 PRIMITIVE: mega-cache-lookup ( methods index cache -- )
15 PRIMITIVE: mega-cache-miss ( methods index cache -- method )
18 ERROR: no-method object generic ;
20 ERROR: inconsistent-next-method class generic ;
22 TUPLE: single-combination ;
24 PREDICATE: single-generic < generic
25 "combination" word-prop single-combination? ;
27 M: single-generic make-inline cannot-be-inline ;
29 GENERIC: dispatch# ( word -- n )
31 M: generic dispatch# "combination" word-prop dispatch# ;
38 : with-combination ( combination quot -- )
39 [ combination ] dip with-variable ; inline
41 HOOK: picker combination ( -- quot )
43 M: single-combination next-method-quot* ( class generic combination -- quot )
45 2dup next-method dup [
49 [ inconsistent-next-method ] 2curry ,
51 ] [ ] make picker prepend
55 : method-for-object ( obj word -- method )
57 [ method-classes [ instance? ] with filter smallest-class ] keep
59 ] [ "default-method" word-prop ]
62 M: single-combination make-default-method
63 [ [ picker ] dip [ no-method ] curry append ] with-combination ;
65 ! ! ! Build an engine ! ! !
67 : find-default ( methods -- default )
68 #! Side-effects methods.
69 [ object bootstrap-word ] dip delete-at* [
70 drop generic-word get "default-method" word-prop
74 TUPLE: predicate-engine class methods ;
76 C: <predicate-engine> predicate-engine
78 : push-method ( method class atomic assoc -- )
80 [ ] [ H{ } clone <predicate-engine> ] ?if
81 [ methods>> set-at ] keep
84 : flatten-method ( method class assoc -- )
85 over flatten-class keys
86 [ swap push-method ] 2with with each ;
88 : flatten-methods ( assoc -- assoc' )
89 H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ;
92 : split-methods ( assoc class -- first second )
93 [ [ nip class<= ] curry assoc-reject ]
94 [ [ nip class<= ] curry assoc-filter ] 2bi ;
96 : convert-methods ( assoc class word -- assoc' )
97 over [ split-methods ] 2dip pick assoc-empty?
98 [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline
100 ! 2.1 Convert tuple methods
101 TUPLE: echelon-dispatch-engine n methods ;
103 C: <echelon-dispatch-engine> echelon-dispatch-engine
105 TUPLE: tuple-dispatch-engine echelons ;
107 : push-echelon ( class method assoc -- )
108 [ swap dup "layout" word-prop third ] dip
109 [ ?set-at ] change-at ;
111 : echelon-sort ( assoc -- assoc' )
112 #! Convert an assoc mapping classes to methods into an
113 #! assoc mapping echelons to assocs. The first echelon
115 H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ;
117 : copy-superclass-methods ( engine superclass assoc -- )
118 at* [ [ methods>> ] bi@ assoc-union! drop ] [ 2drop ] if ;
120 : copy-superclasses-methods ( class engine assoc -- )
121 [ superclasses ] 2dip
122 [ swapd copy-superclass-methods ] 2curry each ;
124 : convert-tuple-inheritance ( assoc -- assoc' )
125 #! A method on a superclass A might have a higher precedence
126 #! than a method on a subclass B, if the methods are
127 #! defined on incomparable classes that happen to contain
128 #! A and B, respectively. Copy A's methods into B's set so
129 #! that they can be sorted and selected properly.
130 dup dup [ copy-superclasses-methods ] curry assoc-each ;
132 : <tuple-dispatch-engine> ( methods -- engine )
133 convert-tuple-inheritance echelon-sort
134 [ dupd <echelon-dispatch-engine> ] assoc-map
135 tuple-dispatch-engine boa ;
137 : convert-tuple-methods ( assoc -- assoc' )
139 \ <tuple-dispatch-engine> convert-methods ;
142 TUPLE: tag-dispatch-engine methods ;
144 C: <tag-dispatch-engine> tag-dispatch-engine
146 : <engine> ( assoc -- engine )
148 convert-tuple-methods
149 <tag-dispatch-engine> ;
151 ! ! ! Compile engine ! ! !
152 GENERIC: compile-engine ( engine -- obj )
154 : compile-engines ( assoc -- assoc' )
155 [ compile-engine ] assoc-map ;
157 : compile-engines* ( assoc -- assoc' )
158 [ over assumed [ compile-engine ] with-variable ] assoc-map ;
160 : direct-dispatch-table ( assoc n -- table )
161 default get <array> <enum> swap assoc-union! seq>> ;
163 : tag-number ( class -- n ) "type" word-prop ;
165 M: tag-dispatch-engine compile-engine
166 methods>> compile-engines*
167 [ [ tag-number ] dip ] assoc-map
168 num-types get direct-dispatch-table ;
170 : build-fast-hash ( methods -- buckets )
171 >alist V{ } clone [ hashcode 1array ] distribute-buckets
172 [ compile-engines* >alist concat ] map ;
174 M: echelon-dispatch-engine compile-engine
176 methods>> dup assoc-size {
177 { 0 [ drop default get ] }
178 { 1 [ >alist first second compile-engine ] }
181 methods>> compile-engines* build-fast-hash
184 M: tuple-dispatch-engine compile-engine
186 echelons>> compile-engines
187 dup keys supremum 1 + f <array>
188 <enum> swap assoc-union! seq>>
191 PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
193 SYMBOL: predicate-engines
195 : sort-methods ( assoc -- assoc' )
196 >alist [ keys sort-classes ] keep extract-keys ;
198 : quote-methods ( assoc -- assoc' )
199 [ 1quotation \ drop prefix ] assoc-map ;
201 : find-predicate-engine ( classes -- word )
202 predicate-engines get [ at ] curry map-find drop ;
204 : next-predicate-engine ( engine -- word )
206 find-predicate-engine
209 : methods-with-default ( engine -- assoc )
210 [ methods>> clone ] [ next-predicate-engine ] bi
211 object bootstrap-word pick set-at ;
213 : keep-going? ( assoc -- ? )
214 assumed get swap second first class<= ;
218 : prune-redundant-predicates ( assoc -- default assoc' )
220 { [ dup empty? ] [ drop [ unreachable ] { } ] }
221 { [ dup length 1 = ] [ first second { } ] }
222 { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
223 [ [ first second ] [ rest-slice ] bi ]
226 : class-predicates ( assoc -- assoc )
227 [ [ predicate-def [ dup ] prepend ] dip ] assoc-map ;
229 : <predicate-engine-word> ( -- word )
230 generic-word get name>> "/predicate-engine" append f <word>
231 dup generic-word get "owner-generic" set-word-prop ;
233 M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
235 : define-predicate-engine ( alist -- word )
236 [ <predicate-engine-word> ] dip
237 [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
239 : compile-predicate-engine ( engine -- word )
243 prune-redundant-predicates
245 [ last ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
247 M: predicate-engine compile-engine
248 [ compile-predicate-engine ] [ class>> ] bi
249 [ drop ] [ predicate-engines get set-at ] 2bi ;
251 M: word compile-engine ;
253 M: f compile-engine ;
255 : build-decision-tree ( generic -- methods )
256 [ "engines" word-prop forget-all ]
257 [ V{ } clone "engines" set-word-prop ]
259 "methods" word-prop clone
260 [ find-default default set ]
261 [ <engine> compile-engine ] bi
264 HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
266 M: single-combination inline-cache-quots 2drop f f ;
268 : define-inline-cache-quot ( word methods -- )
269 [ drop ] [ inline-cache-quots ] 2bi
270 [ >>pic-def ] [ >>pic-tail-def ] bi*
273 HOOK: mega-cache-quot combination ( methods -- quot/f )
275 M: single-combination perform-combination
277 H{ } clone predicate-engines set
279 dup build-decision-tree
280 [ "decision-tree" set-word-prop ]
281 [ mega-cache-quot define ]
282 [ define-inline-cache-quot ]