/core/generic/single/single.factor

  1! Copyright (C) 2009, 2010 Slava Pestov.
  2! See http://factorcode.org/license.txt for BSD license.
  3USING: accessors arrays assocs classes classes.algebra
  4combinators combinators.private definitions effects generic
  5hashtables kernel layouts make math namespaces quotations
  6sequences words ;
  7FROM: assocs => change-at ;
  8IN: generic.single
  9
 10ERROR: no-method object generic ;
 11
 12ERROR: inconsistent-next-method class generic ;
 13
 14TUPLE: single-combination ;
 15
 16PREDICATE: single-generic < generic
 17    "combination" word-prop single-combination? ;
 18
 19M: single-generic make-inline cannot-be-inline ;
 20
 21GENERIC: dispatch# ( word -- n )
 22
 23M: generic dispatch# "combination" word-prop dispatch# ;
 24
 25SYMBOL: assumed
 26SYMBOL: default
 27SYMBOL: generic-word
 28SYMBOL: combination
 29
 30: with-combination ( combination quot -- )
 31    [ combination ] dip with-variable ; inline
 32
 33HOOK: picker combination ( -- quot )
 34
 35M: single-combination next-method-quot* ( class generic combination -- quot )
 36    [
 37        2dup next-method dup [
 38            [
 39                pick predicate-def %
 40                1quotation ,
 41                [ inconsistent-next-method ] 2curry ,
 42                \ if ,
 43            ] [ ] make picker prepend
 44        ] [ 3drop f ] if
 45    ] with-combination ;
 46
 47: method-for-object ( obj word -- method )
 48    [
 49        [ method-classes [ instance? ] with filter smallest-class ] keep
 50        ?lookup-method
 51    ] [ "default-method" word-prop ]
 52    bi or ;
 53
 54M: single-combination make-default-method
 55    [ [ picker ] dip [ no-method ] curry append ] with-combination ;
 56
 57! ! ! Build an engine ! ! !
 58
 59: find-default ( methods -- default )
 60    #! Side-effects methods.
 61    [ object bootstrap-word ] dip delete-at* [
 62        drop generic-word get "default-method" word-prop
 63    ] unless ;
 64
 65! 1. Flatten methods
 66TUPLE: predicate-engine class methods ;
 67
 68C: <predicate-engine> predicate-engine
 69
 70: push-method ( method class atomic assoc -- )
 71    dupd [
 72        [ ] [ H{ } clone <predicate-engine> ] ?if
 73        [ methods>> set-at ] keep
 74    ] change-at ;
 75
 76: flatten-method ( method class assoc -- )
 77    over flatten-class keys
 78    [ swap push-method ] with with with each ;
 79
 80: flatten-methods ( assoc -- assoc' )
 81    H{ } clone [ [ swapd flatten-method ] curry assoc-each ] keep ;
 82
 83! 2. Convert methods
 84: split-methods ( assoc class -- first second )
 85    [ [ nip class<= not ] curry assoc-filter ]
 86    [ [ nip class<=     ] curry assoc-filter ] 2bi ;
 87
 88: convert-methods ( assoc class word -- assoc' )
 89    over [ split-methods ] 2dip pick assoc-empty?
 90    [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline
 91
 92! 2.1 Convert tuple methods
 93TUPLE: echelon-dispatch-engine n methods ;
 94
 95C: <echelon-dispatch-engine> echelon-dispatch-engine
 96
 97TUPLE: tuple-dispatch-engine echelons ;
 98
 99: push-echelon ( class method assoc -- )
100    [ swap dup "layout" word-prop third ] dip
101    [ ?set-at ] change-at ;
102
103: echelon-sort ( assoc -- assoc' )
104    #! Convert an assoc mapping classes to methods into an
105    #! assoc mapping echelons to assocs. The first echelon
106    #! is always there
107    H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ;
108
109: copy-superclass-methods ( engine superclass assoc -- )
110    at* [ [ methods>> ] bi@ assoc-union! drop ] [ 2drop ] if ;
111
112: copy-superclasses-methods ( class engine assoc -- )
113    [ superclasses ] 2dip
114    [ swapd copy-superclass-methods ] 2curry each ;
115
116: convert-tuple-inheritance ( assoc -- assoc' )
117    #! A method on a superclass A might have a higher precedence
118    #! than a method on a subclass B, if the methods are
119    #! defined on incomparable classes that happen to contain
120    #! A and B, respectively. Copy A's methods into B's set so
121    #! that they can be sorted and selected properly.
122    dup dup [ copy-superclasses-methods ] curry assoc-each ;
123
124: <tuple-dispatch-engine> ( methods -- engine )
125    convert-tuple-inheritance echelon-sort
126    [ dupd <echelon-dispatch-engine> ] assoc-map
127    \ tuple-dispatch-engine boa ;
128
129: convert-tuple-methods ( assoc -- assoc' )
130    tuple bootstrap-word
131    \ <tuple-dispatch-engine> convert-methods ;
132
133! 3 Tag methods
134TUPLE: tag-dispatch-engine methods ;
135
136C: <tag-dispatch-engine> tag-dispatch-engine
137
138: <engine> ( assoc -- engine )
139    flatten-methods
140    convert-tuple-methods
141    <tag-dispatch-engine> ;
142
143! ! ! Compile engine ! ! !
144GENERIC: compile-engine ( engine -- obj )
145
146: compile-engines ( assoc -- assoc' )
147    [ compile-engine ] assoc-map ;
148
149: compile-engines* ( assoc -- assoc' )
150    [ over assumed [ compile-engine ] with-variable ] assoc-map ;
151
152: direct-dispatch-table ( assoc n -- table )
153    default get <array> <enum> swap assoc-union! seq>> ;
154
155: tag-number ( class -- n ) "type" word-prop ;
156
157M: tag-dispatch-engine compile-engine
158    methods>> compile-engines*
159    [ [ tag-number ] dip ] assoc-map
160    num-types get direct-dispatch-table ;
161
162: build-fast-hash ( methods -- buckets )
163    >alist V{ } clone [ hashcode 1array ] distribute-buckets
164    [ compile-engines* >alist { } join ] map ;
165
166M: echelon-dispatch-engine compile-engine
167    dup n>> 0 = [
168        methods>> dup assoc-size {
169            { 0 [ drop default get ] }
170            { 1 [ >alist first second compile-engine ] }
171        } case
172    ] [
173        methods>> compile-engines* build-fast-hash
174    ] if ;
175
176M: tuple-dispatch-engine compile-engine
177    tuple assumed [
178        echelons>> compile-engines
179        dup keys supremum 1 + f <array>
180        <enum> swap assoc-union! seq>>
181    ] with-variable ;
182
183PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
184
185SYMBOL: predicate-engines
186
187: sort-methods ( assoc -- assoc' )
188    >alist [ keys sort-classes ] keep extract-keys ;
189
190: quote-methods ( assoc -- assoc' )
191    [ 1quotation \ drop prefix ] assoc-map ;
192
193: find-predicate-engine ( classes -- word )
194    predicate-engines get [ at ] curry map-find drop ;
195
196: next-predicate-engine ( engine -- word )
197    class>> superclasses
198    find-predicate-engine
199    default get or ;
200
201: methods-with-default ( engine -- assoc )
202    [ methods>> clone ] [ next-predicate-engine ] bi
203    object bootstrap-word pick set-at ;
204
205: keep-going? ( assoc -- ? )
206    assumed get swap second first class<= ;
207
208ERROR: unreachable ;
209
210: prune-redundant-predicates ( assoc -- default assoc' )
211    {
212        { [ dup empty? ] [ drop [ unreachable ] { } ] }
213        { [ dup length 1 = ] [ first second { } ] }
214        { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
215        [ [ first second ] [ rest-slice ] bi ]
216    } cond ;
217
218: class-predicates ( assoc -- assoc )
219    [ [ predicate-def [ dup ] prepend ] dip ] assoc-map ;
220
221: <predicate-engine-word> ( -- word )
222    generic-word get name>> "/predicate-engine" append f <word>
223    dup generic-word get "owner-generic" set-word-prop ;
224
225M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
226
227: define-predicate-engine ( alist -- word )
228    [ <predicate-engine-word> ] dip
229    [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
230
231: compile-predicate-engine ( engine -- word )
232    methods-with-default
233    sort-methods
234    quote-methods
235    prune-redundant-predicates
236    class-predicates
237    [ last ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
238
239M: predicate-engine compile-engine
240    [ compile-predicate-engine ] [ class>> ] bi
241    [ drop ] [ predicate-engines get set-at ] 2bi ;
242
243M: word compile-engine ;
244
245M: f compile-engine ;
246
247: build-decision-tree ( generic -- methods )
248    [ "engines" word-prop forget-all ]
249    [ V{ } clone "engines" set-word-prop ]
250    [
251        "methods" word-prop clone
252        [ find-default default set ]
253        [ <engine> compile-engine ] bi
254    ] tri ;
255
256HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
257
258M: single-combination inline-cache-quots 2drop f f ;
259
260: define-inline-cache-quot ( word methods -- )
261    [ drop ] [ inline-cache-quots ] 2bi
262    [ >>pic-def ] [ >>pic-tail-def ] bi*
263    drop ;
264
265HOOK: mega-cache-quot combination ( methods -- quot/f )
266
267M: single-combination perform-combination
268    [
269        H{ } clone predicate-engines set
270        dup generic-word set
271        dup build-decision-tree
272        [ "decision-tree" set-word-prop ]
273        [ mega-cache-quot define ]
274        [ define-inline-cache-quot ]
275        2tri
276    ] with-combination ;